Penn White
ecritt1 at alltel.net
Wed Mar 15 05:55:40 CST 2006
Just to be complete for the archives, I thought I'd post my solution to this
problem. Thanks very much to all who offered advice and got me thinking and
exploring several new ways of doing things, especially using Custom
Collection Classes which I didn't actually need here but will definitely use
in future develpment tasks.
Some references I found useful were the following:
1. Using Custom Collection Classes in Access
http://www.databaseadvisors.com/newsletters/newsletter200503/0503usingcustomcollections/using%20custom%20collections%20in%20microsoft%20access.htm
2. How to Programmatically Export Items to Microsoft Access
http://support.microsoft.com/?kbid=253794
3. Ten Tips for Microsoft Outlook Developers
http://msdn.microsoft.com/library/default.asp?url=/library/en-us/dnout2k2/html/odc_novoltips.asp
*************** CODE ***************
Function Fn_CreateRecipList(ctlList As Control) As String
' 1. Creates Recipient string for 'SendObject' email.
' 2. Verifies that there is a Contact in Outlook for each Recipient.
' 3. If Contact in Outlook, verifies Email Address is current.
' Note: I have my own Error Handling routine so just substitute it with
your own.
Dim varItem As Variant
Dim strRecip1 As String
Dim strFirst1 As String
Dim strLast1 As String
Dim strEmail1 As String
Dim strRecip As String
' Set up Outlook objects.
Dim ol As New Outlook.Application
Dim olCi As Outlook.ContactItem
Dim cf As Outlook.MAPIFolder
Dim olns As Outlook.NameSpace
Dim olItems As Outlook.Items
On Error GoTo Err_Fn_CreateRecipList ' Revised Error Handler
Set ol = CreateObject("Outlook.Application")
Set olns = ol.GetNamespace("MAPI")
Set cf = olns.GetDefaultFolder(olFolderContacts)
Set olItems = cf.Items
For Each varItem In ctlList.ItemsSelected
strFirst1 = ctlList.Column(3, varItem)
strLast1 = ctlList.Column(2, varItem)
If strFirst1 = "" And strLast1 = "" Then
strRecip1 = ctlList.Column(1, varItem)
strLast1 = strRecip1
Else
strRecip1 = strFirst1 & " " & strLast1
End If
strEmail1 = Fn_CreateOLEmail(ctlList.Column(4, varItem))
Set olCi = cf.Items.Find("[FullName] = '" & strRecip1 & "'")
If TypeName(olCi) = "Nothing" Then
' Add Contact
Set olCi = ol.CreateItem(olContactItem)
olCi.FirstName = strFirst1
olCi.LastName = strLast1
olCi.Email1Address = strEmail1
olCi.Save
Else
' Verify Email Address
If olCi.Email1Address <> strEmail1 Then
olCi.Email1Address = strEmail1
olCi.Save
End If
End If
If Fn_IsNothing(strRecip) Then
strRecip = strRecip1
Else
strRecip = strRecip & "; " & strRecip1
End If
Next varItem
Fn_CreateRecipList = strRecip
Exit_Fn_CreateRecipList:
Set olCi = Nothing
Set olItems = Nothing
Set cf = Nothing
Set olns = Nothing
Set ol = Nothing
Exit Function
Err_Fn_CreateRecipList:
Select Case Err.Number
Case 0
Resume Next
Case Else
If Fn_ShowGenericErrorMsg("M_MiscFunctions", "Fn_CreateRecipList",
Err.Number, Err.Description) = True Then
Stop
Resume
Else
Resume Exit_Fn_CreateRecipList
End If
End Select
End Function