'BEHIND A FORM
'REQUIREMENTS:
'REFERENCE TO MS OUTLOOK 10.0 OR ABOVE.
'3 COMMAND BUTTONS - CMDCLOSE, CMDDISPLAY, AND CMDBROWSE.
'5 LABELS - LBLCONTACTS, LBLLOCATION, LBLPATH, LBLCOUNT (2).
'1 COMBOBOX - CBOCONTACT - LOADS WITH THE SELECTED FOLDERS CONTACTS
Option Explicit
Private moApp As Outlook.Application
Private moNS As Outlook.NameSpace
Private moFolder As Outlook.MAPIFolder
Private moContactItem As Outlook.ContactItem
Private moDistributionList As Outlook.DistListItem
Private mbClose As Boolean
Private Sub cmdClose_Click()
MousePointer = vbHourglass
Unload Me
End Sub
Private Sub cmdBrowse_Click()
Dim i As Integer
Screen.MousePointer = vbHourglass
'SELECT A CONTACT FOLDER TO LIST (PRIVATE OR PUBLIC)
Set moFolder = moNS.PickFolder
If TypeName(moFolder) = "Nothing" Then
Screen.MousePointer = vbNormal
Me.SetFocus
Exit Sub
ElseIf moFolder.DefaultItemType <> olContactItem Then
MsgBox "'Contact' type folders only!", vbOKOnly + vbExclamation, App.ProductName
Screen.MousePointer = vbNormal
Me.SetFocus
Exit Sub
End If
Screen.MousePointer = vbHourglass
Me.SetFocus
lblPath.Caption = moFolder.FolderPath
lblCount(1).Caption = moFolder.Items.Count
cboContact.Clear
cboEntryID.Clear
If moFolder.Items.Count > 0 Then
For i = 1 To moFolder.Items.Count
DoEvents
If moFolder.Items.Item(i).Class = 69 Then
Set moDistributionList = moFolder.Items.Item(i)
cboContact.AddItem moDistributionList.DLName & " (Distributiion List)"
cboContact.ItemData(i - 1) = 0
cboEntryID.AddItem moDistributionList.EntryID
Set moDistributionList = Nothing
Else
Set moContactItem = moFolder.Items.Item(i)
cboContact.AddItem moContactItem.FullName & " (" & moContactItem.CompanyName & ")"
cboContact.ItemData(i - 1) = 1
cboEntryID.AddItem moContactItem.EntryID
Set moContactItem = Nothing
End If
Next
cboContact.ListIndex = 0
Else
cmdDisplay.Enabled = False
End If
Screen.MousePointer = vbNormal
End Sub
Private Sub cmdDisplay_Click()
Dim sContact As String
'SYNC CONTACTS TO ENTRYIDS
cboEntryID.ListIndex = cboContact.ListIndex
If cboContact.ListIndex <> -1 Then
sContact = Left$(cboContact.Text, InStr(1, cboContact.Text, "(") - 2)
If moFolder.Items.Item(sContact).Class = 69 Then
Set moDistributionList = moFolder.Items.Item(cboEntryID.Text)
'MAKE SURE THERE ARE NOT TWO CONTACTS WITH THE SAME NAME
If moDistributionList.EntryID = cboEntryID.Text Then
moDistributionList.Display True
Else
Set moDistributionList = moNS.GetItemFromID(cboEntryID.Text)
moDistributionList.Display True
End If
Set moDistributionList = Nothing
Else
Set moContactItem = moFolder.Items.Item(sContact)
'MAKE SURE THERE ARE NOT TWO CONTACTS WITH THE SAME NAME (DIFFERENT COMPANIES)
If moContactItem.EntryID = cboEntryID.Text Then
moContactItem.Display True
Else
Set moContactItem = moNS.GetItemFromID(cboEntryID.Text)
moContactItem.Display True
End If
Set moContactItem = Nothing
End If
End If
End Sub
Private Sub Form_Load()
On Error GoTo No_Bugs
mbClose = False
'ATTACH TO OUTLOOK IF RUNNING - IF NOT CREATE NEW
Set moApp = GetObject(, "Outlook.Application")
If TypeName(moApp) = "Nothing" Then
Set moApp = New Outlook.Application
mbClose = True
End If
'GET NAMESPACE AND OUTLOOK VERSION
Set moNS = moApp.GetNamespace("MAPI")
If InStr(1, moApp.Version, "10.") > 1 Then
MsgBox "Unsupported Outlook version!", vbOKOnly + vbExclamation, App.ProductName
Set moNS = Nothing
Set moApp = Nothing
End If
frmMain.Caption = App.ProductName
Exit Sub
No_Bugs:
If Err.Number = 429 Then
MsgBox Err.Number & " - " & Err.Description, vbOKOnly + vbExclamation, App.ProductName
Resume Next
Else
MsgBox Err.Number & " - " & Err.Description, vbOKOnly + vbExclamation, App.ProductName
End If
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Set moContactItem = Nothing
Set moFolder = Nothing
Set moNS = Nothing
If mbClose = True And TypeName(moApp) <> "Nothing" Then
moApp.Quit
End If
Set moApp = Nothing
End Sub
