Using Global Address List from Excel to Create

[SherryO]

I have a template in Excel that uses a UserForm to create a list for distribution (One on the form in list format, one for email dist). Is there a way to use the Global Address List from Outlook to populate the lists? Right now I'm using a manually created list of names and then getting the email address to build the list. I've seen some code posted out here, but I don't know how to make it work. If anyone can help, I would appreciate it. Thanks

[VBA]Option Explicit
Option Compare Text
Dim sFolder As String

Private Sub UserForm_Initialize()
Dim i As Long
Dim FileName As Variant

Dim rngHCE As Range, pdfFile As Variant
Dim HCE_Num As String, HoldADD As String, LookIN As String, Att As String

'Get HCE num cell
Set rngHCE = Sheets("Jobs").Range("D" & Selection.row)
HCE_Num = rngHCE.Text

'Use the hyperlink's address and break it down to get the folder it resides in
Att = rngHCE.Hyperlinks(1).Address
HoldADD = WorksheetFunction.Substitute(Att, "\", "|", Len(Att) - Len(WorksheetFunction.Substitute(Att, "\", "")))
sFolder = Left(HoldADD, InStr(1, HoldADD, "|") - 1)

'Perform a search to look for the pdf files. Then check to see if they have
'the HCE number within the file name...if yes, add it to the list box.
With Application.FileSearch
.NewSearch
.LookIN = sFolder
.SearchSubFolders = False
.FileName = "pdf"

If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
If InStr(1, .FoundFiles(i), HCE_Num, vbTextCompare) <> 0 Then
FileName = Split(.FoundFiles(i), "\")
lstPDF.AddItem FileName(UBound(FileName))
End If
Next
End If
End With

'If no items were found in the file search
If lstPDF.ListCount = 0 Then
MsgBox "No Items found", vbOKOnly, "Items"
End If

End Sub

Private Sub cmdInsert_Click()
Dim ArrayPDF() As Variant
Dim i As Long, j As Long
Dim blnSelected As Boolean

Dim appOutlook As Object
Dim OLItem As Object

Dim strProj As String
Dim strCompany As String
Dim strBody As String
Dim LookIN As String
ReDim ArrayPDF(0)

'Add pdf files (location w/ name) to a dynamic array
For i = 0 To lstPDF.ListCount - 1
If lstPDF.Selected(i) Then
blnSelected = True
ReDim Preserve ArrayPDF(j)
ArrayPDF(j) = sFolder & "\" & lstPDF.List(i)
j = j + 1
End If
Next

'If there were no items selected in the list box, exit sub
If blnSelected = False Then
MsgBox "No Items selected", vbOKOnly, "Selected Items"
Exit Sub
End If

'Start the outlook session
Set appOutlook = CreateObject("Outlook.Application")
Set OLItem = appOutlook.CreateItem(0)

If Selection.row < 6 Then
Set appOutlook = Nothing
Set OLItem = Nothing
Exit Sub
End If

'Create the body of the Outlook email
'-------------------------------------------------------------------------
strCompany = Sheets("Jobs").Range("C" & Selection.row).Text
strProj = Sheets("Jobs").Range("E" & Selection.row).Text

strBody = "Hey," & vbCrLf & vbCrLf & "Here is the " & strProj & _
" project from " & strCompany & ". Let me know what you think." _
& vbCrLf & vbCrLf & "Thanks," & vbCrLf & "Joseph" _
& vbCrLf & vbCrLf & vbCrLf
'-------------------------------------------------------------------------

'Add the email items
With OLItem
.Subject = strProj & " Project"

For i = LBound(ArrayPDF()) To UBound(ArrayPDF())
.Attachments.Add ArrayPDF(i), 1, i + 1
strBody = vbCrLf & strBody
Next i

.Body = strBody
.To = "myEngineer@someEmail.com"
.Display
End With

Set OLItem = Nothing
Set appOutlook = Nothing


Unload Me
End Sub

Private Sub cmdCancel_Click()
Unload Me
End Sub
[/VBA]

[SherryO]

I'm still needing help if anyone can. Thanks!!!

[CBrine]

SherryO,
I do something similiar in an access database. The code accesses the local mailbox GAL and updates an access table based on that. The only problem is that it runs afowl of the outlook security, so you will be prompted to allow access to outlook. I have modified this code to dump the listing to the activesheet, so run it a blank workbook to get a feel for how it works and move on to integrating it with your code.

[vba]
Sub CreateAddressList()
'Creates MAPI session Variable
Dim objSession As Object
'Creates Storage for Address List Entries
Dim gal As Object
Dim galEntries As Object
Dim Counter As Double
'Open Email Session
Set objSession = CreateObject("MAPI.Session")
objSession.Logon
'Setup all entries in GAL
Set gal = objSession.GetAddressList(0)
Set galEntries = gal.AddressEntries
Counter = 1
'Popluate Gloabl Address List Table with GAL entries
Do Until Err.Number <> 0
ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).Offset(1, 0) = galEntries.Item(Counter)
Counter = Counter + 1
Loop
objSession.Logoff
End sub

[/vba]

HTH
Cal

[SherryO]

Thanks, this works great for a dump of the list, but I guess i didn't explain myself very well. I'm trying to get it so that excel opens the Select Names dialog box in Outlook, then the user can select any of the names in either the GAL or contacts list and have it write back to excel with the names and the email address of the selected names. Am I asking for the moon? I've been trying to do this as a low priority for months with no success. I do have it working with a similar code above, although your's seems much more efficient. I hate the security, so I have it running from my machine to update a template so my users don't have to click yes. Any thoughts would be greatly appreciated. Thank you!!

[CBrine]

Ah... I'm pretty sure that's what I did originally, when I was trying to get the dump. Let me dig into it for a while and see what I can come up with. Should be just some twists on the code I have.

Cal

[CBrine]

SherryO,

I hate the security, so I have it running from my machine to update a template so my users don't have to click yes. Any thoughts would be greatly appreciated. Thank you!!

This kinda confuses me? If you are updating a template somewhere you will need the dump of the GAL to bypass the security issue? Can you expand on this?