The query that contains all the email addresses have all the info requiredThat would indicate that you did not have ANY email addresses?
Walk through your code line by line, especially where you get the email addresses.
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
Set rs = CurrentDb.OpenRecordset("SELECT * FROM TechPubDual ")
, which one is it?Option Explicit
Dim strFilename as string, 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 & """" 'this line will fail if Emailtbl table is 'empty, you would need to replace it with 'an "INSERT INTO" statement
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 TechPubDual;") 'you had Emailtbl here in the latest version
If rs.RecordCount > 0 Then
rs.MoveFirst
Do
If Not IsNull(rs!email) Then
vRecipientList = vRecipientList & rs("To") & "," 'Vlad - changed email separator to comma
End If
rs.MoveNext
Loop Until rs.EOF
vMsg = rs("Message") 'do you have a Message field in TechPubDual; you shouldn't as you would have to repeat 'it for every record along with the registration; these fields should be moved to a 'different table such as Emailtbl if that has only one record for the email settings
'vMsg= DLookup("[Message]", "[EmailTbl]") 'uncomment this line if you move the fields to Emailtbl and 'comment or delete the one above
vSubject = "New DAW Sheet Listing - Registration: " & " " & rs("Registration") 'see comment above
'vSubject ="New DAW Sheet Listing - Registration: " & " " & DLookup("[Registration]","[EmailTbl]") 'uncomment the above line if you move the fields to Emailtbl andment or delete the original one above it
vReportPDF = CurrentProject.Path & "\" & "DAW Sheet.pdf" 'you have to include the extension
'<<<<<<<<<<<<<<<<<<<<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
End Sub
Public Function GetUserName() As String
GetUserName = Environ("UserName")
End Function
Sub SendEMailCDO(aTo, aCC, aSubject, aTextBody, aFrom, aPath)
Dim vProductionPlannerMail As String
aCC = vProductionPlannerMail
'==========================================
'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 ") 'why not keep this
VWPass = VWPass & rs!WPass 'why not keep this in the same table as the other settings
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 'VWPass is in a different table and you already got it above
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
.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
Hi,@Gizmo
Initially you had your email list (of the recipients of your report) in TechPubDual, but now you are trying to get it from Emailtbl, whichSet rs = CurrentDb.OpenRecordset("SELECT * FROM TechPubDual ")
, which one is it?
I am going over your code now, I will post an update soon.
Cheers,
Vlad
Hi,Try to remove the spaces at the end of the two Select statements. Did you read my comments regarding the various tables? You are using EmailTBL to build your list of recipients which suggests it has multiple records yet to store the Windows password, the body of the message you want to send and part of the subject line of the message in the same table, meaning you have to replicate these three fields for each record. You should move those to the GmailSettingsTbl ( I don't know why you have a GMailSettingsQry as that table shold only have one record).
Cheers,
Vlad
Please post the entire code again, I cannot see where you declare the rs as DAO.Recordset.
Cheers,
Option Explicit
Dim strFilename As String, 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]", "[EmailTblQry]")) = "" Then
Dim Message, Title, Default
Message = "Enter Windows Password"
Title = "Enter Parameters"
WPassStr = InputBox(Message, Title)
DoCmd.SetWarnings False
DoCmd.RunSQL "UPDATE EmailTblQry 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 EmailTBLQry; ")
If rs.RecordCount > 0 Then
rs.MoveFirst
Do
If Not IsNull(rs!To) Then
'vRecipientList = vRecipientList & rs!To & "," 'Vlad - changed email separator to comma
vRecipientList = vRecipientList & rs("To") & "," 'Vlad - changed email separator to comma
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]")
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!")
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 vProductionPlannerMail As String
Dim rs As String
aCC = vProductionPlannerMail
'==========================================
'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 EmailTBLQry;")
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 'VWPass is in a different table and you already got it above
'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
.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
That is because he has defined it as a string??????Please post the entire code again, I cannot see where you declare the rs as DAO.Recordset.
Cheers,
Hi,That is because he has defined it as a string??????
Dim rs As String
Gismo,Hi,
Was defining as string incorrect?
What should it be defined as?
Oh I see, sorry, missed that completelyGismo,
That question really disappoints me, and reveals a great deal.
I'll give you a clue.
In one portion of the code you define rs as a recordset and then use that to get data from TechPubDual
You 'say' that gets you your email addresses. ? It used to, until you posted your last update, but let's say it does anyway.
Then in Sub SendEMailCDO you define it as a string.?
Which do you think it should be defined as?
Google 'Access recordset' and see what a recordset actually is. The clue is in the name anyway.
You do not seem to be learning anything at all with all these mistakes, which again disappoints me. I try and learn by my mistakes and avoid repeating them.
well i never thought that, debig.print works like a charmAs I said before, sit back and think of the what you are trying to do and the steps to achieve it. Break it down to small steps, make sure one works before moving on to the next. If you just throw a pile of code together, a novice cannot tell where the error is, if the debugger does not show them.
indent your code to make it easier to read AND debug errors. Google Smart Indenter and install that. I use that a lot for other peoples code (like yours ), so that I can read it easier.
I tend to think of 'How would I do it manually', then automate it, then perhaps tweak it.
It does not have to be the most efficient code in the world, but it does have to work reliably, time after time.
Google is your friend here.