PDA

View Full Version : Solved: respective id's in the textbox...



v_gyku
09-16-2005, 09:31 PM
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
10-09-2005, 10:33 AM
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