Create a subfolder in Outlook contacts called delintel

[Mathew]

I need some help! I have the VBA code going together ok.
I have this VBA code I’ve been working on for a couple
weeks. We use Excel 2003. We keep our contacts in Excel,
because these change daily. I've been tasked to create a Macro that
will send a new contact to a subfolder under Contacts in Outlook.
The folder will be called "Delintel"
I’ve re-read Automating Outlook with Excel at Dick
Clicks http://www.dicks-clicks.com/excel/olAutomating.htm
very good site. I've some others as well. I have not yet
found a way for saving the contact to a subfolder under
my Contacts in Outlook. How can I access or create this
subfolder? Below is some of the code.

For Each rCell In Range("A4:A580").Cells
Set olApp = CreateObject("Outlook.Application")
If Err.Number = 429 Then
Set olApp = CreateObject("Outlook.application")
End If

Set olCi = olApp.CreateItem(olContactItem)

OrganizationalIDNumber = rCell.Value ' Company long # i.e. AB001..
Department1 = rCell.Offset(0, 1).Value ' Company Short Name
……

With olCi
.AssistantName = AssistantName1 ' Assistants Name
.CompanyName = Company ' Company Name
……
.Save
End With
Set olCi = Nothing
Set olApp = Nothing
Next rCell

I changed the line Set Olci to:
Set olCi = olApp.CreateItem(olContactItem).Folders("delintel")
But I get error 438. So this is not the correct way to access the object.

Among the other attempts I also tried:
Set Fldr = olNs.GetDefaultFolder(olFolderContacts).Folders("delintel")

Any help would be greatly appreciated!

 

[Steve Yandl]

Matthew,

The sub below will create a new subfolder of Contacts named "Test"

___________________________________________
Sub NewOLfolder()

Const olFolderContacts = 10

Set objOL = CreateObject("Outlook.Application")
Set objNS = objOL.GetNamespace("MAPI")
Set objFldr = objNS.GetDefaultFolder(olFolderContacts)

Set objNewFldr = objFldr.Folders.Add("Test")

Set objNS = Nothing
Set objOL = Nothing
End Sub
__________________________________________

Now you can work with objNewFldr. However, if the subfolder "Test" already
existed, the subroutine below adds a couple of contacts. My test example is
a bit different from your scenario. In my case, I have full names in column
A and email addresses in column B on the active workbook sheet but you
should be able to modify for your needs.

_________________________________________
Sub AddToMyFolder()

Const olFolderContacts = 10

Dim R As Integer

Set objOL = CreateObject("Outlook.Application")
Set objNS = objOL.GetNamespace("MAPI")
Set objFldr = objNS.GetDefaultFolder(olFolderContacts)

Set objMyFolder = objFldr.Folders("Test")

R = Range("A65536").End(xlUp).Row

For x = 1 To R
Set ctct = objMyFolder.Items.Add
With ctct
.FullName = Cells(x, 1).Value
.Email1Address = Cells(x, 2).Value
.Save
End With
Next x

Set objNS = Nothing
Set objOL = Nothing
End Sub
________________________________________

Steve Yandl