VBA: Getting Contact folder to appear in Address Book??
(Outlook2000)
I can easily find the manual setting to make a Contacts folder appear in the
Address Book (properties/outlook address book/show this folder as an e-mail
Address Book).
Problem is I want to do this in code and cannot for the life of me find out
how. I'm creating a Contacts folder from Access and creating Contact entries
from Access data. It all works fine (incl. creating a Shortcut on the
Outlook Bar) but it won't appear in the Address Book until you change
the setting manually.
a) How do I set the Contacts folder to appear in the Address Book by code?
b) Do I have to manually create an Address List as well and link it to the
Contact? (I assume Outlook does this and links the Address Book entry to the
Contact somehow??)
My code is below out of interest..
Thanks... (please cc: to my email as well)
--
regards,
Bradley
hrsystems.com.au
------------------------------------------------
Function CreateOutlookContacts()
On Error GoTo CreateOutlookContacts_err
'prompt user
Dim r As Long, myMsg As String
r = MsgBox("BIGCare will create a 'BIGCare Contacts' folder in Microsoft
Outlook. Continue?", vbQuestion + vbOKCancel + vbDefaultButton1, "Outlook
Contacts")
If r <> vbOK Then Exit Function
Dim rsPerson As DAO.Recordset
Dim CountTotal As Long, CountRec As Long, OutputForm As String, i As Long
Dim myOlApp As Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myFolder As Outlook.MAPIFolder
Dim myContactFolder As Outlook.MAPIFolder
Dim myItem As Outlook.ContactItem
Dim myOlBar As Outlook.OutlookBarPane
Dim myOlGroup As Outlook.OutlookBarGroup
Dim myOlBarShortcut As Outlook.OutlookBarShortcut
Dim myExplorer As Outlook.Explorer
Set rsPerson = CurrentDb.OpenRecordset("qryOutlookExport",
DB_OPEN_SNAPSHOT)
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderContacts)
'Check some people records exist
If rsPerson.RecordCount = 0 Then Exit Function
rsPerson.MoveLast
CountTotal = rsPerson.RecordCount
CountRec = 0
OutputForm = "frmOutlookProgress"
DoCmd.OpenForm OutputForm
GV_CANCEL = False
'Initial progress message
Forms(OutputForm)![lblStatus].Caption = "Deleting BIGCare Contacts
folder..."
Forms(OutputForm).Repaint
'Contact Folder
'Delete contacts folder
For i = 1 To myFolder.Folders.Count
If myFolder.Folders.Item(i).Name = "BIGCare Contacts" Then
myFolder.Folders.Remove (i)
Exit For
End If
Next
'Create folder
Set myContactFolder = myFolder.Folders.Add("BIGCare Contacts",
olFolderContacts)
'Shortcut
Set myExplorer = myOlApp.ActiveExplorer
If TypeName(myExplorer) = "Nothing" Then 'test if Outlook open already
Set myExplorer = myFolder.GetExplorer
End If
Set myOlBar = myExplorer.Panes.Item("OutlookBar")
Set myOlGroup = myOlBar.Contents.Groups.Item(1)
'check if shortcut already exists and delete
For i = 1 To myOlGroup.Shortcuts.Count
If myOlGroup.Shortcuts.Item(i).Name = "BIGCare Contacts" Then
myOlGroup.Shortcuts.Remove (i)
Exit For
End If
Next
'Create shortcut
Set myOlBarShortcut = myOlGroup.Shortcuts.Add(myContactFolder, "BIGCare
Contacts")
On Error GoTo CreateOutlookContacts_err
'Create contacts from people records
rsPerson.MoveFirst
Do Until rsPerson.EOF Or GV_CANCEL
If apiGetAsyncKeyState(VK_ESCAPE) Then GV_CANCEL = True 'give user
option to cancel
Set myItem = myContactFolder.Items.Add(olContactItem)
If Len(rsPerson![GivenName]) > 0 Then myItem.FirstName =
rsPerson![GivenName]
If Len(rsPerson![Surname]) > 0 Then myItem.LastName = rsPerson![Surname]
If Len(rsPerson![Email]) > 0 Then myItem.Email1Address =
rsPerson![Email]
If Len(rsPerson![HomePhone]) > 0 Then myItem.HomeTelephoneNumber =
rsPerson![HomePhone]
If Len(rsPerson![WorkPhone]) > 0 Then myItem.BusinessTelephoneNumber =
rsPerson![WorkPhone]
If Len(rsPerson![MobilePhone]) > 0 Then myItem.MobileTelephoneNumber =
rsPerson![MobilePhone]
If Len(rsPerson![HomeFax]) > 0 Then myItem.HomeFaxNumber =
rsPerson![HomeFax]
If Len(rsPerson![WorkFax]) > 0 Then myItem.BusinessFaxNumber =
rsPerson![WorkFax]
If Len(rsPerson![Address1]) > 0 Then myItem.HomeAddressStreet =
rsPerson![Address1]
If Len(rsPerson![Address2]) > 0 Then myItem.HomeAddressStreet =
rsPerson![Address2]
If Len(rsPerson![Suburb]) > 0 Then myItem.HomeAddressCity =
rsPerson![Suburb]
If Len(rsPerson![Country]) > 0 Then myItem.HomeAddressCountry =
rsPerson![Country]
If Len(rsPerson![PostCode]) > 0 Then myItem.HomeAddressPostalCode =
rsPerson![PostCode]
If Len(rsPerson![PostalAddress1]) > 0 Then myItem.MailingAddressStreet =
rsPerson![PostalAddress1]
If Len(rsPerson![PostalAddress2]) > 0 Then myItem.MailingAddressStreet =
rsPerson![PostalAddress2]
If Len(rsPerson![PostalSuburb]) > 0 Then myItem.MailingAddressCity =
rsPerson![PostalSuburb]
If Len(rsPerson![PostalCountry]) > 0 Then myItem.MailingAddressCountry =
rsPerson![PostalCountry]
If Len(rsPerson![PostalPostCode]) > 0 Then
myItem.MailingAddressPostalCode = rsPerson![PostalPostCode]
myItem.Save
'Update progress indicator
CountRec = CountRec + 1
Forms(OutputForm)![lblStatus].Caption = CountRec & " of " & CountTotal
Forms(OutputForm)![bxProgress].Width = (8 / CountTotal) * CountRec * 567
Forms(OutputForm).Repaint
rsPerson.MoveNext
Loop
CreateOutlookContacts_exit:
If GV_CANCEL Then
Forms(OutputForm)!lblEscape.Caption = "Cancelled"
Else
Forms(OutputForm)!lblEscape.Caption = "Done"
End If
Forms(OutputForm)![btnOK].Visible = True
myMsg = "To make the Contact Folder appear in your Address Book please do
the following: " & Chr(10)
myMsg = myMsg & Chr(10) & "- Right-click on the 'BIGCare Contacts'
shortcut in Outlook"
myMsg = myMsg & Chr(10) & "- Select 'Properties' from the menu"
myMsg = myMsg & Chr(10) & "- Under the 'Outlook Address Book' tab tick the
box"
myMsg = myMsg & Chr(10) & " labelled 'Show this folder as an e-mail
Address Book'"
myMsg = myMsg & Chr(10) & "- Click 'OK'"
MsgBox myMsg, vbInformation + vbOKOnly, "Outlook Contacts"
'Clean up
Set myExplorer = Nothing
Set myOlBarShortcut = Nothing
Set myOlGroup = Nothing
Set myOlBar = Nothing
Set myItem = Nothing
Set myContactFolder = Nothing
Set myFolder = Nothing
Set myNameSpace = Nothing
Set myOlApp = Nothing
Set rsPerson = Nothing
Exit Function
CreateOutlookContacts_err:
MsgBox Err.Description, 48, "Error in CreateOutlookContacts()"
Resume CreateOutlookContacts_exit
End Function
