Import Outlook Contacts (Resolved)

[demotivater]

Does anyone have any tips/links/samples for importing Outlook 2002 Contacts into an Access 2002 database?

Thanks in advance

[RobDog888]

In Outlook, with the Contacts being displayed...
Click File > Import and Export... > Then the wizard pops up.
Export to a File > Microsoft Access > Select Contacts folder.
Then browse to your access database. Then click Finish.

[demotivater]

Should have been more clear, I'm attempting to do this through vb6 code. Thanks for the input though.

[shubha_de]

Hi Michelle !

You can use the Outlook Object Library to Access the contacts.

You can look at the example given in the link
http://support.microsoft.com/?kbid=260999


Hope it Helps
Shubha

[demotivater]

No sure who Michelle is??
But thanks for the link, I never have any luck searching M$ site.

[RobDog888]

Linked Contacts are for internal use by Outlook and not for Access.
Try this...Connect to Outlook Contacts using ADO and import into Access.

Public Function Outlook_Contacts_2_Access()
'   <GORS = ACCESS>
'   <ORS = OUTLOOK>
    On Error GoTo No_Bugs
    
    Dim Cnn As ADODB.Connection
    Dim CnnA As ADODB.Connection
    Dim oRs As ADODB.Recordset
    Dim goRs As ADODB.Recordset
 
    Dim sSQL As String
    
    Set Cnn = New ADODB.Connection
    Set CnnA = New ADODB.Connection
    Set oRs = New ADODB.Recordset
    Set goRs = New ADODB.Recordset
 
    Cnn.ConnectionString = "Provider=Microsoft.JET.OLEDB.4.0;Exchange 4.0;" & _
    "MAPILEVEL=Outlook Address Book\;TABLETYPE=1;" & _
    "DATABASE={B1C82C96-7149-4EDD-A709-8D7E66518332}" 'PROFILE=Outlook;
    Cnn.Open
    
    sSQL = "SELECT * from [Contacts]"
    
    oRs.Open sSQL, Cnn, adOpenStatic, adLockReadOnly, adCmdText
 
    CnnA.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\OtoA.mdb;Persist Security Info=False"
    CnnA.Open
    goRs.Open "SELECT * FROM Contacts WHERE 1=2;", CnnA, adOpenStatic, adLockReadOnly, adCmdText
    
    frmMain.prbProgress.Max = oRs.RecordCount
    oRs.MoveFirst
    i = 0
    Do While oRs.EOF = False
        DoEvents
        goRs.AddNew
        goRs!First = oRs!First
        goRs!Last = oRs!Last
        goRs!Title = oRs!Title
        goRs!Company = oRs!Company
        goRs!Department = oRs!Department
        goRs!Office = oRs!Office
        goRs.Fields("Post Office Box") = oRs.Fields("Post Office Box")
        goRs!Address = oRs!Address
        goRs!City = oRs!City
        goRs!State = oRs!State
        goRs.Fields("Zip Code") = oRs.Fields("Zip Code")
        goRs!Country = oRs!Country
        goRs!Phone = oRs!Phone
        goRs.Fields("Mobile Phone") = oRs.Fields("Mobile Phone")
        goRs.Fields("Pager Phone") = oRs.Fields("Pager Phone")
        goRs.Fields("Home2 Phone") = oRs.Fields("Home2 Phone")
        goRs.Fields("Assistant Phone Number") = oRs.Fields("Assistant Phone Number")
        goRs.Fields("Fax Number") = oRs.Fields("Fax Number")
        goRs.Fields("Telex Number") = oRs.Fields("Telex Number")
        goRs.Fields("Display Name") = oRs.Fields("Display Name")
        goRs.Fields("E-mail Type") = oRs.Fields("E-mail Type")
        goRs.Fields("E-mail Address") = oRs.Fields("E-mail Address")
        goRs!Alias = oRs!Alias
        goRs!Assistant = oRs!Assistant
        goRs.Fields("Send Rich Text") = oRs.Fields("Send Rich Text")
        goRs!Primary = oRs!Primary
        goRs.Update
        oRs.MoveNext
        i = i + 1
        frmMain.prbProgress.Value = i
    Loop
    oRs.Close
    goRs.Close
    Set Cnn = Nothing
    Set CnnA = Nothing
    Set oRs = Nothing
    Set goRs = Nothing
    Exit Function
 
No_Bugs:
    
    If Err.Number = "-2147467259" Then
        MsgBox "User Canceled Operation!", vbInformation + vbOKOnly, "Outlook Contacts Connect"
        Set Cnn = Nothing
        Set CnnA = Nothing
        Set oRs = Nothing
        Set goRs = Nothing
        Exit Function
    ElseIf Err.Number = "-2147217865" Then
        MsgBox "Invalid Profile Entered!", vbInformation + vbOKOnly, "Outlook Contacts Connect"
        Set Cnn = Nothing
        Set CnnA = Nothing        
        Set oRs = Nothing
        Set goRs = Nothing
        Exit Function
    Else
        MsgBox Err.Number & "-" & Err.Description, vbCritical, "Outlook Contacts Connect"
        Resume Next
    End If
 
End Function

[RobDog888]

Oh ya, just create the Contacts table in Access with the fileds you
want to import. Then in the code remove the fields so the code
matches your table's fields. Set the proper field types too.

[demotivater]

Sweet
Thanks man, that's exactly what I needed.

[RobDog888]

Your welcome. The only thing is that it is slow if you have alot of contacts in Outlook.
No way around that though.

Later.