zielonapani
New Member
- Joined
- Sep 5, 2013
- Messages
- 38
Hi,
I have a a code for a user form where I have a list box with outlook contacts. So far it shows only names&surnames and while multi-selected e-mail addresses are pasted to a textbox (that later-after clicking "Select" Button -will be copied into e-mail's To: box).
I would like to modify the code and have 2 displayed columns (names&surnames AND e-mails). Plus i think i need a code preventing error when for example I have contact that has more than one e-mail address. In this case I think I need to see the person's contact name&surname but with different e-mail addresses in each line. I hope I explained it clearly. I spend hours searching through the internet but unfortunately haven't came up with solution. So please, dear excel geniuses help me
I have a a code for a user form where I have a list box with outlook contacts. So far it shows only names&surnames and while multi-selected e-mail addresses are pasted to a textbox (that later-after clicking "Select" Button -will be copied into e-mail's To: box).
I would like to modify the code and have 2 displayed columns (names&surnames AND e-mails). Plus i think i need a code preventing error when for example I have contact that has more than one e-mail address. In this case I think I need to see the person's contact name&surname but with different e-mail addresses in each line. I hope I explained it clearly. I spend hours searching through the internet but unfortunately haven't came up with solution. So please, dear excel geniuses help me
Code:
Private Sub GetContacts()
Dim oOutlookApp As Outlook.Application
Dim oOutlookNameSpace As Outlook.Namespace
Dim oContacts As Outlook.MAPIFolder
Dim oContact As Outlook.ContactItem
Dim i As Long
Set oOutlookApp = New Outlook.Application
Set oOutlookNameSpace = oOutlookApp.GetNamespace("MAPI")
'Get the contactfolder
Set oContacts = oOutlookNameSpace.GetDefaultFolder(olFolderContacts)
For i = 1 To oContacts.Items.Count
If TypeName(oContacts.Items(i)) = "ContactItem" Then
Set oContact = oContacts.Items(i)
Me.ListBox1.AddItem oContact.Email1Address
Me.ListBox1.List(Me.ListBox1.ListCount - 1, 1) = oContact.LastNameAndFirstName
End If
Next i
Set oContact = Nothing
Set oContacts = Nothing
Set oOutlookNameSpace = Nothing
Set oOutlookApp = Nothing
End Sub
Private Sub cbSelect_Click()
Dim lItem As Long
Dim bSelected As Boolean
For lItem = ListBox1.ListCount - 1 To 0 Step -1
If ListBox1.Selected(lItem) = True Then
bSelected = True
Exit For
End If
Next
If bSelected = True Then
With Me.txtEmail
For lItem = ListBox1.ListCount - 1 To 0 Step -1
If ListBox1.Selected(lItem) = True Then
.Text = ListBox1.List(lItem) & ";" & .Text
ListBox1.Selected(lItem) = False
End If
Next
.Text = Left(.Text, Len(.Text) - 1)
End With
Else
MsgBox "Nothing chosen", vbCritical
End If
End Sub
Private Sub UserForm_Activate()
GetContacts
End Sub