VB and VBA Users Source Code: Outlook Contact List Builder
[
Home
|
Contents
|
Search
|
Reply
| Previous | Next ]
VB/VBA Source Code
Outlook Contact List Builder
By:
Ken Williamson
Email (spam proof):
Email the originator of this post
Date:
Wednesday, December 12, 2001
Hits:
1078
Category:
Office
Article:
The following code will build an Outlook (97+) Contact List and Address Book from a database (Access DAO used in this case.) Problem with it is, when it runs each contact appears in a form for an instant, which is very annoying. This is set to a command button. Public Sub Command1_Click() Const ERR_TABLE_NOT_FOUND = 3078 Const ERR_FIELD_NOT_FOUND = 3265 Const ERR_ATTACHED_TABLE_NOT_FOUND = 3024 Const ERR_INVALID_ATTACHED_TABLE_PATH = 3044 On Error GoTo ERR_ExportContactsTable ' Open the table. Dim tblContacts As Recordset Dim strMessage As String Set ws = DBEngine.Workspaces(0) Set db = ws.OpenDatabase("C:\Rathole\TestData\LittleBase\SmallTest.mdb") Set tblContacts = db.OpenRecordset("ShortEmps") ' Open Outlook Dim oOutlook As OutLook.Application Set oOutlook = CreateObject("Outlook.Application") Dim olNS As OutLook.NameSpace Set olNS = oOutlook.GetNamespace("MAPI") olNS.Logon ' Get a reference to the Items collection of the contacts folder. Dim colItems As OutLook.ContactItem ' Load Contacts From DBF Do Until tblContacts.EOF Set colItems = oOutlook.CreateItem(olContactItem) With colItems .FullName = tblContacts("Contact") .Email1Address = Trim(LCase(tblContacts("EMAIL"))) .Email1AddressType = "SMTP" .Save .Display End With ' Load email addresses into Contacts Address Book Dim Menu As Object Dim Command As Object Set Menu = oOutlook.ActiveInspector.CommandBars("Tools") Set Command = Menu.Controls("Check Names") Command.Execute Set Menu = oOutlook.ActiveInspector.CommandBars("File") Set Command = Menu.Controls("Save") Command.Execute Set Command = Menu.Controls("Close") Command.Execute Set colItems = Nothing tblContacts.MoveNext Loop tblContacts.Close Set tblContacts = Nothing olNS.Logoff Set olNS = Nothing Set oOutlook = Nothing strMessage = "Your contacts have been successfully imported." MsgBox strMessage, vbOKOnly, MESSAGE_CAPTION Exit_ExportContactsTable: On Error Resume Next Exit Sub ERR_ExportContactsTable: Select Case Err Case ERR_TABLE_NOT_FOUND strMessage = "Cannot find table!" MsgBox strMessage, vbCritical, MESSAGE_CAPTION Resume Exit_ExportContactsTable 'These errors occur if an attached table is moved or deleted 'or if the path to the table file is no longer valid. Case ERR_ATTACHED_TABLE_NOT_FOUND, ERR_INVALID_ATTACHED_TABLE_PATH strMessage = "Cannot find attached table!" MsgBox strMessage, vbCritical, MESSAGE_CAPTION Resume Exit_ExportContactsTable 'If a field in the code does not match a field in the table 'then move on to the next field. Case ERR_FIELD_NOT_FOUND Resume Next Case Else strMessage = "An unexpected error has occured. Error#" _ & Err & ": " & Error MsgBox strMessage, vbCritical, MESSAGE_CAPTION Resume Exit_ExportContactsTable End Select End Sub
Terms and Conditions
Support this site
Download a trial version of the Excel Workbook Rebuilder
