Private Sub SendeMail()
Dim rs As Recordset
Dim vRecipientList As String
Dim vMsg As String
Dim vSubject As String
Set rs = CurrentDb.OpenRecordset("SELECT * FROM qryEmailReport ")
If rs.RecordCount > 0 Then
rs.MoveFirst
Do
If Not IsNull(rs! tbl.ContractorEmailaddress ) Then
vRecipientList = vRecipientList & rs! FieldThatHoldsTheeMailAddresses & ";"
rs.MoveNext
Else
rs.MoveNext
End If
Loop Until rs.EOF
vMsg = " Your Message here... "
vSubject = " Your Subject here... "
DoCmd.SendObject acSendReport, " rptProposal ", acFormatPDF, vRecipientList, , , vSubject, vMsg, False
MsgBox ("Report successfully eMailed!")
Else
MsgBox "No contacts."
End If
End Sub
I am looking to create a VBA string for a DoCmd.
I have a query that filters Report ID and the Contractors Email. I need a on click code made that will take the ReportID off of the form and then send it to all of the Email addresses that are linked to that ReportID. I was going to use a DoCmd.SendObject, but I'm not sure about how to write it.
Here's the relevant MSDN section:
https://msdn.microsoft.com/en-us/library/office/ff197046.aspx
Basic usage:
Docmd.SendObject acSendQuery, MyQueryName, acFormatXLS _
"To Email", "CC Email", ,"My Subject Line"
Related
I set up a code to save each page of a report as a separate PDF with the file name being the "release number"
I was able to get it to email each file in a separate email to a single email address.
But I can't figure out how to have the email recipient be dependent on the field "account"?
I have a table called "Distribution list" with the fields "Company" (the account name) and "Email".
I want it to send to the corresponding email for each company/account.
How could I achieve this?
Private Sub Command11_Click()
Dim rs As DAO.Recordset
Dim sFolder As String
Dim sFile As String
Const sReportName = "BLreport2"
'Dim strTo As String
' Dim strMessage As String
'Dim strSubject As String
On Error GoTo Error_Handler
'The folder in which to save the PDFs
sFolder = Application.CurrentProject.Path & "\"
'Define the Records that you will use to filtered the report with
Set rs = CurrentDb.OpenRecordset("SELECT account, [release number], contents3 FROM selectedbols", dbOpenSnapshot)
With rs
If .RecordCount <> 0 Then 'Make sure we have record to generate PDF with
.MoveFirst
Do While Not .EOF
'Build the PDF filename we are going to use to save the PDF with
sFile = sFolder & Nz(![release number], "") & ".pdf"
'Open the report filtered to the specific record or criteria we want in hidden mode
DoCmd.OpenReport sReportName, acViewPreview, , "[release number]=" & ![release number], acHidden
'Print it out as a PDF
DoCmd.OutputTo acOutputReport, sReportName, acFormatPDF, sFile, , , , acExportQualityPrint
'Close the report now that we're done with this criteria
'strTo = test#gmail.com
' strSubject = "Your invoice"
'strMessage = "Please find the invoice attached"
'DoCmd.SendObject acSendReport, "BLreport2", acFormatPDF, _
strTo, , , strSubject, strMessage
DoCmd.Close acReport, sReportName
'If you wanted to create an e-mail and include an individual report, you would do so now
.MoveNext
Loop
End If
End With
'Open the folder housing the PDF files (Optional)
Application.FollowHyperlink sFolder
Error_Handler_Exit:
On Error Resume Next
If Not rs Is Nothing Then
rs.Close
Set rs = Nothing
End If
Exit Sub
Error_Handler:
If Err.Number <> 2501 Then 'Let's ignore user cancellation of this action!
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: Command0_Click" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
End If
Resume Error_Handler_Exit
End Sub
I have a query in Access (Q_Invoices) that has separate records based on the invoice number (Invoice_Number). I also have a report that is linking to this query (R_Invoices_PDF). What I would like to do is to have VBA code to loop through each record in the query, and print the record as a separate PDF from the report.
I copied the following code from some website, and tried to adapt it for my purposes. It works to an extent. However, I stop it before it loops, and it saves all the records, not just the first one.
Private Sub cmd_GenPDFs_Click()
Dim rs As DAO.Recordset
Dim sFolder As String
Dim sFile As String
On Error GoTo Error_Handler
sFolder = "D:\Documents\Orchestra\Invoices\Invoice files\"
Set rs = CurrentDb.OpenRecordset("SELECT Invoice_Number FROM Q_Invoices", dbOpenSnapshot)
With rs
.MoveFirst
Do While Not .EOF
DoCmd.OpenReport "R_Invoices_PDF", acViewPreview, , "[Invoice_Number]=" & ![Invoice_Number], acHidden
sFile = Nz(![Invoice_Number], "") & ".pdf"
sFile = sFolder & sFile
DoCmd.OutputTo acOutputReport, "R_Invoices_PDF", acFormatPDF, sFile, acExportQualityPrint
'If you wanted to create an e-mail and include an individual report, you would do so now
DoCmd.Close acReport, "R_Invoices_PDF"
.MoveNext
Loop
End With
Application.FollowHyperlink sFolder 'Optional / Open the folder housing the files
Error_Handler_Exit:
On Error Resume Next
If Not rs Is Nothing Then
rs.Close
Set rs = Nothing
End If
Exit Sub
Error_Handler:
If Err.Number <> 2501 Then 'Let's ignore user cancellation of this action!
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: cmd_GenPDFs_Click" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occured!"
End If
Resume Error_Handler_Exit
End Sub
I recall some issue with filtering the report. Thus, we filter the query that drives the report to return only data for a single invoice using a TempVars.
Here, Faktura means Invoice:
Private Sub FakturaPrint( _
ByVal PrintType As CdPrintType, _
Optional ByRef FullPath As String)
Const ReportName As String = "Faktura"
Const FileNameMask As String = "Faktura{0}.pdf"
Const FileIdMask As String = "kladde Job {0}"
Const CancelError As Long = 2212 ' Cactus TimeSag cannot print the object.
Const PrintError As Long = 2501 ' PrintOut was cancelled.
Dim Path As String
Dim FileName As String
Dim FileId As String
Dim PrintCount As Integer
Dim PrintCopy As Integer
On Error GoTo FakturaPrint_Click_Error
' Set filter on the source query of the report.
TempVars("FakturaID").Value = Me!FaktID.Value
Select Case PrintType
Case cdPrintPreview
DoCmd.OpenReport ReportName, acViewPreview, , , acWindowNormal
Case cdPrintPrinter
PrintCount = Nz(Me!UdskFakt.Column(2), 1)
If PrintCount < 1 Then
PrintCount = 1
End If
For PrintCopy = 1 To PrintCount
DoCmd.OpenReport ReportName, acViewNormal, , , acWindowNormal
Next
Case cdPrintPdf
Path = Environ("USERPROFILE") & "\Documents\"
FileId = Nz(Str(Me!Faktura.Value), Replace(FileIdMask, "{0}", Me!JobID.Value))
FileName = Replace(FileNameMask, "{0}", FileId)
' Return FullPath by reference for e-mail.
FullPath = Path & FileName
DoCmd.OutputTo acOutputReport, ReportName, acFormatPDF, FullPath, False, , , acExportQualityPrint
End Select
FakturaPrint_Click_Exit:
Me!TextForClipboard.SetFocus
Exit Sub
FakturaPrint_Click_Error:
Select Case Err.Number
Case CancelError, PrintError
' Printing cancelled by user.
' Ignore.
Case Else
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure FakturaPrint_Click of Sub Form_Faktura"
End Select
Resume FakturaPrint_Click_Exit
End Sub
It is not a loop, but you can probably easily abstract from that.
I'm having an issue with an access form/report as it's not printing to the printer I've chosen from a combobox (that lists all the available printers).
I do know that I did create the report through the designer with the printer zebra-01 set and I think this is what might be causing the problem.
I have the following code to print labels from the report:
'Option Compare Database
Private Sub btnPrint_Click()
'Validate Input Given. If the input is less than or equal to 0 discard the print command.
'Two If statements, one for validating the input type and if the input is a positive number.
If IsNull(Me.txtNumberOfLabels) Or Not IsNumeric(Me.txtNumberOfLabels.Value) Then
MsgBox "O valor introduzido não é um valor numérico.", _
vbOKOnly, "Erro"
DoCmd.GoToControl "txtNumberOfLabels"
Exit Sub
End If
If Me.txtNumberOfLabels.Value <= 0 Then
MsgBox "O número de etiquetas a imprimir deve ser superior a 0", _
vbOKOnly, "Erro"
DoCmd.GoToControl "txtNumberOfLabels"
Exit Sub
End If
Dim availablePrinters As Printer
Dim selectedPrinter As String
DoCmd.GoToControl "cbPrintersList"
selectedPrinter = Me.cbPrintersList.Text
For Each availablePrinters In Application.Printers
If availablePrinters.DeviceName = selectedPrinter Then
Set Application.Printer = availablePrinters
Exit For
End If
Next availablePrinters
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim lastLabelRecordIndex_Part1 As String
Dim lastLabelRecordIndex_Part2 As String
Dim lastLabelRecordIndex_Part3 As String
Dim oldLastLabelRecordIndex_Part1 As String
Dim oldLastLabelRecordIndex_Part2 As String
Dim oldLastLabelRecordIndex_Part3 As String
Dim strSQL As String
Set db = CurrentDb
strSQL = "SELECT MAX(Pre_SSCC) As MaxRecord FROM SSCC_Gen"
Set rs = db.OpenRecordset(strSQL, dbOpenSnapshot)
oldLastLabelRecordIndex_Part1 = CStr(Left(rs("MaxRecord"), 8))
oldLastLabelRecordIndex_Part2 = CStr(Mid(rs("MaxRecord"), 9, 4))
oldLastLabelRecordIndex_Part3 = CStr(Right(rs("MaxRecord"), 5))
rs.Close
db.Close
Dim labelRecordIndex As Long
DoCmd.SetWarnings False
For labelRecordIndex = CLng(oldLastLabelRecordIndex_Part3) To CLng(oldLastLabelRecordIndex_Part3) + Me.txtNumberOfLabels.Value - 1
DoCmd.RunSQL "INSERT INTO SSCC_GenCount (Data) VALUES (#" & Format(Now(), "dd/mm/yyyy") & "#)"
Next labelRecordIndex
DoCmd.SetWarnings True
Set db = CurrentDb
Set rs = db.OpenRecordset(strSQL, dbOpenSnapshot)
lastLabelRecordIndex_Part1 = CStr(Left(rs("MaxRecord"), 8))
lastLabelRecordIndex_Part2 = CStr(Mid(rs("MaxRecord"), 9, 4))
lastLabelRecordIndex_Part3 = CStr(Right(rs("MaxRecord"), 5))
rs.Close
db.Close
Dim oldLastLabelRecordIndex As String
Dim lastLabelRecordIndex As String
oldLastLabelRecordIndex = oldLastLabelRecordIndex_Part1 & oldLastLabelRecordIndex_Part2 & CStr(oldLastLabelRecordIndex_Part3 + 1)
lastLabelRecordIndex = lastLabelRecordIndex_Part1 & lastLabelRecordIndex_Part2 & lastLabelRecordIndex_Part3
DoCmd.SetWarnings False
DoCmd.OpenReport Report_Labels_SSCC_Gen.Name, acViewPreview, , "Pre_SSCC BETWEEN '" & CStr(oldLastLabelRecordIndex) & "' AND '" & CStr(lastLabelRecordIndex) & "'", acHidden
Set Report_Labels_SSCC_Gen.Printer = Application.Printers(Me.cbPrintersList.ListIndex)
'MsgBox Report_Labels_SSCC_Gen.Printer.DeviceName
DoCmd.OpenReport Report_Labels_SSCC_Gen.Name, , , "Pre_SSCC BETWEEN '" & CStr(oldLastLabelRecordIndex) & "' AND '" & CStr(lastLabelRecordIndex) & "'", acHidden
DoCmd.Close acReport, Report_Labels_SSCC_Gen.Name, acSaveNo
DoCmd.SetWarnings True
End Sub
And this is the code to populate the combobox with the list of available printers, as soon as the form comes up:
Private Sub Form_Load()
Dim printerIndex As Integer
For printerIndex = 0 To Application.Printers.Count - 1
Me.cbPrintersList.AddItem (Application.Printers(printerIndex).DeviceName)
Next printerIndex
DoCmd.GoToControl "cbPrintersList"
End Sub
Now, according to dozens of articles I've read the whole day, the following bit of code should set the printer I want to print to, but it still keeps sending to the zebra-01 printer:
DoCmd.OpenReport Report_Labels_SSCC_Gen.Name, acViewPreview, , "Pre_SSCC BETWEEN '" & CStr(oldLastLabelRecordIndex) & "' AND '" & CStr(lastLabelRecordIndex) & "'", acHidden
Set Report_Labels_SSCC_Gen.Printer = Application.Printers(Me.cbPrintersList.ListIndex)
'MsgBox Report_Labels_SSCC_Gen.Printer.DeviceName
DoCmd.OpenReport Report_Labels_SSCC_Gen.Name, , , "Pre_SSCC BETWEEN '" & CStr(oldLastLabelRecordIndex) & "' AND '" & CStr(lastLabelRecordIndex) & "'", acHidden
DoCmd.Close acReport, Report_Labels_SSCC_Gen.Name, acSaveNo
Can anyone explain to me what am I missing or doing wrong?
As a reference, here's what's happening before and after the printer is set to the report.printer property:
Before setting the printer
After setting the printer
You can clearly see from the debug that the report has its printer property set to the printer I've chosen from the combobox.
However, for some reason I cannot understand, right after that line of code, when running the OpenReport to print the labels, it prints to zebra-01 printer instead...
Personally, I use the following code to print reports to a specified printer:
DoCmd.OpenReport "SomeReport", acViewPreview
Set Reports("SomeReport").Printer = Application.Printers("SomePrinter")
DoCmd.SelectObject acReport, "SomeReport"
DoCmd.PrintOut
DoCmd.Close
This only works with reports that are not printing to the default printer, so first open up the report in design view, go to page setup, and choose Use specific printer, then pick a printer (any printer), to make sure the report won't be printed on the system default printer.
If you want to specify paper size and bin, you can do so after setting the report printer:
DoCmd.OpenReport "SomeReport", acViewPreview
Set Reports("SomeReport").Printer = Application.Printers("SomePrinter")
Reports("SomeReport").Printer.PaperSize = 1
Reports("SomeReport").Printer.PaperBin = 2
DoCmd.SelectObject acReport, "SomeReport"
DoCmd.PrintOut
DoCmd.Close
Getting the right numbers for the paper and bin numbers is a bit complicated, however. The process is outlined here: https://learn.microsoft.com/en-us/office/vba/access/concepts/printing/programmatically-retrieve-printer-capabilities
Please see code below that returns a run-time error 3265 due to the line:
strTo = !email_address1
however, if i changed it to
strTo = !AccountNumber it will populate in the outlook email To: line properly but i need the email address, not the account number - do i need to define email_address1? it is a short text field in my query/report. if so, how do i define it? totally new to access.
Option Compare Database
Sub Mac1()
Dim rsAccountNumber As DAO.Recordset
Dim strTo As Variant
Dim strSubject As String
Dim strMessageText As String
Set rsAccountNumber = CurrentDb.OpenRecordset("SELECT DISTINCT AccountNumber, email_address1 FROM [P3_DVP_UnAffirmed_Report_for_En Query]", dbOpenSnapshot)
With rsAccountNumber
Do Until .EOF
DoCmd.OpenReport "Unaffirmed Report", _
acViewPreview, _
WhereCondition:="AccountNumber = '" & !AccountNumber & "'", _
WindowMode:=acHidden
strTo = !Email_Address1
strSubject = "Invoice Number "
strMessageText = "Text Here"
DoCmd.SendObject ObjectType:=acSendReport, _
ObjectName:="Unaffirmed Report", _
OutputFormat:=acFormatPDF, _
To:=strTo, _
Subject:=strSubject, _
MESSAGETEXT:=strMessageText, _
EditMessage:=True
DoCmd.Close acReport, "Unaffirmed Report", acSaveNo
.MoveNext
Loop
.Close
End With
End Sub
In your SELECT list you should specify the email_address1 field so:
Set rsAccountNumber = CurrentDb.OpenRecordset("SELECT DISTINCT AccountNumber, email_address1 FROM [P3_DVP_UnAffirmed_Report_for_En Query]",dbOpenSnapShot)
Returning after fixing errors and now a new one. I have created an SQL Statement using VBA in Access 2007 and I am getting the error "Item not found in this collection" The fields do exist in the tables and are spelled correctly. I even copied the SQL statement into a query and it worked. I'm assuming the error is with this part of the code
Dim strCMCID As Long ' (it's a Key field AutoNumber)
strCMCID = Me!CMCID_Txt
and
"WHERE Commitments_Tbl.CMCID = " & strCMCID & ""
Full code posted below. This is my first time putting an SQL Statement in using VBA. What I am trying to do is get the SQL Statement to pull two email addresses from a specific record from the current Form.
Public Sub SendConfirm()
On Error GoTo Err_SendConfirm_Click
Dim Borrower As String, LOEmail As String, ProcEmail As String, ClsEmail As String, Caution As String, LNumber As Long, TheFile As String, TheName As String
'SQL Statement to get Processor and Closer email
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim strSQL As String
Dim strCMCID As Long 'AutoNumber
Dim strMWS As String
Dim strProcEM As String
Dim StrClsEM As String
strCMCID = Me!CMCID_Txt 'AutoNumber
strSQL = "SELECT Commitments_Tbl.CMCID, Status_Tbl.MWStatus, DBUsers_Tbl.EMail, DBUsers_Tbl_1.EMail " & _
"FROM ((Commitments_Tbl LEFT JOIN Status_Tbl ON Commitments_Tbl.LoanNumber = Status_Tbl.LoanNumber) LEFT JOIN DBUsers_Tbl AS DBUsers_Tbl_1 ON Status_Tbl.Processor = DBUsers_Tbl_1.MWName) LEFT JOIN DBUsers_Tbl ON Status_Tbl.Closer = DBUsers_Tbl.MWName " & _
"WHERE Commitments_Tbl.CMCID = " & strCMCID & ""
Set dbs = CurrentDb
Set rst = CurrentDb.OpenRecordset(strSQL)
strMWS = rst!MWStatus
strProcEM = Nz(rst!DBUsers_Tbl.EMail, "John.Doe#CWork.com")
StrClsEM = Nz(rst!DBUsers_Tbl_1.EMail, "John.Doe#Work.com")
'Message Box
Dim Msg, Style, Title, Response
LOEmail = Me!OrigID_Cbo.Column(3)
Borrower = Me!BorrNameL_Txt
LNumber = Nz(Me!LoanNumber_Txt, 0)
Msg = "Do you want to send an e-mail to Set_up?"
Style = vbYesNo
Title = "Cancel Set-Up E-Mail"
Response = MsgBox(Msg, Style, Title)
If Response = vbYes Then
GoTo line3
Else
GoTo line4
End If
line3:
TheName = "" & Borrower & " " & LNumber & ""
TheFile = "P:\mortgage\prodcenters\LOAN ITEMS (SW)\_RateLocks_and_Changes\" & TheName & ".rtf"
DoCmd.OutputTo acOutputReport, "Confirmation_Email2", acFormatRTF, TheFile, False
If Nz(Me!InvestorID_Cbo, "Blank") = "Blank" Then
DoCmd.SendObject , , , "CommerceMortgage#CommerceBank.com", , , "New Lock: " & Borrower & ": " & LNumber, "A rate lock confirmation has been saved down to the server at P:\mortgage\prodcenters\LOAN ITEMS (SW)\_RateLocks_and_Changes as a word document with the same name and loan number as that is the subject line of this email. Please upload it into the GDR.", -1
Else
DoCmd.SendObject , , , "CommerceMortgage#CommerceBank.com", , , "Term Change" & ": " & Borrower & ": " & LNumber, "A rate lock confirmation has been saved down to the server at P:\mortgage\prodcenters\LOAN ITEMS (SW)\_RateLocks_and_Changes as a word document with the same name and loan number as that is the subject line of this email. Please upload it into the GDR.", True
End If
line4:
ClsEmail = Nz(StrClsEM, "John.Doe#Work.com")
ProcEmail = Nz(strProcEM, "John.Doe#Work.com")
If Me!RateExpDate_Txt <= Date + 8 Then
Caution = "STOP Terms Finalized:"
ElseIf strMWS = "Closing" And Me!RateExpDate_Txt >= Date + 8 Then
Caution = "STOP:"
Else
Caution = ""
End If
If Me!InvestorID_Cbo = "" Then
DoCmd.SendObject acSendReport, "Confirmation_Email", "SnapshotFormat(*.snp)", LOEmail, ProcEmail & ";" & ClsEmail, , Caution & "New Lock: " & Borrower & ": " & LNumber, , True
Else
DoCmd.SendObject acSendReport, "Confirmation_Email", "SnapshotFormat(*.snp)", LOEmail, ProcEmail & ";" & ClsEmail, , Caution & " " & "Term Change" & ": " & Borrower & ": " & LNumber, , True
End If
rst.Close
Set rst = Nothing
Set dbs = Nothing
Exit_SendConfirm_Click:
Exit Sub
Err_SendConfirm_Click:
MsgBox Err.Description
Resume Exit_SendConfirm_Click
End Sub
If we create a query in Access that pulls two fields with the same name from two different tables then Access will name the resulting columns Table1.Field and Table2.Field to disambiguate. When referring to those fields in the Recordset using "bang (!) notation" you must put square brackets around the entire field name. In your case, for example, you would need to use
rst![DBUsers_Tbl.EMail]
instead of
rst!DBUsers_Tbl.EMail