SherryO
10-31-2006, 06:58 AM
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
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
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