Solved: 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

[VBA]
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[/VBA]