Outlook 2000/2003 Add Contact list in list box

[malik641]

How would I add my contact list to a list box (userform)?


....:think: I'm not sure how much more detail I could add....

TIA

[Tommy]

Hey Joseph,
I wrote this in Word so I'm not sure what you need since I don't know where you are using it. You will need outlook lib checked. This is something I use someplace else so it may not work as expected but I know it will get you started :) :thumb
I wrote it for someone to fill in a form in word with the contact information in outlook. I allowed the contacts to be added deleted and modified from word. Of course the form got filled in and faxed/printed. :whip

Sub GetContacts()
Dim Mase As Outlook.ContactItem
Dim objSession As Outlook.Application
Dim myFolder As MAPIFolder
Dim MyNameSpace As NameSpace
Dim I As Integer
Set objSession = GetObject(, "Outlook.Application")
Set MyNameSpace = objSession.GetNamespace("MAPI")
Set myFolder = MyNameSpace.GetDefaultFolder(olFolderContacts)
ReDim strName(1 To myFolder.Items.Count)
ReDim strStreet(1 To myFolder.Items.Count)
For I = 1 To myFolder.Items.Count
Set Mase = myFolder.Items(I)
'this is where you would do the additem
strName(I) = Mase.CompanyName
strStreet(I) = Mase.MailingAddress
Next
Set objSession = Nothing
Set MyNameSpace = Nothing
Set myFolder = Nothing
Set Mase = Nothing
End Sub

Have fun :)

[malik641]

Thanks Tommy, I'll see what I can do with it.


I'm not familiar with Outlook VBA at all (or Outlook really...well compared to my Excel skills anyway). Know any good websites with tutorials???


BTW, here's the code I have now (without your addition):
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

[Tommy]

F1, Object browser, Google, watch window, a few open days, idle hands and a wondering brain is how I got this far FWIW :rofl:

'Get HCE num cell
right before this I would check for a selected row if not one, stop the form inialize. maybe with a message box :dunno if its just for you no big deal but I forget so my perspective is geared towards that :devil2:

If blnSelected = False or Selection.Row < 6 Then I would make this change just easier OK I'm being picky but thats all I could find hehe. It is real easy to follow, short, sweet, and to the point, good job. :bow:

Don't fall over but I don't use Excel very much. :eek: Not even sure I know how to must less take advantage of all the worksheet functions.

[SherryO]

Can this be done with the Global Address List? Also, could you please attach the workbook? I believe this is exactly what I'm looking for, but it's a bit over my head and I think it would help to see it in the original file. Thanks so much!!
SherryO