Definately a problem for me bc theoretically I have no clue as to what
a given user of the app is doing SMTP-wise.
Or do I?
Anybody been here?
For the masochistically-inclined, here's a snip of my code.
GoogleGroups is probably gonna have it's way with it
wrapping-wise, so I'd email it to anybody who wants
a .txt file version.
------------------------------------------------------
Public Sub Email_Report(ByVal theObjectName As String,
theReportDescription As String, ByVal theEmailReportSelectionBasis As
Long)
1000 DebugStackPush mModuleName & ": Email_Report"
1001 On Error GoTo Email_Report_err
' PURPOSE: To send a copy of the named report to each person on the
' list in ttblEmailAddresses
' ACCEPTS: - Object name of the report. e.g. "rptMaturities"
' - Description of the report
' - Whether we want addresses selected for report or trade
buy ticket
'
' NOTES: 1) We discontinued using MS Access' .SendObject command
because it was provoking
' a security confirmation in Outlook. Supposedly the
CDO.Message object
' goes direct to SMTP, bypassing Outlook.
1002 Dim myRS As DAO.Recordset
Dim myCdoMessage As CDO.Message
Dim myCdoConfig As CDO.Configuration
Dim curAddress As String
Dim myQueryName As String
Dim myTempDir As String
Dim mySnpPath As String
Const mySchema As String = "
http://schemas.microsoft.com/cdo/
configuration/"
'
------------------------------------------------------------------
' Get path to user's "Documents and Settings", then create a Temp
' directory under it
1010 myTempDir = Environ("UserProfile")
1019 myTempDir = myTempDir & "\Temp"
On Error Resume Next
MkDir myTempDir
On Error GoTo Email_Report_err
'
------------------------------------------------------------------
' Create a snapshot of our report in the temp dir, after having
' deleted any pre-existing file
1020 mySnpPath = myTempDir & "\" & theObjectName & ".snp"
On Error Resume Next
Kill mySnpPath
On Error GoTo Email_Report_err
1030 DoCmd.OutputTo acOutputReport, theObjectName, "Snapshot Format",
mySnpPath
'
------------------------------------------------------------------
' Set up CDO as needed
1040 Set myCdoConfig = New CDO.Configuration
1041 With myCdoConfig.Fields
1042 .Item(mySchema & "sendusing") = 2 ' cdoSendUsingPort
1043 .Item(mySchema & "smtpserver") = "localhost"
1044 .Update
1049 End With
'
------------------------------------------------------------------
' Create a CDO Message object, whose "TO:" we will customize for
each
1090 Set myCdoMessage = New CDO.Message
1091 With myCdoMessage
1092 .From = CurrentUserGet()
1093 .Subject = theReportDescription
1094 .textbody = theReportDescription & " report attached as .SNP
file."
1095 .AddAttachment mySnpPath
1099 End With
'
------------------------------------------------------------------
' Determine our input query and open our recordset of email
addresses
1110 Select Case theEmailReportSelectionBasis
Case gEmailReportSelectionBasis_Report
1112 myQueryName = "qryEmailAddresses_Selected_Report"
1113 Case gEmailReportSelectionBasis_Trade_Buy
1114 myQueryName = "qryEmailAddresses_Selected_Trade_Buy"
1115 Case Else
1116 BugAlert True, "Unexpected EmailReportSelectionBasis=" &
theEmailReportSelectionBasis & "'."
1119 End Select
1120 Set myRS = CurrentDb.OpenRecordset(myQueryName, dbOpenSnapshot,
dbForwardOnly)
'
------------------------------------------------------------------
' Loop through the email addresses, sending a copy of the message
to each
1130 With myRS
1131 If ((.BOF = True) And (.EOF = True)) Then
1132 MsgBox "Please select at least one eMail address and try
again.", vbExclamation, "Cannot eMail: No Addresses Selected"
1133 Else
1134 Do Until .EOF = True
1139 curAddress = !EmailAddress & ""
1140 If Len(curAddress) > 0 Then
1150 With myCdoMessage
1151 .To = curAddress
1152 .Send
1159 End With
'1159 DoCmd.SendObject acSendReport, theObjectName,
"Snapshot Format", curAddress, , , theReportDescription,
theReportDescription & " report attached as .SNP file...", False
1990 End If
'cdo.cdoSMTPServer =
1991 .MoveNext
1992 Loop
1993 End If
1999 End With
Email_Report_xit:
DebugStackPop
On Error Resume Next
Set myCdoMessage = Nothing
Set myCdoConfig = Nothing
myRS.Close
Set myRS = Nothing
Exit Sub
Email_Report_err:
BugAlert True, "curAddress='" & curAddress & "'."
Resume Email_Report_xit
End Sub
------------------------------------------------------
