Option Explicit
Dim aTo, aCC, aFrom, aPath, FileList, aTextBody, aSubject, strFilename, strMsg As String
Private Sub Excecute_Click()
Dim SQL As String
Dim WPassStr As String
Dim sSQL As String
'Enter Password
If Nz(DLookup("[WPass]", "[EmailTbl]")) = "" Then
Dim Message, Title, Default
Message = "Enter Windows Password"
Title = "Enter Parameters"
WPassStr = InputBox(Message, Title)
DoCmd.SetWarnings False
DoCmd.RunSQL "UPDATE EmailTbl SET WPass =""" & WPassStr & """"
DoCmd.SetWarnings True
End If
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 EmailTBL ")
If rs.RecordCount > 0 Then
rs.MoveFirst
Do
If Not IsNull(rs!email) Then
vRecipientList = vRecipientList & rs!To & "," 'Vlad - changed email separator to comma
rs.MoveNext
Else
rs.MoveNext
End If
Loop Until rs.EOF
vMsg = [Message]
vSubject = "New DAW Sheet Listing - Registration: " & " " & [Registration]
vReportPDF = CurrentProject.Path & "\" & "DAW Sheet"
'<<<<<<<<<<<<<<<<<<<<export the report as PDF>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
DoCmd.OutputTo acReport, "DAW Sheet", acFormatPDF, vReportPDF
'<<<<<<<<<<<<<<<<<<<<export the report as PDF>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'<<<<<<<<<<<<<<<<<<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
'DoCmd.RunMacro "New DAW Email List"
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 vToUser As String
Dim vProductionPlannerMail As String
Set rs = CurrentDb.OpenRecordset("SELECT * FROM EmailTBL ")
If rs.RecordCount > 0 Then
rs.MoveFirst
Do
If Not IsNull(rs!To) Then
vToUser = vToUser & rs!To & "," 'Vlad - changed email separator to comma
rs.MoveNext
Else
rs.MoveNext
End If
Loop Until rs.EOF
aCC = vProductionPlannerMail
aFrom = vToUser
'==========================================
'Original code by Jeff Blumson
'Adapted by Colin Riddington to include file attachments
'Date: 25/08/2007
'==========================================
'Dim CDOEmailType 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 VWPass As String
Set rs = CurrentDb.OpenRecordset("SELECT * FROM EmailTBL ")
VWPass = VWPass & rs!WPass
Set rs = CurrentDb.OpenRecordset("SELECT * FROM GMailSettingsQry ")
'CDOEmailType = rs!EmailType
txtSendUsing = rs!SendUsing
txtPort = rs!ServerPort
txtServer = rs!EmailServer
txtAuthenticate = rs!SMTPAuthenticate
intTimeOut = rs!Timeout
txtusername = GetUserName
txtPassword = rs!VWPass
txtSSL = rs!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
You need to see the values BEFORE you attempt to use them.
