E
Ed Adamthwaite
Hi all,
Ive tried to generate a Distribution list in Outlook by automation from
Access using Redemption.
The list is generated and saved in the Outlook Contacts folder.
When I try to send an email using the list, I get the Outlook error message:
"The personal distribution list(s) this message is addressed to must
contain recipients. Add at least one recipient to each list."
In Outlook I can manually create a distribution list without members from
Contacts, but cannot using code. Even though the type "SMTP" is passed in
the AddMemberEx loop, it doesn't get into the DistList member's Internet
type property. When I manually try to update, the member is resolved to the
Contacts folder and the SMTP is set after clicking the Custom/Internet
button.
I'd appreciate some pointers as to where I'm going wrong.
The code:
Sub MakeAccessSIGDL()
On Error GoTo ErrorHandler
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim sDLname As String
Dim sSQL As String
Dim olApp As Object
Dim ns As Object
Dim myDL As Object
Dim rDL As Object
Dim sEntryID As String
Set olApp = CreateObject("Outlook.Application")
Set ns = olApp.GetNamespace("MAPI")
Set myDL = olApp.CreateItem(olDistributionListItem)
sDLname = "Access SIG List"
Set rDL = CreateObject("Redemption.SafeDistList")
myDL.Save
sEntryID = myDL.EntryID
'Debug.Print sEntryID
rDL.Item = myDL
Call DeleteDistributionList(sDLname)
sSQL = "SELECT Name, Address " _
& "FROM tblEmailAddresses " _
& "WHERE (((IsCurrent) = True)) " _
& "ORDER BY IIf(Len(GetString(1,[Name],' '))>1," _
& "GetString(2,[Name],' '),GetString(1,[Name],' '));"
'Debug.Print sSQL
Set conn = CurrentProject.Connection
Set rs = New ADODB.Recordset
With rs
.Open sSQL, conn, adOpenStatic, adLockOptimistic, adCmdText
.MoveLast 'force error 3021 if no records
.MoveFirst
Do Until .EOF
'CStr circumvents error- why?????
rDL.AddMemberEx CStr(.Fields("Name")), CStr(.Fields("Address")),
"SMTP"
.MoveNext
Loop
End With
rDL.DLName = sDLname
rDL.Save
Set rDL = Nothing
Set myDL = Nothing
Set myDL = ns.GetItemFromID(sEntryID)
myDL.SaveAs FILE_PATH_NAME & ".msg"
myDL.display
Set myDL = Nothing
Set rDL = Nothing
rs.Close
GoTo ThatsIt
ErrorHandler:
Select Case Err.Number
Case -2147217908
Case -2147217865 'cannot find table
Case 3021 'no records
Case Else
MsgBox "Problem with MakeAccessSIGDL()" & vbCrLf _
& "Error: & " & Err.Number & ": " & Err.Description
End Select
ThatsIt:
Set rs = Nothing
conn.Close
Set conn = Nothing
Set olApp = Nothing
Set ns = Nothing
End Sub
Regards,
Ed.
Ed Adamthwaite.
Ive tried to generate a Distribution list in Outlook by automation from
Access using Redemption.
The list is generated and saved in the Outlook Contacts folder.
When I try to send an email using the list, I get the Outlook error message:
"The personal distribution list(s) this message is addressed to must
contain recipients. Add at least one recipient to each list."
In Outlook I can manually create a distribution list without members from
Contacts, but cannot using code. Even though the type "SMTP" is passed in
the AddMemberEx loop, it doesn't get into the DistList member's Internet
type property. When I manually try to update, the member is resolved to the
Contacts folder and the SMTP is set after clicking the Custom/Internet
button.
I'd appreciate some pointers as to where I'm going wrong.
The code:
Sub MakeAccessSIGDL()
On Error GoTo ErrorHandler
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim sDLname As String
Dim sSQL As String
Dim olApp As Object
Dim ns As Object
Dim myDL As Object
Dim rDL As Object
Dim sEntryID As String
Set olApp = CreateObject("Outlook.Application")
Set ns = olApp.GetNamespace("MAPI")
Set myDL = olApp.CreateItem(olDistributionListItem)
sDLname = "Access SIG List"
Set rDL = CreateObject("Redemption.SafeDistList")
myDL.Save
sEntryID = myDL.EntryID
'Debug.Print sEntryID
rDL.Item = myDL
Call DeleteDistributionList(sDLname)
sSQL = "SELECT Name, Address " _
& "FROM tblEmailAddresses " _
& "WHERE (((IsCurrent) = True)) " _
& "ORDER BY IIf(Len(GetString(1,[Name],' '))>1," _
& "GetString(2,[Name],' '),GetString(1,[Name],' '));"
'Debug.Print sSQL
Set conn = CurrentProject.Connection
Set rs = New ADODB.Recordset
With rs
.Open sSQL, conn, adOpenStatic, adLockOptimistic, adCmdText
.MoveLast 'force error 3021 if no records
.MoveFirst
Do Until .EOF
'CStr circumvents error- why?????
rDL.AddMemberEx CStr(.Fields("Name")), CStr(.Fields("Address")),
"SMTP"
.MoveNext
Loop
End With
rDL.DLName = sDLname
rDL.Save
Set rDL = Nothing
Set myDL = Nothing
Set myDL = ns.GetItemFromID(sEntryID)
myDL.SaveAs FILE_PATH_NAME & ".msg"
myDL.display
Set myDL = Nothing
Set rDL = Nothing
rs.Close
GoTo ThatsIt
ErrorHandler:
Select Case Err.Number
Case -2147217908
Case -2147217865 'cannot find table
Case 3021 'no records
Case Else
MsgBox "Problem with MakeAccessSIGDL()" & vbCrLf _
& "Error: & " & Err.Number & ": " & Err.Description
End Select
ThatsIt:
Set rs = Nothing
conn.Close
Set conn = Nothing
Set olApp = Nothing
Set ns = Nothing
End Sub
Regards,
Ed.
Ed Adamthwaite.