Find and Modify an Outllook Contact

[peterhw]

I am trying to build a module to add notes etc to an outlook contact.
I have tried a number of things and the code below works.
Lines commented out generated errors.
Why does

Dim olApp As Outlook.Application

fail when so many examples use it?

How can I specify different folder for the contacts?

Sub GetContact()
Dim int1 as integer
Dim str1 As String, str2 As String
    'Dim olApp As Outlook.Application
    'Dim olNs As Namespace
    'Dim Fldr As MAPIFolder
    'Dim olCi As ContactItem
Dim olApp As Object
'On Error GoTo Error_Handler  '''''' need to add code for this top work
    Const olContactItem = 2
    Const olFolderContacts = 10
    Set olApp = CreateObject("Outlook.Application")
    Set olContact = olApp.CreateItem(olContactItem)
    'Set olApp = New Outlook.Application
    Set olNs = olApp.GetNamespace("MAPI")
    Set Fldr = olNs.Folders("Personal Folders").Folders("Contacts")
    int1 = 1
    For Each olCi In Fldr.Items
        str1 = olCi.CompanyName
        Sheets(ActiveSheet.Name).Cells(int1, 1) = str1
        str2 = olCi.FullName
        Sheets(ActiveSheet.Name).Cells(int1, 2) = str2
        int1 = int1 + 1
    Next olCi


    Set olCi = Nothing
    Set Fldr = Nothing
    Set olNs = Nothing
    Set olApp = Nothing


End Sub

any help appreciated

 

[s.ridd]

The line mentioned and the rest of your variables are generating errors because you need to set a reference to the Outlook Object Library. To do this click on Tools>References in the Visual Basic Editor, then choose the reference called "Microsoft Outlook x.0 Object Library" where x will represent the latest version of Outlook that you have installed. The rest of your code looks like you've mashed together 2 or more procedures that do two different things and use two different approaches. Below I've taken out one set of code for you to try and run

Sub GetContact()Dim int1 As Integer
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim Fldr As Outlook.MAPIFolder
Dim olCi As Outlook.ContactItem
    
    Set olApp = New Outlook.Application
    Set olNs = olApp.GetNamespace("MAPI")
    Set Fldr = olNs.Folders("Personal Folders").Folders("Contacts")
    
    int1 = 1
    For Each olCi In Fldr.Items
        Cells(int1, 1) = olCi.CompanyName
        Cells(int1, 2) = olCi.FullName
        int1 = int1 + 1
    Next olCi
    
    Set olCi = Nothing
    Set Fldr = Nothing
    Set olNs = Nothing
    Set olApp = Nothing
End Sub

Hope this helps

Simon

 

[peterhw]

The line ......... "Microsoft Outlook x.0 Object Library" where x will represent the latest version of Outlook that you have installed.

Never looked at this before but seems to solve that problem x = 12.0.
The code works fine until I get to a GROUP ITEM rather than a CONTACT ITEM.
So include the extra lines below - commented out - for the moment. If the ' - comment is removed the code fails line 1 - error 13 type mismatch.
I believe I have managed to get the code working elsewhere using the TypeName (as below)

Sub GetContact()Dim int1 As Integer
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim Fldr As Outlook.MAPIFolder
Dim olCi As Outlook.ContactItem
    
    Set olApp = New Outlook.Application
    Set olNs = olApp.GetNamespace("MAPI")
    Set Fldr = olNs.Folders("Personal Folders").Folders("Contacts")
    Set Fldr = Fldr.Folders("IMS")                       '  this works too
    int1 = 1
    For Each olCi In Fldr.Items
        'If TypeName(olCi) = "Contactitem" Then        '   <<<<<<<<<<<<<<<<<<
            Cells(int1, 1) = olCi.CompanyName
            Cells(int1, 2) = olCi.FullName
            int1 = int1 + 1
        'End If                                          '   <<<<<<<<<<<<<<<<<<
    Next olCi
    Set olCi = Nothing
    Set Fldr = Nothing
    Set olNs = Nothing
    Set olApp = Nothing
End Sub

Thanks again