I have a database and I would like some VBA code to enable me to email specific pages of an Access report via Outlook.
For example, if I want to attach page 10 to 20 from a report.
I know how to attach a report to an email. This is my code that working properly, but I want to send specific page from Access Report.
Thanks in advance.
Dim olApp As Object
Dim olItem As Variant
Dim rec As Recordset
Dim db As Database
Dim fileName As String, todayDate As String
Set db = CurrentDb
todayDate = Format(Date, "MMDDYYYY")
fileName = Application.CurrentProject.path & "\Invoice_" & todayDate & ".pdf"
DoCmd.OutputTo acOutputReport, "rptInvoice", acFormatPDF, fileName, False
Set olApp = CreateObject("Outlook.application")
Set olItem = olApp.CreateItem(0)
olItem.display
olItem.To = Nz(rec![EmailPrimaryContact])
olItem.Subject = ""
olItem.Attachments.Add fileName
olItem.htmlBody = "Dear & " < br > " "
olItem.display
Set olItem = Nothing
Set rec = Nothing
Assuming you have Adobe as a printer option, consider DoCmd.PrintOut after adjusting the report's Printer property:
Use below subroutine to find Adobe printer
Sub Printers()
Dim prtDefault As Printer
For Each prtDefault In Application.Printers
Debug.Print prtDefault.DeviceName
Next prtDefault
Set prtDefault = Nothing
End Sub
Adjusted VBA (replaces DoCmd.OutputTo...)
Sub OutlookEmailModule()
...
DoCmd.OpenReport "rptInvoice", acViewReport ' OPEN REPORT
Reports("rptInvoice").Printer = Application.Printers("Adobe PDF") ' ADJUST PRINTER
DoCmd.PrintOut acPages, 7, 10 ' SUBSET PAGES
' PROMPTS YOU TO SAVE DOCUMENT AS fileName
DoCmd.Close acReport, acSaveNo ' CLOSE W/O SAVING
...
olItem.Attachments.Add fileName ' USE SAME FILE AS ABOVE
...
End Sub
Related
I've been putting this code together for a few days now with some success. My code will save pdf reports by project number so my battle is half won. The second part is where I am needing help getting each pdf report to automatically send to the project's email(Proj Mgr Emial) in the table.
tblEmailProjects
Additionally, while I can generate a single email (should be two) in the ".Display" mode, it attaches all the project's pdf reports instead of just the pdf report belonging to that recipient.
Single email generated by code
Finally, my variable strList causes an Runtime error "'-2147221238 The item has been moved or deleted" even tho it has been declared and set
I think/I hope I am close and would really appreciate any help...
Dim olApp As Object
Dim olMail As Object
Dim strExport As String
Dim strList As String
Set olApp = CreateObject("Outlook.Application")
Set olMail = olApp.CreateItem(olMailItem)
Dim rst As DAO.Recordset
'Public strRptFilter As String ' not need to use a public variable
Set rst = CurrentDb.OpenRecordset("SELECT DISTINCT [Proj_Nbr],[Project Mgr Emial] FROM [TblEmailProjects] ORDER BY [Proj_Nbr];", dbOpenSnapshot)
If rst.RecordCount > 0 Then ' make sure that we have data
rst.MoveFirst
Do While Not rst.EOF
strRptFilter = "[Proj_Nbr] = " & Chr(34) & rst![Proj_Nbr] & Chr(34)
DoCmd.OpenReport "rptProjCost", acViewPreview, , strRptFilter, acHidden ' open the report hidden in preview mode setting the where parameter
DoCmd.OutputTo acOutputReport, "rptProjCost", acFormatPDF, "C:\Users\Lisa Burns\Documents\AJI\Deploy DELPHI Projects\" & rst![Proj_Nbr] & ".pdf" ' save the opened report
DoCmd.Close acReport, "rptProjCost" ' close the report
strExport = "C:\Users\Lisa Burns\Documents\AJI\Deploy DELPHI Projects\" & rst![Proj_Nbr] & ".pdf"
strList = rst![Project Mgr Emial] ' ******ERRORS HERE WHEN ACTUALLY TRYING TO SEND EMAILS INSTEAD OF JUST DISPLAYING.&_
'WHEN DISPLAYING ONLY ONE EMAIL SHOWING LAST EMAIL ADDRESS IN THE RECORDsET*****
With olMail
.To = strList '******ERRORS HERE WHEN ACTUALLY TRYING TO SEND EMAILS INSTEAD OF JUST DISPLAYING
.CC = "" 'Change if you want a CC
.BCC = "" 'Change is you want a BCC
.Subject = "Project Costs for" & "rst![Proj_Nbr]" '****CODE DOES NOT CAPTURE PROJ_NBR...INCORRECT SYNTAX?"
.Body = "Attached, please find your project cost report for project number & rst![Proj_Nbr]." 'Change to what ever you want the body of the email to say
'Attaches the exported file using the variable created at beginning
.Attachments.Add strExport '*****ADDS ALL REPORTS INSTEAD OF FILTERING THE PDF REPORT THAT IS APPROPRIATE FOR THE RECIPIENT****
.Display 'Use for testing purposes only, note out for live runs '.Send 'Use for live purposes only.
End With
DoEvents
rst.MoveNext
Loop
End If ' rst.RecordCount > 0
'Frees email objects stored in memory
Set olMail = Nothing
Set olApp = Nothing
'stop added here
rst.Close
Set rst = Nothing
End Sub
What I will suggest you split your codes into two part. First part will saves pdf to your desired folder and second part will send mail to users with individual attachment. Below is code to send mail to individuals with separate pdf attachment. First test it from an command button then include these codes to your codes. It will be easier then to deploy.
Read this post.
I hope you are aware about Add References Microsoft Outlook x.xx Object Library.
Private Sub cmdSendMails_Click()
Dim oApp As New Outlook.Application
Dim oEmail As Outlook.MailItem
Dim strEmail As String, strAttachment As String
Dim mypath As String
mypath = "C:\Users\Lisa Burns\Documents\AJI\Deploy DELPHI Projects\" 'Change the path with your folder path
Dim db As DAO.Database
Dim rs As DAO.Recordset
Set db = CurrentDb()
Set rs = db.OpenRecordset("SELECT DISTINCT [Proj_Nbr],[Project Mgr Emial] FROM [TblEmailProjects]", dbOpenSnapshot)
On Error Resume Next 'Suppress errors
Do While Not rs.EOF
strAttachment = mypath & rs![Proj_Nbr] & ".pdf" 'Pdf name exactly as employee ID.
strEmail = rs![Project Mgr Emial] 'Email address from table column.
Set oEmail = oApp.CreateItem(olMailItem)
With oEmail
.Recipients.Add strEmail 'Add email address
.Subject = "Your subject text here."
.Body = "Your body text here."
.Attachments.Add strAttachment 'Attach PDF file.
'.Send
.Display 'Use .send to send the mail. Display will show the email editor window.
End With
Set oEmail = Nothing
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
Set db = Nothing
End Sub
I have a client that is using Access 2002 because it allows Replication. He is using this on Windows 10 with Outlook from Office 365.
The goal is to create a new email with all of the info filled in and attach a scanned proposal so that my client can review the email, make any changes that he wants and then send it.
In Access, the SendObject command creates and opens a plain text email and while this email is open my Outlook macro to scan a document and attach it to the email will not run.
So I would like to create a new Outlook email from Access that allows me to run my Outlook macro.
Or if I could get Access 2002 to create an email and attach the scanned document to it, I think I could get by with using msgboxes to verify specific items.
Below is the Access macro with the SendObject command followed by the Outlook macro.
Private Sub EmailProposal_Click()
'Access macro.
Dim stDocName As String
Dim stEmailAddress As String
Dim stSubject As String
Dim stMessage As String
stDocName = "rptProposal"
stEmailAddress = Forms!RequestForm!EmailAddress.Value
stSubject = "PROPOSAL"
stMessage = "Your proposal is attached." & vbCrLf & vbCrLf & "If you have any questions, please call us."
'Email the proposal.
DoCmd.SendObject acReport, stDocName, acFormatRTF, stEmailAddress, , , stSubject, stMessage
End Sub
Sub Scan()
'Outlook macro.
Dim myItem As Outlook.MailItem
Dim myAttachments As Outlook.Attachments
On Error Resume Next
Dim objCommonDialog As WIA.CommonDialog
Dim objImage As WIA.ImageFile
Dim strPath As String
Set objCommonDialog = New WIA.CommonDialog
'This shows the dialog box. I'd rather tell it what to do instead of having to manually choose each time.
Set objImage = objCommonDialog.ShowAcquireImage
strPath = Environ("TEMP") & "\TempScan.jpg" 'Save the scan.
If Not objImage Is Nothing Then
objImage.SaveFile strPath ' save into temp file
On Error GoTo ErrHandler
If TypeName(ActiveWindow) = "Inspector" Then
If ActiveInspector.IsWordMail And ActiveInspector.EditorType = olEditorWord Then
ActiveInspector.WordEditor.Application.Selection.Inlineshapes.AddPicture strPath 'Insert into email. I want to attach it instead.
End If
End If
Kill strPath
Else
MsgBox "The Scan macro in Outlook did not find a document." & vbCrLf & vbCrLf & _
"Please place the proposal in the printer so it can be scanned.", vbOKOnly
End If
lbl_Exit:
Set objImage = Nothing
Set objCommonDialog = Nothing
Exit Sub
ErrHandler:
Beep
Resume lbl_Exit
End Sub
It seems you just need to automate Outlook for sending out emails with the required content set up. Take a look at the following articles that give you the basics of Outlook automation:
Automating Outlook from a Visual Basic Application
Automating Outlook from Other Office Applications
Sub Send_Mail_Outlook()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "Hi there" & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2" & vbNewLine & _
"This is line 3" & vbNewLine & _
"This is line 4"
On Error Resume Next
With OutMail
.To = "eugene#astafiev.com"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = strbody
'You can add a file like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
I am trying to export a report in an from an Access database to multiple email address using a table and a report I have produced. Below is the code I have been using to accomplish this.
Function EmailNotification()
On Error GoTo Err_EmailNotification
Dim olApp As Object
Dim olMail As Object
Set olApp = CreateObject("Outlook.Application")
Set olMail = olApp.CreateItem(olMailItem)
Dim EmailList As String
Dim EmailList2 As String
Dim objOutlookRecip As Object
Dim objOutlookRecip2 As Object
Dim objOutlookAttach As Object
Const TERMINAL_QUERY = "SELECT EMail " & _
" FROM [EmailList] " & _
" ORDER BY Email;"
Dim dbs As DAO.Database
Dim rst1 As DAO.Recordset
DoCmd.OutputTo acOutputReport, "CarryIn_Email", "PDFFormat(*.pdf)", "Q:\2017\Big E Transportation\Accounting\Advanced Auto\Projects Summary Report.PDF", False, " , acExportQualityPrint"
Set dbs = CurrentDb()
Set rst1 = dbs.OpenRecordset(TERMINAL_QUERY)
With rst1
.MoveFirst
.MoveLast
.MoveFirst
rstX = rst1.RecordCount
If Not (.EOF And .BOF) Then
.MoveFirst
Do Until .EOF
Set olApp = CreateObject("Outlook.Application")
Set olMail = olApp.CreateItem(olMailItem)
With olMail
Set objOutlookRecip = .Recipients.Add(rst1!Email)
objOutlookRecip.Type = olTo
.Subject = "Carry Ins"
SETOBJOUTLOOKATTACH = .Attachments.Add("Q:\2017\Big E Transportation\Accounting\Advanced Auto\Projects Summary Report.PDF")
.Send
End With
.MoveNext
Loop
End If
End With
Exit_EmailNotification:
Exit Function
Err_EmailNotification:
MsgBox Error$
Resume Exit_EmailNotification
End Function
My problem is that this code is not exporting an email with a PDF attached to it, but instead is exporting an email with an email as the attachment.
I want this code to export an email with a PDF attachment, not an email with an email as the attachment.
Functions are procedures used to calculate something and return a result. The function you have above is not returning anything.
A subroutine is a procedure to run through steps in a process and not return a result.
the code provided below should satisfy what you are trying to accomplish:
Public Sub EmailNotification()
Dim olApp As Object
Dim olMail As Object
Dim strExport, strList As String
Dim rst1 As DAO.Recordset
Const TERMINAL_QUERY = "SELECT EMail " & _
"FROM [EmailList] " & _
"ORDER BY Email;"
On Error GoTo ErrorH
'Varibale to update one location for entire code
strExport = "Q:\2017\Big E Transportation\Accounting\Advanced Auto\Projects Summary Report.PDF"
'Ensures strList is empty for below check
strList = Empty
'Outputs the report to PDF using strExport variable
DoCmd.OutputTo acOutputReport, "CarryIn_Email", "PDFFormat(*.pdf)", strExport, False, " , acExportQualityPrint"
'Opens the recordset containing email addresses within const query above
Set rst1 = CurrentDb.OpenRecordset(TERMINAL_QUERY)
'ensure the recordset is fully loaded
rst1.MoveLast
rst1.MoveFirst
'loop to acquire email addresses from query statement, adding ";" to separate each email address
Do While Not rst1.EOF
If strList = Empty Then
strList = rst1![Email]
Else
strList = strList & "; "
End If
rst1.MoveNext
Loop
'Closes recordset and frees object in memory
rst.Close
Set rst = Nothing
'Creates the memory for email objects
Set olApp = CreateObject("Outlook.Application")
Set olMail = olApp.CreateItem(olMailItem)
'Generates email information
With olMail
'olFormatPlain is easier to type in an email with, my opinion only, this line is not needed
.BodyFormat = olFormatPlain
'Who the email is going to, using the strList created during loop above
.To = strList
.CC = "" 'Change if you want a CC
.BCC = "" 'Change is you want a BCC
.Subject = "Carry Ins"
.Body = "" 'Change to what ever you want the body of the email to say
'Attaches the exported file using the variable created at beginning
.Attachments.Add = strExport
.Display 'Use for testing purposes only, note out for live runs
'.Send 'Use for live purposes only, note out for test runs
End With
'Frees email objects stored in memory
Set olMail = Nothing
Set olApp = Nothing
EndCode:
'Ensures all objects are free from memory
If Not rst1 Is Nothing Then
rst1.Close
Set rst1 = Nothing
End If
If Not olApp Is Nothing Then
Set olMail = Nothing
Set olApp = Nothing
End If
Exit Sub
'Error handler to display error infor in message box, resumes end code
'Change is you want/need this to handle specific error numbers
ErrorH:
MsgBox Err.Number & " - " & Err.Description
Resume EndCode
End Sub
I have written VBA code for Microsoft Word to send an email when a button is clicked. When the button is clicked, and the macro is completed, I would like the file to be deleted from the Desktop.
When I run this macro now, Microsoft Word closes out, but the file is not deleted from my desktop.
Here is my code:
Private Sub CommandButton1_Click()
Dim OL As Object
Dim EmailItem As Object
Dim Doc As Document
Dim FileName As String
Dim FilePath As String
Dim DeletePath As String
Application.ScreenUpdating = False
Set OL = CreateObject("Outlook.Application")
Set EmailItem = OL.CreateItem(olMailItem)
Set Doc = ActiveDocument
myFileName = "Form"
FilePath = "C:\Users\" & Environ("Username") & "\desktop\"
Doc.SaveAs2 FileName:=FilePath & myFileName & ".docx", Fileformat:=wdFormatXMLDocument, AddToRecentFiles:=False
With EmailItem
.Subject = "Bid Award Form"
.Body = "Please Review the attached Bid Award form"
.To = "EMAILADDRESS#DOMAIN.COM"
.Importance = olImportanceNormal 'Or olImprotanceHigh Or olImprotanceLow
.Attachments.Add Doc.FullName
.Send
End With
'display a message using named arguments
MsgBox _
prompt:="Your email has been sent. Please check your Outlook sent mail for confirmation", _
Buttons:=vbOKOnly, _
Title:="Email Confirmation"
'Close the File
Doc.Close
Kill "C:\Users\" & Environ("Username") & "\desktop\form.docx"
'Close the Application of the document we are going to delete
Application.Quit
Application.ScreenUpdating = True
Set Doc = Nothing
Set OL = Nothing
Set EmailItem = Nothing
End Sub
Any help that you can provide will be very helpful!
Probably you are looking at the wrong file. Kill is a function, that makes no mistakes.
Simply try the following:
Sub KillTheFile
Kill "C:\Users\" & Environ("Username") & "\desktop\form.docx"
End Sub
Then see if it works. Probably you are having a file frm.docx or similar.
Try it like this instead
On Error Goto 0
Dim sDocName as string
sDocName = Doc.FullName
Doc.Close
Kill sDocName
I've been trying to find a script that saves attachments to a folder on our network from Outlook. I've finally got something working but it looks like it doesn't work on my 2nd system which happens to be Outlook 2010. I can't say for sure if it's because of this difference.
Code is:
Sub SaveAllAttachments(objItem As MailItem)
Dim objAttachments As Outlook.Attachments
Dim strName, strLocation As String
Dim dblCount, dblLoop As Double
strLocation = "C:\test\"
On Error GoTo ExitSub
If objItem.Class = olMail Then
Set objAttachments = objItem.Attachments
dblCount = objAttachments.Count
If dblCount <= 0 Then
GoTo 100
End If
For dblLoop = 1 To dblCount
strID = " from " & Format(Date, "mm-dd-yy") 'Append the Date
'strID = strID & " at " & Format(Time, "hh`mm AMPM") 'Append the Time
' These lines are going to retrieve the name of the
' attachment, attach the strID to it to insure it is
' a unique name, and then insure that the file
' extension is appended to the end of the file name.
strName = objAttachments.Item(dblLoop).Filename 'Get attachment name
strExt = Right$(strName, 4) 'Store file Extension
strName = Left$(strName, Len(strName) - 4) 'Remove file Extension
strName = strName & strID & strExt 'Reattach Extension
' Tell the script where to save it and
' what to call it
strName1 = strLocation & "PDF\" & strName 'Put it all together
strName2 = strLocation & "JPG\" & strName 'Put it all together
' Save the attachment as a file.
objAttachments.Item(dblLoop).SaveAsFile strName1
objAttachments.Item(dblLoop).SaveAsFile strName2
Next dblLoop
objItem.Delete
End If
100
ExitSub:
Set objAttachments = Nothing
Set objOutlook = Nothing
End Sub
It doesn't matter what Outlook version you are using at the moment. The code should work correcly.
Possible reasons why it doesn't work:
I'd suggest choosing another location for saving files. The C: drive requires admin privileges on latest OS.
The rule is not triggered.
An error in the script. Try to call the script manually from other VBA sub and see what happens under the hood. Do you get any errors in the code?