How to add contacts to a public folder

D

Dave

I am trying to use VBA to add contacts to a public folder.

I can read the contacts that are in the public folder but I cannot write (or
create) contacts in the public folder. When I try to create contacts they
are created only in my local contacts folder (the one under my "Mailbox").
Instead I need to create them in the public folder.

I am not that familiar with Outlook and Exchange so I have borrowed
liberally from two code references: Microsoft Outlook Programming (page 567)
and KB 290658.

Below is my code. There are 3 routines: first to get the proper folder,
second to read the public folder, and third to write to the public folder.

If anyone can give me some direction I would be grateful.

Dave

---------------------------------------------------------------------

1. Get the public folder

Public Function GetFolder(strFolderPath As String) As MAPIFolder

Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim colFolders As Outlook.Folders
Dim objFolder As Outlook.MAPIFolder
Dim arrFolders() As String
Dim i As Long

On Error Resume Next

strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")

Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objFolder = objNS.Folders.Item(arrFolders(0))
If Not objFolder Is Nothing Then
For i = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(i))
If objFolder Is Nothing Then
Exit For
End If
Next
End If

Set GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing
Set objApp = Nothing


End Function

---------------------------------------------------------------------
2. Read the contacts in the public folder

Sub addContacts2()

Dim i As Integer 'counter
Dim strFolderName As String 'Outlook folder
Dim strFolderPath As String 'Outlook folder path

'get folder name from drop down box selection
strFolderName = cboFolder.value
strFolderPath = "Public Folders\All Public Folders\" & strFolderName

'Outlook Objects
Dim ol As New Outlook.Application
Dim olns As Outlook.NameSpace
Dim cf As Outlook.MAPIFolder
Dim c As Outlook.ContactItem
Dim objItems As Outlook.Items
Dim Prop As Outlook.UserProperty


Set olns = ol.GetNamespace("MAPI")


'Call function to return proper folder object
Set cf = GetFolder(strFolderPath)
Set objItems = cf.Items
iNumContacts = objItems.Count

If iNumContacts <> 0 Then

'turn label and progress bar on
Me.lblProgress.Caption = iNumContacts & " potential records to
import."
Me.lblProgress.Visible = True

Me.pbIn.Visible = True
iPBOutWidth = Me.pbOut.Width

For i = 1 To iNumContacts

'set progress bar
'size of inner box= (size of outer box/# records) * current
record
Me.pbIn.Width = (iPBOutWidth / iNumContacts) * i
Me.Repaint

If TypeName(objItems(i)) = "ContactItem" Then
Set c = objItems(i)

debug.Print c.CompanyName

End If

Set c = Nothing

Next i

MsgBox "Finished."

Else
MsgBox "No contacts to export."
End If

Set olns = Nothing
Set cf = Nothing
Set objItems = Nothing

End Sub

---------------------------------------------------------------------
3. Write contacts to public folder

Sub addContacts3()

' Set up DAO Objects.
Dim oDataBase As DAO.Database
Dim rst As DAO.Recordset
Set oDataBase = OpenDatabase _
("\\xxxtech.com\data\users\xxx\My Documents\Work
Files\Access\NWind2003.mdb")
Set rst = oDataBase.OpenRecordset("contact")


Dim i As Integer 'counter
Dim strFolderName As String 'Outlook folder
Dim strFolderPath As String 'Outlook folder path


'get folder name from drop down box selection
strFolderName = cboFolder.value
strFolderPath = "Public Folders\All Public Folders\" & strFolderName


'Outlook Objects
Dim ol As New Outlook.Application
Dim olns As Outlook.NameSpace
Dim cf As Outlook.MAPIFolder
Dim c As Outlook.ContactItem
Dim objItems As Outlook.Items
Dim Prop As Outlook.UserProperty


Set olns = ol.GetNamespace("MAPI")

'Call function to return proper folder object
Set cf = GetFolder(strFolderPath)
iNumContacts = rst.RecordCount

MsgBox (iNumContacts)

If iNumContacts <> 0 Then

'turn label and progress bar on
Me.lblProgress.Caption = iNumContacts & " potential records to
import."
Me.lblProgress.Visible = True

Me.pbIn.Visible = True
iPBOutWidth = Me.pbOut.Width

rst.MoveFirst

For i = 1 To iNumContacts

'set progress bar
'size of inner box= (size of outer box/# records) * current
record
Me.pbIn.Width = (iPBOutWidth / iNumContacts) * i
Me.Repaint

Set c = ol.CreateItem(olContactItem)

If rst![CompanyName] <> "" Then c.CompanyName =
rst![CompanyName]
If rst![ContactName] <> "" Then c.FullName =
rst![ContactName]

'this writes the conact to outlook but to my contact folder rather than
the public folder
c.Save
c.Close (olSave)

rst.MoveNext

Set c = Nothing

Next i

MsgBox "Finished."

Else
MsgBox "No contacts to export."
End If

Set olns = Nothing
Set cf = Nothing
Set objItems = Nothing

End Sub

---------------------------------------------------------------------
 
S

Sue Mosher [MVP-Outlook]

To create an item in a non-default folder, use the Add method on the target
folder's Items collection. You can use the code at
http://www.outlookcode.com/d/code/getfolder.htm to walk the folder hierarchy
and return the MAPIFolder corresponding to a given path string.
--
Sue Mosher, Outlook MVP
Author of
Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers



Dave said:
I am trying to use VBA to add contacts to a public folder.

I can read the contacts that are in the public folder but I cannot write
(or
create) contacts in the public folder. When I try to create contacts they
are created only in my local contacts folder (the one under my "Mailbox").
Instead I need to create them in the public folder.

I am not that familiar with Outlook and Exchange so I have borrowed
liberally from two code references: Microsoft Outlook Programming (page
567)
and KB 290658.

Below is my code. There are 3 routines: first to get the proper folder,
second to read the public folder, and third to write to the public folder.

If anyone can give me some direction I would be grateful.

Dave

---------------------------------------------------------------------

1. Get the public folder

Public Function GetFolder(strFolderPath As String) As MAPIFolder

Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim colFolders As Outlook.Folders
Dim objFolder As Outlook.MAPIFolder
Dim arrFolders() As String
Dim i As Long

On Error Resume Next

strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")

Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objFolder = objNS.Folders.Item(arrFolders(0))
If Not objFolder Is Nothing Then
For i = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(i))
If objFolder Is Nothing Then
Exit For
End If
Next
End If

Set GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing
Set objApp = Nothing


End Function

---------------------------------------------------------------------
2. Read the contacts in the public folder

Sub addContacts2()

Dim i As Integer 'counter
Dim strFolderName As String 'Outlook folder
Dim strFolderPath As String 'Outlook folder path

'get folder name from drop down box selection
strFolderName = cboFolder.value
strFolderPath = "Public Folders\All Public Folders\" & strFolderName

'Outlook Objects
Dim ol As New Outlook.Application
Dim olns As Outlook.NameSpace
Dim cf As Outlook.MAPIFolder
Dim c As Outlook.ContactItem
Dim objItems As Outlook.Items
Dim Prop As Outlook.UserProperty


Set olns = ol.GetNamespace("MAPI")


'Call function to return proper folder object
Set cf = GetFolder(strFolderPath)
Set objItems = cf.Items
iNumContacts = objItems.Count

If iNumContacts <> 0 Then

'turn label and progress bar on
Me.lblProgress.Caption = iNumContacts & " potential records to
import."
Me.lblProgress.Visible = True

Me.pbIn.Visible = True
iPBOutWidth = Me.pbOut.Width

For i = 1 To iNumContacts

'set progress bar
'size of inner box= (size of outer box/# records) * current
record
Me.pbIn.Width = (iPBOutWidth / iNumContacts) * i
Me.Repaint

If TypeName(objItems(i)) = "ContactItem" Then
Set c = objItems(i)

debug.Print c.CompanyName

End If

Set c = Nothing

Next i

MsgBox "Finished."

Else
MsgBox "No contacts to export."
End If

Set olns = Nothing
Set cf = Nothing
Set objItems = Nothing

End Sub

---------------------------------------------------------------------
3. Write contacts to public folder

Sub addContacts3()

' Set up DAO Objects.
Dim oDataBase As DAO.Database
Dim rst As DAO.Recordset
Set oDataBase = OpenDatabase _
("\\xxxtech.com\data\users\xxx\My Documents\Work
Files\Access\NWind2003.mdb")
Set rst = oDataBase.OpenRecordset("contact")


Dim i As Integer 'counter
Dim strFolderName As String 'Outlook folder
Dim strFolderPath As String 'Outlook folder path


'get folder name from drop down box selection
strFolderName = cboFolder.value
strFolderPath = "Public Folders\All Public Folders\" & strFolderName


'Outlook Objects
Dim ol As New Outlook.Application
Dim olns As Outlook.NameSpace
Dim cf As Outlook.MAPIFolder
Dim c As Outlook.ContactItem
Dim objItems As Outlook.Items
Dim Prop As Outlook.UserProperty


Set olns = ol.GetNamespace("MAPI")

'Call function to return proper folder object
Set cf = GetFolder(strFolderPath)
iNumContacts = rst.RecordCount

MsgBox (iNumContacts)

If iNumContacts <> 0 Then

'turn label and progress bar on
Me.lblProgress.Caption = iNumContacts & " potential records to
import."
Me.lblProgress.Visible = True

Me.pbIn.Visible = True
iPBOutWidth = Me.pbOut.Width

rst.MoveFirst

For i = 1 To iNumContacts

'set progress bar
'size of inner box= (size of outer box/# records) * current
record
Me.pbIn.Width = (iPBOutWidth / iNumContacts) * i
Me.Repaint

Set c = ol.CreateItem(olContactItem)

If rst![CompanyName] <> "" Then c.CompanyName =
rst![CompanyName]
If rst![ContactName] <> "" Then c.FullName =
rst![ContactName]

'this writes the conact to outlook but to my contact folder rather than
the public folder
c.Save
c.Close (olSave)

rst.MoveNext

Set c = Nothing

Next i

MsgBox "Finished."

Else
MsgBox "No contacts to export."
End If

Set olns = Nothing
Set cf = Nothing
Set objItems = Nothing

End Sub
Click to expand...
 
D

Dave

Yes, that works quite nicely.

The reference in your book, by the way, is page 262.

Thank you.


Sue Mosher said:
To create an item in a non-default folder, use the Add method on the target
folder's Items collection. You can use the code at
http://www.outlookcode.com/d/code/getfolder.htm to walk the folder hierarchy
and return the MAPIFolder corresponding to a given path string.
--
Sue Mosher, Outlook MVP
Author of
Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers



Dave said:
I am trying to use VBA to add contacts to a public folder.

I can read the contacts that are in the public folder but I cannot write
(or
create) contacts in the public folder. When I try to create contacts they
are created only in my local contacts folder (the one under my "Mailbox").
Instead I need to create them in the public folder.

I am not that familiar with Outlook and Exchange so I have borrowed
liberally from two code references: Microsoft Outlook Programming (page
567)
and KB 290658.

Below is my code. There are 3 routines: first to get the proper folder,
second to read the public folder, and third to write to the public folder.

If anyone can give me some direction I would be grateful.

Dave

---------------------------------------------------------------------

1. Get the public folder

Public Function GetFolder(strFolderPath As String) As MAPIFolder

Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim colFolders As Outlook.Folders
Dim objFolder As Outlook.MAPIFolder
Dim arrFolders() As String
Dim i As Long

On Error Resume Next

strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")

Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objFolder = objNS.Folders.Item(arrFolders(0))
If Not objFolder Is Nothing Then
For i = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(i))
If objFolder Is Nothing Then
Exit For
End If
Next
End If

Set GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing
Set objApp = Nothing


End Function

---------------------------------------------------------------------
2. Read the contacts in the public folder

Sub addContacts2()

Dim i As Integer 'counter
Dim strFolderName As String 'Outlook folder
Dim strFolderPath As String 'Outlook folder path

'get folder name from drop down box selection
strFolderName = cboFolder.value
strFolderPath = "Public Folders\All Public Folders\" & strFolderName

'Outlook Objects
Dim ol As New Outlook.Application
Dim olns As Outlook.NameSpace
Dim cf As Outlook.MAPIFolder
Dim c As Outlook.ContactItem
Dim objItems As Outlook.Items
Dim Prop As Outlook.UserProperty


Set olns = ol.GetNamespace("MAPI")


'Call function to return proper folder object
Set cf = GetFolder(strFolderPath)
Set objItems = cf.Items
iNumContacts = objItems.Count

If iNumContacts <> 0 Then

'turn label and progress bar on
Me.lblProgress.Caption = iNumContacts & " potential records to
import."
Me.lblProgress.Visible = True

Me.pbIn.Visible = True
iPBOutWidth = Me.pbOut.Width

For i = 1 To iNumContacts

'set progress bar
'size of inner box= (size of outer box/# records) * current
record
Me.pbIn.Width = (iPBOutWidth / iNumContacts) * i
Me.Repaint

If TypeName(objItems(i)) = "ContactItem" Then
Set c = objItems(i)

debug.Print c.CompanyName

End If

Set c = Nothing

Next i

MsgBox "Finished."

Else
MsgBox "No contacts to export."
End If

Set olns = Nothing
Set cf = Nothing
Set objItems = Nothing

End Sub

---------------------------------------------------------------------
3. Write contacts to public folder

Sub addContacts3()

' Set up DAO Objects.
Dim oDataBase As DAO.Database
Dim rst As DAO.Recordset
Set oDataBase = OpenDatabase _
("\\xxxtech.com\data\users\xxx\My Documents\Work
Files\Access\NWind2003.mdb")
Set rst = oDataBase.OpenRecordset("contact")


Dim i As Integer 'counter
Dim strFolderName As String 'Outlook folder
Dim strFolderPath As String 'Outlook folder path


'get folder name from drop down box selection
strFolderName = cboFolder.value
strFolderPath = "Public Folders\All Public Folders\" & strFolderName


'Outlook Objects
Dim ol As New Outlook.Application
Dim olns As Outlook.NameSpace
Dim cf As Outlook.MAPIFolder
Dim c As Outlook.ContactItem
Dim objItems As Outlook.Items
Dim Prop As Outlook.UserProperty


Set olns = ol.GetNamespace("MAPI")

'Call function to return proper folder object
Set cf = GetFolder(strFolderPath)
iNumContacts = rst.RecordCount

MsgBox (iNumContacts)

If iNumContacts <> 0 Then

'turn label and progress bar on
Me.lblProgress.Caption = iNumContacts & " potential records to
import."
Me.lblProgress.Visible = True

Me.pbIn.Visible = True
iPBOutWidth = Me.pbOut.Width

rst.MoveFirst

For i = 1 To iNumContacts

'set progress bar
'size of inner box= (size of outer box/# records) * current
record
Me.pbIn.Width = (iPBOutWidth / iNumContacts) * i
Me.Repaint

Set c = ol.CreateItem(olContactItem)

If rst![CompanyName] <> "" Then c.CompanyName =
rst![CompanyName]
If rst![ContactName] <> "" Then c.FullName =
rst![ContactName]

'this writes the conact to outlook but to my contact folder rather than
the public folder
c.Save
c.Close (olSave)

rst.MoveNext

Set c = Nothing

Next i

MsgBox "Finished."

Else
MsgBox "No contacts to export."
End If

Set olns = Nothing
Set cf = Nothing
Set objItems = Nothing

End Sub
Click to expand...
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

copying a custom view from a public folder and distributing programatically 1
Senders email address in saved attachment 1
For Each loop not getting all Email Items 3
Operation Failed, object could be not be found - Can't find the fo 2
Type mismatch when moving mail item from sent items 1
Save Attachment Using Macro 3
Error Downloading Outlookfields using VBA 0
setting my code to access contacts from a a different folder. 3

Top