home *** CD-ROM | disk | FTP | other *** search
- VERSION 5.00
- Begin VB.Form Contacts
- Caption = "VBA DEMO: Outlook 98 Contacts "
- ClientHeight = 5325
- ClientLeft = 60
- ClientTop = 375
- ClientWidth = 7950
- LinkTopic = "Form1"
- ScaleHeight = 5325
- ScaleWidth = 7950
- StartUpPosition = 3 'Windows Default
- Begin VB.ListBox List2
- BeginProperty Font
- Name = "Verdana"
- Size = 9
- Charset = 0
- Weight = 400
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- Height = 2370
- Left = 5055
- Sorted = -1 'True
- TabIndex = 3
- Top = 435
- Width = 2775
- End
- Begin VB.ListBox List1
- BeginProperty Font
- Name = "Verdana"
- Size = 9
- Charset = 0
- Weight = 400
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- Height = 2370
- Left = 2055
- TabIndex = 2
- Top = 420
- Width = 2775
- End
- Begin VB.CommandButton Command2
- Caption = "View Contacts"
- Enabled = 0 'False
- BeginProperty Font
- Name = "Verdana"
- Size = 9
- Charset = 0
- Weight = 400
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- Height = 495
- Left = 90
- TabIndex = 1
- Top = 1155
- Width = 1815
- End
- Begin VB.CommandButton Command1
- Caption = "Start Outlook"
- BeginProperty Font
- Name = "Verdana"
- Size = 9
- Charset = 0
- Weight = 400
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- Height = 495
- Left = 90
- TabIndex = 0
- Top = 435
- Width = 1815
- End
- Begin VB.Label Label5
- Alignment = 2 'Center
- Caption = "Contacts"
- BeginProperty Font
- Name = "Verdana"
- Size = 9.75
- Charset = 0
- Weight = 700
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- Height = 285
- Left = 5055
- TabIndex = 13
- Top = 90
- Width = 2760
- End
- Begin VB.Label Label1
- Alignment = 2 'Center
- Caption = "Companies"
- BeginProperty Font
- Name = "Verdana"
- Size = 9.75
- Charset = 0
- Weight = 700
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- Height = 285
- Left = 2055
- TabIndex = 12
- Top = 75
- Width = 2805
- End
- Begin VB.Label Label4
- Caption = "E-Mail"
- BeginProperty Font
- Name = "Verdana"
- Size = 9
- Charset = 0
- Weight = 400
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- Height = 255
- Left = 3990
- TabIndex = 11
- Top = 4905
- Width = 735
- End
- Begin VB.Label lblEMail
- BorderStyle = 1 'Fixed Single
- BeginProperty Font
- Name = "Verdana"
- Size = 9
- Charset = 0
- Weight = 400
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- Height = 315
- Left = 4860
- TabIndex = 10
- Top = 4875
- Width = 2970
- End
- Begin VB.Label Label6
- Alignment = 2 'Center
- Caption = "Selected Contact Information"
- BeginProperty Font
- Name = "Verdana"
- Size = 9.75
- Charset = 0
- Weight = 700
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- Height = 285
- Left = 4230
- TabIndex = 9
- Top = 3075
- Width = 3615
- End
- Begin VB.Label lblFAX
- BorderStyle = 1 'Fixed Single
- BeginProperty Font
- Name = "Verdana"
- Size = 9
- Charset = 0
- Weight = 400
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- Height = 315
- Left = 4860
- TabIndex = 8
- Top = 4410
- Width = 2970
- End
- Begin VB.Label lblPhone
- BorderStyle = 1 'Fixed Single
- BeginProperty Font
- Name = "Verdana"
- Size = 9
- Charset = 0
- Weight = 400
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- Height = 315
- Left = 4860
- TabIndex = 7
- Top = 3945
- Width = 2970
- End
- Begin VB.Label Label3
- Caption = "Phone Number"
- BeginProperty Font
- Name = "Verdana"
- Size = 9
- Charset = 0
- Weight = 400
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- Height = 255
- Left = 3975
- TabIndex = 6
- Top = 3975
- Width = 975
- End
- Begin VB.Label Label2
- Caption = "FAX"
- BeginProperty Font
- Name = "Verdana"
- Size = 9
- Charset = 0
- Weight = 400
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- Height = 255
- Left = 3975
- TabIndex = 5
- Top = 4440
- Width = 735
- End
- Begin VB.Label lblName
- BorderStyle = 1 'Fixed Single
- BeginProperty Font
- Name = "Verdana"
- Size = 9
- Charset = 0
- Weight = 400
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- Height = 315
- Left = 3960
- TabIndex = 4
- Top = 3495
- Width = 3870
- End
- Attribute VB_Name = "Contacts"
- Attribute VB_GlobalNameSpace = False
- Attribute VB_Creatable = False
- Attribute VB_PredeclaredId = True
- Attribute VB_Exposed = False
- ' ******************************
- ' ******************************
- ' ** MASTERING VB6 **
- ' ** by Evangelos Petroutos **
- ' ** SYBEX, 1998 **
- ' ******************************
- ' ******************************
- Dim OLApp As Application
- Dim mNameSpace As NameSpace
- Dim mContact As Object
- Dim allContacts As Object
- Private Sub Command1_Click()
- On Error GoTo OutlookNotStarted
- Set OLApp = CreateObject("Outlook.Application")
- On Error GoTo NoMAPINameSpace
- Set mNameSpace = OLApp.GetNamespace("MAPI")
- List1.Clear
- List2.Clear
- Command2.Enabled = True
- Exit Sub
- OutlookNotStarted:
- MsgBox "Could not start Outlook"
- Exit Sub
- NoMAPINameSpace:
- MsgBox "Could not get MAPI NameSpace"
- Exit Sub
- End Sub
- Private Sub Command2_Click()
- Set allContacts = mNameSpace.GetDefaultFolder(olFolderContacts).Items
- allContacts.Sort "CompanyName"
- On Error Resume Next
- For Each mContact In allContacts
- If Trim(mContact.CompanyName) <> "" Then List1.AddItem mContact.CompanyName
- If List1.List(List1.NewIndex) = List1.List(List1.NewIndex - 1) Then List1.RemoveItem List1.NewIndex
- Next
- End Sub
- Private Sub List1_Click()
- Dim CompanyName As String
- Dim filterString As String
- If List1.ListIndex = -1 Then Exit Sub
- CompanyName = List1.Text
- filterString = "[CompanyName] = """ & CompanyName & """"
-
- Set thiscontact = allContacts.Find(filterString)
- If IsNull(thiscontact) Then
- MsgBox "Fatal error in locating a contact. Program will exit"
- End
- End If
- List2.Clear
- While Not thiscontact Is Nothing
- If Trim(thiscontact.FullName) <> "" Then List2.AddItem thiscontact.FullName
- Set thiscontact = allContacts.FindNext
- Wend
- End Sub
- Private Sub List2_Click()
- Dim ContactName As String
- Dim filterString As String
- If List2.ListIndex = -1 Then Exit Sub
- ContactName = List2.Text
- filterString = "[FullName] = """ & ContactName & """"
- Set thiscontact = allContacts.Find(filterString)
- If IsNull(thiscontact) Then
- MsgBox "Fatal error in locating a contact's name. Program will exit"
- End
- End If
- lblName.Caption = " " & thiscontact.FullName
- lblPhone.Caption = " " & thiscontact.BusinessTelephoneNumber
- lblFAX.Caption = " " & thiscontact.BusinessFaxNumber
- lblEMail.Caption = " " & thiscontact.Email1Address
- End Sub
-