Visual Basic > Internet Web Mail Stuff

Outlook Contact List Builder

Outlook Contact List Builder

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