Option Explicit
Dim strFilename As String, strMsg As String
Dim aProjectLeaderMail As String
Dim aProductionPlannerMail As String
Dim aCurrentUserMail As String
Dim Acc As String
Private Sub Excecute_Click()
Dim SQL As String
Dim WPassStr As String
Dim sSQL As String
'Enter Password
If Nz(DLookup("[WPass]", "[GMailSettingsQry]")) = "" Then
Dim Message, Title, Default
Message = "Enter Windows Password"
Title = "Enter Parameters"
WPassStr = InputBox(Message, Title)
DoCmd.SetWarnings False
DoCmd.RunSQL "UPDATE GMailSettingsQry SET WPass =""" & WPassStr & """"
DoCmd.SetWarnings True
End If
Dim rs As Recordset
Dim vRecipientList As String
Dim vRecipientListCC As String
Dim vMsg As String
Dim vSubject As String
Dim vReportPDF As String
aProjectLeaderMail = ProjectLeaderMail
aProductionPlannerMail = ProductionPlannerMail
'Set To Recipient
Set rs = CurrentDb.OpenRecordset("SELECT * FROM EmailTBLQry_NewDaw; ")
If rs.RecordCount > 0 Then
rs.MoveFirst
Do
If Not IsNull(rs!To) Then
vRecipientList = vRecipientList & rs("To") & "," 'Vlad - changed email separator to comma
rs.MoveNext
Else
rs.MoveNext
End If
Loop Until rs.EOF
'Set CC Recipient
Set rs = CurrentDb.OpenRecordset("SELECT * FROM EmailTBLQry_NewDaw; ")
If rs.RecordCount > 0 Then
rs.MoveFirst
Do
If Not IsNull(aProjectLeaderMail) And aProjectLeaderMail <> "N/A" Then
Acc = Acc & "," & aProjectLeaderMail & "," & aProductionPlannerMail & ";" & aCurrentUserMail
rs.MoveNext
Else
rs.MoveNext
End If
Loop Until rs.EOF
'vSubject = "New DAW Sheet Listing - Registration: " & " " & rs("Registration")
vSubject = "New DAW Sheet Listing - Registration: " & " " & DLookup("[Registration]", "[EmailTblQry_NewDaw]")
vReportPDF = CurrentProject.Path & "\" & "DAW Sheet.pdf"
'<<<<<<<<<<<<<<<<<<<<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!")
'Debug.Print aProjectLeaderMail, aProductionPlannerMail, aCurrentUserMail
'Debug.Print Acc
Else
MsgBox "No contacts."
End If
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
aFrom = CurrentUserMail
aCurrentUserMail = CurrentUserMail
'==========================================
'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
Dim txtFrom As String
'Debug lines
'Debug.Print txtSendUsing, txtPort, txtServer, txtAuthenticate, intTimeOut, txtSSL
'Debug.Print txtusername, txtPassword, VWPass
'Debug.Print aTo, aProjectLeaderMail, aProductionPlannerMail, aCurrentUserMail
'Debug.Print aTo, aCC, aFrom
'Debug.Print aSubject
'Debug.Print aTextBody
'Debug.Print aPath
Set rs = CurrentDb.OpenRecordset("SELECT * FROM GMailSettingsQry;")
VWPass = VWPass & rs!WPass
'CDOEmailType = rs!EmailType
txtSendUsing = rs!SendUsing
txtPort = rs!ServerPort
txtServer = rs!EmailServer
txtAuthenticate = rs!SMTPAuthenticate
intTimeOut = rs!Timeout
txtusername = GetUserName
txtPassword = 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
.To = aCurrentUserMail
.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.Print Acc
'Debug.Print aTo, Acc, aFrom
'Debug.Print Acc & aProjectLeaderMail & aCurrentUserMail & aProductionPlannerMail
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 Sub
