Check/Create Contacts SubFolder in Outlook 1

[PBAPaul]

I have my 'standard' Contacts folder in Outlook 2002 and I wish to check if a subfolder "Special Contacts" has been created. If it hasn't then I wish to create it, if it has then I wish to download the data.

I am having problems in checking/creating the new subfolder. Please can anyone help?

I use the code below to get data from my 'standard' folder.

Sub GetOutlookDetails()
    Dim objContactsFolder As Outlook.MAPIFolder
    Dim objContacts As Outlook.Items
    Dim objContact As Object
    Dim iCount As Integer

    Set objContactsFolder = Session.GetDefaultFolder(olFolderContacts)
    Set objContacts = objContactsFolder.Items
    iCount = 0

     For Each objContact In objContacts
        If TypeName(objContact) = "ContactItem" Then
                .Cells(iCount + 2, 1) = objContact.Categories
                .Cells(iCount + 2, 2) = objContact.Title
                .Cells(iCount + 2, 3) = objContact.FirstName
                .Cells(iCount + 2, 4) = objContact.LastName

etc

 

[fumei]

Here is alternative. If Special Contacts exists, it displays the first name - but you can do whatever you need to at that point. If "Special Contacts" does not exists - itcreates it.

Sub FindSubContacts()

Dim olApp As outlook.Application
Dim objNameSpace As NameSpace
Dim objContacts As MAPIFolder
Dim mySubFolder As MAPIFolder
Dim objContactItem As ContactItem
Dim strFolderName As String

Dim i As Integer, ContactCount As Integer
Dim intEachContact As Integer

i = 1
    Set olApp = CreateObject("Outlook.Application")
    Set objNameSpace = olApp.GetNamespace("MAPI")
    Set objContacts = objNameSpace.GetDefaultFolder(olFolderContacts)
    On Error Resume Next
    For Each mySubFolder In objContacts.Folders
        strFolderName = objContacts.Folders.Item(i).Name
        If strFolderName = "Special Contacts" Then
            ContactCount = objContacts.Folders.Item(i).Items.Count
            intEachContact = 1
            For var = 1 To ContactCount
' do what ever you mean by "download"
' I just have it give me the name for testing
                Set objContactItem = objContacts.Folders.Item(i).Items(intEachContact)
                MsgBox objContactItem.FirstName
                intEachContact = intEachContact + 1
        ' have to reset object to be to get next item
                Set objContactItem = Nothing
            Next
            i = i + 1
        Else
            objContacts.Folders.Add "Special Contacts"
        End If
    Next
    Set objContacts = Nothing
    Set objNameSpace = Nothing
    Set olApp = Nothing
End Sub

Hope this helps.



Gerry

 

[PBAPaul]

Gerry

Thanks for the code. I got myself into a knot trying to add the subfolder and your code shows me exactly how to do it.

Have a star!

Paul