| {\rtf1\ansi\ansicpg1252\deff0\deflang1044{\fonttbl{\f0\fnil\fcharset0 MS Sans Serif;}} \viewkind4\uc1\pard\f0\fs17 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. \par \par This is set to a command button. \par \par Public Sub Command1_Click() \par Const ERR_TABLE_NOT_FOUND = 3078 \par Const ERR_FIELD_NOT_FOUND = 3265 \par Const ERR_ATTACHED_TABLE_NOT_FOUND = 3024 \par Const ERR_INVALID_ATTACHED_TABLE_PATH = 3044 \par On Error GoTo ERR_ExportContactsTable \par ' Open the table. \par Dim tblContacts As Recordset \par Dim strMessage As String \par Set ws = DBEngine.Workspaces(0) \par Set db = ws.OpenDatabase("C:\\Rathole\\TestData\\LittleBase\\SmallTest.mdb") \par Set tblContacts = db.OpenRecordset("ShortEmps") \par ' Open Outlook \par Dim oOutlook As OutLook.Application \par Set oOutlook = CreateObject("Outlook.Application") \par \par Dim olNS As OutLook.NameSpace \par Set olNS = oOutlook.GetNamespace("MAPI") \par olNS.Logon \par \par ' Get a reference to the Items collection of the contacts folder. \par Dim colItems As OutLook.ContactItem \par ' Load Contacts From DBF \par Do Until tblContacts.EOF \par Set colItems = oOutlook.CreateItem(olContactItem) \par With colItems \par .FullName = tblContacts("Contact") \par .Email1Address = Trim(LCase(tblContacts("EMAIL"))) \par .Email1AddressType = "SMTP" \par .Save \par .Display \par End With \par ' Load email addresses into Contacts Address Book \par Dim Menu As Object \par Dim Command As Object \par Set Menu = oOutlook.ActiveInspector.CommandBars("Tools") \par Set Command = Menu.Controls("Check Names") \par Command.Execute \par Set Menu = oOutlook.ActiveInspector.CommandBars("File") \par Set Command = Menu.Controls("Save") \par Command.Execute \par Set Command = Menu.Controls("Close") \par Command.Execute \par Set colItems = Nothing \par \par tblContacts.MoveNext \par Loop \par tblContacts.Close \par Set tblContacts = Nothing \par olNS.Logoff \par Set olNS = Nothing \par Set oOutlook = Nothing \par \par strMessage = "Your contacts have been successfully imported." \par MsgBox strMessage, vbOKOnly, MESSAGE_CAPTION \par \par Exit_ExportContactsTable: \par 'on error resume next \par \par \par Exit Sub \par ERR_ExportContactsTable: \par \par Select Case Err \par Case ERR_TABLE_NOT_FOUND \par strMessage = "Cannot find table!" \par MsgBox strMessage, vbCritical, MESSAGE_CAPTION \par Resume Exit_ExportContactsTable \par \par 'These errors occur if an attached table is moved or deleted \par 'or if the path to the table file is no longer valid. \par Case ERR_ATTACHED_TABLE_NOT_FOUND, ERR_INVALID_ATTACHED_TABLE_PATH \par strMessage = "Cannot find attached table!" \par MsgBox strMessage, vbCritical, MESSAGE_CAPTION \par Resume Exit_ExportContactsTable \par \par 'If a field in the code does not match a field in the table \par 'then move on to the next field. \par Case ERR_FIELD_NOT_FOUND \par Resume Next \par Case Else \par strMessage = "An unexpected error has occured. Error#" _ \par & Err & ": " & Error \par MsgBox strMessage, vbCritical, MESSAGE_CAPTION \par Resume Exit_ExportContactsTable \par End Select \par \par End Sub \par } |
Outlook Contact List Builder |
India web developer web development India | India web development company India ecommerce web developer