Respective id's in the textbox...

[v_gyku]

I have a small form on load of which i get the contact list in form of lastname,firstname.

when i select the names from the list box the selected names goes to the textbox in another form.

But i want email ids of the seleted names to go in the textbox.

I cant take emailids in the small form, it has to be this way only.

This is the code i have written which takes names to the textbox, can u modify it for emailids.



Dim Starray As String
Dim strAns As String
Dim str As Integer
Dim strArray()
Dim AppOutlook As outlook.Application
Dim CloseOutlook As Boolean
Dim SaveToFolderArray
Dim SaveToFolderArrayTemp
Const labelFileName = "Contacts Mailing Labels.doc"
' Dim myOlExp As Outlook.Explorer

Private Sub Btnselectemail_Click()
Me.Hide
End Sub

Private Sub Form_Load()
' Function GetContactList() As Boolean
On Error GoTo ContactListErr
' Create an Outlook application object
If IsAppOpen("Outlook", "Application") Then
Set AppOutlook = GetObject(, "Outlook.Application")
CloseOutlook = False
Else
Set AppOutlook = CreateObject("Outlook.Application")
CloseOutlook = True
End If
' Create Outlook namespace object
Dim oNameSpace As outlook.Namespace
Set oNameSpace = AppOutlook.GetNamespace("MAPI")
' Create Outlook contact folder object
Dim oContactFolder As Object
Set oContactFolder = oNameSpace.GetDefaultFolder(outlook.OlDefaultFolders.olFolderContacts)
If (oContactFolder Is Nothing) Or (oContactFolder.Items.Count < 1) Then
GetContactList = False
Else
For Each Contact In oContactFolder.Items
If Contact.Class = olContact Then
lstContactList.AddItem Contact.LastName & ", " & Contact.FirstName
End If
Next
GetContactList = True
End If
Set oNameSpace = Nothing
Set oContactFolder = Nothing
' Exit the Outlook application
If CloseOutlook = True Then
AppOutlook.Quit
End If
Set AppOutlook = Nothing
Exit Sub
ContactListErr:
On Error Resume Next
If Not (oNameSpace Is Nothing) Then
Set oNameSpace = Nothing
End If
If Not (oContactFolder Is Nothing) Then
Set oContactFolder = Nothing
End If
If Not (AppOutlook Is Nothing) Then
If CloseOutlook = True Then
AppOutlook.Quit
End If
Set AppOutlook = Nothing
End If
GetContactList = False
' End Function
End Sub


Sub Sort(inpArray(), inpList)
Dim intRet
Dim intCompare
Dim intLoopTimes
Dim strTemp
For intLoopTimes = 1 To UBound(inpArray)
For intCompare = LBound(inpArray) To UBound(inpArray) - 1
intRet = StrComp(inpArray(intCompare), _
inpArray(intCompare + 1), vbTextCompare)
If intRet = 1 Then
' String1 is greater than String2
strTemp = inpArray(intCompare)
inpArray(intCompare) = inpArray(intCompare + 1)
inpArray(intCompare + 1) = strTemp
End If
Next
Next
inpList.Clear
For intCompare = 1 To UBound(inpArray)
inpList.AddItem inpArray(intCompare)
Next
End Sub

[Bob Phillips]

This might help. I have added a listbox click event to load a text box Textbox1. Adjust to suit



Private Sub Form_Load()
' Function GetContactList() As Boolean
On Error GoTo ContactListErr
' Create an Outlook application object
' If IsAppOpen("Outlook", "Application") Then
Set AppOutlook = GetObject(, "Outlook.Application")
CloseOutlook = False
' Else
' Set AppOutlook = CreateObject("Outlook.Application")
' CloseOutlook = True
' End If
' Create Outlook namespace object
Dim oNameSpace As Outlook.NameSpace
Set oNameSpace = AppOutlook.GetNamespace("MAPI")
' Create Outlook contact folder object
Dim oContactFolder As Object
Set oContactFolder = oNameSpace.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderContacts)
If (oContactFolder Is Nothing) Or (oContactFolder.Items.Count < 1) Then
GetContactList = False
Else
For Each contact In oContactFolder.Items
With lstContactList
If contact.Class = olContact Then
.AddItem contact.LastName & ", " & contact.FirstName
.List(.ListCount - 1, 1) = contact.Email1Address
End If
End With
Next
GetContactList = True
End If
Set oNameSpace = Nothing
Set oContactFolder = Nothing
' Exit the Outlook application
If CloseOutlook = True Then
AppOutlook.Quit
End If
Set AppOutlook = Nothing
Exit Sub
ContactListErr:
On Error Resume Next
If Not (oNameSpace Is Nothing) Then
Set oNameSpace = Nothing
End If
If Not (oContactFolder Is Nothing) Then
Set oContactFolder = Nothing
End If
If Not (AppOutlook Is Nothing) Then
If CloseOutlook = True Then
AppOutlook.Quit
End If
Set AppOutlook = Nothing
End If
GetContactList = False
' End Function
End Sub

Private Sub lstContactList_Click()
With lstContactList
TextBox1.Text = .List(.ListIndex, 1)
End With
End Sub