Option Compare Database
Option Explicit
Dim aTo, aCC, aFrom, aPath, FileList, aTextBody, aSubject, strFilename, strMsg As String
Private Sub emailReportAsPDF_Click()
'Enter Password
Dim Message, Title, Default, WPass
Message = "Enter Windows Password"
Title = "InputBox"
WPass = InputBox(Message, Title, Default)
TempVars = ["WPass"]
DoCmd.OpenQuery "Clear EmailTbl"
DoCmd.OpenQuery "Update TechPubDual Mail List"
DoCmd.OpenQuery "Update EmailTBL - Current User"
Dim rs As Recordset
Dim vRecipientList As String
Dim vMsg As String
Dim vSubject As String
Dim vReportPDF As String
Set rs = CurrentDb.OpenRecordset("SELECT * FROM TechPubDual ")
If rs.RecordCount > 0 Then
rs.MoveFirst
Do
If Not IsNull(rs!email) Then
vRecipientList = vRecipientList & rs!email & "," 'Vlad - changed email separator to comma
rs.MoveNext
Else
rs.MoveNext
End If
Loop Until rs.EOF
vMsg = "Please find attached new document loaded"
vSubject = "New Document Loaded"
vReportPDF = CurrentProject.Path & "\" & "Email_SB_Notification_From_TechPubs_All_SB_TBL.pdf"
'<<<<<<<<<<<<<<<<<<<<export the report as PDF>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
DoCmd.OutputTo acReport, "Email SB Notification - From TechPubs - All - SB TBL", acFormatPDF, vReportPDF
'<<<<<<<<<<<<<<<<<<<<export the report as PDF>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'DoCmd.SendObject acSendReport, "Email SB Notification - From TechPubs - All - SB TBL", acFormatPDF, vRecipientList, , , vSubject, vMsg, False
'<<<<<<<<<<<<<<<<<<call Colin's sub to email report as attachment>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
SendEMailCDO vRecipientList, "", vSubject, vMsg, "", vReportPDF
'<<<<<<<<<<<<<<<<<<call Colin's sub to email report as attachment>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'MsgBox ("Report successfully eMailed!")
Else
MsgBox "No contacts."
End If
End Sub
Public Function GetUserName() As String
GetUserName = Environ("UserName")
End Function
Sub SendEMailCDO(aTo, aCC, aSubject, aTextBody, aFrom, aPath)
Dim rs As Recordset
Dim vRecipientListUser As String
Set rs = CurrentDb.OpenRecordset("SELECT * FROM TechPubDualCurrentUserMail ")
If rs.RecordCount > 0 Then
rs.MoveFirst
Do
If Not IsNull(rs!CurrentUserMail) Then
vRecipientListUser = vRecipientListUser & rs!CurrentUserMail & "," 'Vlad - changed email separator to comma
rs.MoveNext
Else
rs.MoveNext
End If
Loop Until rs.EOF
aCC = vRecipientListUser
aFrom = vRecipientListUser
'==========================================
'Original code by Jeff Blumson
'Adapted by Colin Riddington to include file attachments
'Date: 25/08/2007
'==========================================
Dim cboEmailType As String
Dim txtSendUsing As String
Dim txtPort As String
Dim txtServer As String
Dim txtAuthenticate As String
Dim intTimeOut As String
Dim txtSSL As String
Dim txtusername As String
Dim txtPassword As String
Dim WPass As String
cboEmailType = EmailType
txtSendUsing = SendUsing
txtPort = ServerPort
txtServer = EmailServer
txtAuthenticate = SMTPAuthenticate
txtusername = GetUserName
txtPassword = WPass
intTimeOut = Timeout
txtSSL = UseSSL
On Error GoTo err_SendEMailCDO
Const CdoBodyFormatText = 1
Const CdoBodyFormatHTML = 0
Const CdoMailFormatMime = 0
Const CdoMailFormatText = 1
Dim Message As Object
'Create CDO message object
Set Message = CreateObject("cdo.Message")
With Message.Configuration.Fields
.Item("
http://schemas.microsoft.com/cdo/configuration/sendusing") = txtSendUsing
.Item("
http://schemas.microsoft.com/cdo/configuration/smtpserverport") = txtPort
.Item("
http://schemas.microsoft.com/cdo/configuration/smtpserver") = txtServer
.Item("
http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = txtAuthenticate
.Item("
http://schemas.microsoft.com/cdo/configuration/sendusername") = txtusername
.Item("
http://schemas.microsoft.com/cdo/configuration/sendpassword") = txtPassword
.Item("
http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = intTimeOut
.Item("
http://schemas.microsoft.com/cdo/configuration/smtpusessl") = txtSSL
'code for STARTTLS
If txtPort = 587 Then
.Item("
http://schemas.microsoft.com/cdo/configuration/sendtls").Value = True
End If
.Update
End With
DoCmd.Hourglass True
With Message
.To = aTo 'Set email adress
.Subject = aSubject 'Set subject
.TextBody = aTextBody 'Set body text
If Len(aCC) > 0 Then .CC = aCC 'Set copy to
If Len(aFrom) > 0 Then .From = aFrom 'Set sender address if specified.
If Len(aPath) > 0 Then .AddAttachment (aPath) 'Attach this file
.Send 'Send the message
End With
'Debug lines
'Debug.Print txtSendUsing, txtPort, txtAuthenticate, intTimeout
'Debug.Print txtServer, txtUserName, txtPassword
'Debug.Print aTo, aCC, aFrom
'Debug.Print aSubject
'Debug.Print aTextBody
'Debug.Print aPath
DoCmd.Hourglass False
'Show message
MsgBox "The email message has been sent successfully. ", vbInformation, "EMail message"
'Clean up
Set Message = Nothing
Exit_SendEMailCDO:
Exit Sub
err_SendEMailCDO:
'MsgBox "Error # " & str(err.Number) & Chr(13) & err.Description
strMsg = "Sorry - I was unable to send the email message(s). " & vbNewLine & vbNewLine & _
"Error # " & Str(Err.Number) & Chr(13) & Err.Description
MsgBox strMsg, vbCritical, "EMail message"
strMsg = ""
Resume Exit_SendEMailCDO
End If
End Sub
