I want to send automatic emails to the persons whose emailID will be stored in the fields of a query with my report (same to everyone) as attachment.
I have the query, during compiling it is showing error message "in query expression.
Error 3075
I need to attach my report with every email, but I am not finding a way to delete every time after sending from my local file (I have removed the code related to this, so you can add a new one)
Option Compare Database
Option Explicit
Public Sub sendserialemail()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim emailto As String
Dim emailcc As String
Dim emailsubject As String
Dim emailtext As String
Dim outapp As Outlook.Application
Dim outmail As Outlook.MailItem
Dim outstarted As Boolean
Dim rpt As Report
Dim pdfmail As String
On Error Resume Next
Set outapp = GetObject(, "outlook.application")
On Error GoTo 0
If outapp Is Nothing Then
Set outapp = CreateObject("outlook.application")
outstarted = True
End If
Set db = CurrentDb
Set rs = db.OpenRecordset("qryeMailOverdueTasks")
DoCmd.OutputTo acOutputReport, "tasks", acFormatPDF, "desktop"
Do Until rs.EOF
emailto = rs.Fields("responsible person").Value
emailcc = "ravikumar.ramadas#plansee.com"
emailsubject = "Pending tasks to complete the issue regarding" & " " & rs.Fields("issue").Value
emailtext = "Hello" & vbCrLf & "Kindly complete the task which is in the attached file to complete the cutomer isue regarding" & " " & rs.Fields("issue").Value
pdfmail = "tasks.pdf"
Set outmail = outapp.CreateItem(olMailItem)
outmail.To = emailto
outmail.CC = emailcc
outmail.Subject = emailsubject
outmail.Body = emailtext
outmail.Attachments = pdfmail
outmail.Send
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
Set db = Nothing
If outstarted Then
outapp.Quit
End If
Set outmail = Nothing
Set outapp = Nothing
End Sub
Code tries to save a pdf named "desktop" to folder db is located in. Then code tries to attach a file named "tasks.pdf" but this file does not exist nor does this specify file path where pdf is located.
Correct code to specify file path and name to save and retrieve.
Related
I'm completely new to VB and I'm trying to extract the attachment which is saved available inside the .msg file using the below code.
Could someone help me if this is the right approach to do this ?
I'm facing below compiler errors. Could someone help me how to resolve this issue ?
Outlook.Attachment is not defined.
End Sub' must be preceded by a matching 'Sub'
Reference to a non-shared member requires an object reference.
Statement cannot appear within a method body. End of method assumed
Method arguments must be enclosed in parentheses.
Type 'Outlook.MailItem' is not defined.
Sub SaveOlAttachments()
Dim msg As Outlook.MailItem
Dim att As Outlook.Attachment
Dim strFilePath As String
Dim strAttPath As String
Dim strFile As String
strFilePath = "C:\Users\...\Desktop\Test\"
strAttPath = "C:\Users\...\extracted attachment\"
strFile = Dir(strFilePath & "<Doc Name>.msg")
Do While Len(strFile) > 0
msg = Application.CreateItemFromTemplate(strFilePath & strFile)
If msg.Attachments.Count > 0 Then
For Each att In msg.Attachments
att.SaveAsFile strAttPath & att.FileName
Next
End If
strFile = Dir
Loop
End Sub
First of all, check out the file path where you try to find the template:
msg = Application.CreateItemFromTemplate(strFilePath & strFile)
The strFilePath string may include the file name already:
strFile = Dir(strFilePath & "<Doc Name>.msg")
Second, make sure attachments are saved using unique file names:
att.SaveAsFile strAttPath & att.FileName
The FileName string can be the same in different emails. I'd recommend adding IDs or the current time and etc. to the file name to uniquely name attached files on the disk.
Here is the code we use to grab a daily report attachment. I left a few commented statements in case you might need them (we didn't).
Sub Extract_Outlook_Email_Attachments()
On Error GoTo ErrHandler
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim folder As MAPIFolder
Dim OutlookMail As Variant
Dim i As Integer
Dim olNS As Outlook.Namespace
Dim objOwner As Outlook.Recipient
Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Dim saveFolder As String
saveFolder = strAttPath ' SAVE THE ATTACHMENT TO
'this bit is added to get a shared email
Set objOwner = OutlookNamespace.CreateRecipient("SHARED FOLDER NAME")
objOwner.Resolve
If objOwner.Resolved Then
Debug.Print "Outlook GB Fulfillment is good."
Set folder = OutlookNamespace.GetSharedDefaultFolder(objOwner, olFolderInbox) 'can use olFolderInbox or olFolderSentMail
End If
'Write mail to spreadsheet - create named range, from and to dates on the spreadsheet
i = 1
For Each OutlookMail In folder.Items
' Debug.Print "SenderEmailAddress: " & OutlookMail.SenderEmailAddress
'If OutlookMail.SenderEmailAddress = "no-reply#OurCompany.com" Then
If OutlookMail.subject = "Daily Report" Then
' If OutlookMail.SenderName = "no-reply#OurCompany.com" And OutlookMail.Subject = "Daily New Subscriber Plan Election Fulfillment" And OutlookMail.Attachments(1) = "NewSubscriberPlanElectionFulfillment_Subscription.xls" Then
Debug.Print "Received: " & OutlookMail.ReceivedTime
Debug.Print "Attach: " & OutlookMail.Attachments(1)
dateformat = Format(OutlookMail.ReceivedTime, "m-d-yy")
Debug.Print dateformat
FName = dateformat & " " & OutlookMail.Attachments(1).fileName
Debug.Print "FName: " & FName
Dim strFileExists As String
strFileExists = Dir(saveFolder & FName)
If strFileExists = "" Then
' MsgBox "The selected file doesn't exist"
Else
' MsgBox "The selected file exists"
Exit Sub
End If
OutlookMail.Attachments(1).SaveAsFile saveFolder & FName
Set outAttachment = Nothing
End If
Next OutlookMail
Set folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
ErrHandler:
Debug.Print Err.Description
End Sub
Instead of using CreateItemFromTemplate, you can use Namespace.OpenSharedItem to open an MSG file.
You also need to add Outlook to your VB.Net project references.
I am trying to make email using Outlook to remind someone to update their CV information per 6 months (180 days).
I have 1 query and 1 table.
Duedate_7 query consists of employee information, which passed 180 days or more since the last update. Access would send email to those employees.
Highlights table consists of the ID of the employees (Number), date of the project (date) and content of the project (long text).
Option Compare Database
Option Explicit
Function Otomail()
Dim db As DAO.Database
Dim rs1 As DAO.Recordset
Dim emailTo As String
Dim emailSubject As String
Dim emailText As String
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
Dim outlookStarted As Boolean
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If outApp Is Nothing Then
Set outApp = CreateObject("Outlook.Application")
outlookStarted = True
End If
Set db = CurrentDb
Set rs1 = db.OpenRecordset("SELECT ID, NIK, Nama, email, datemailsend FROM DueDate_7")
Do Until rs1.EOF
emailTo = rs1.Fields("email")
emailSubject = "Update CV"
emailText = "Please send the newest project highlights informations of Mr/Mrs' " & rs1.Fields("Nama").Value & " to the inside sales department for updating your CV which is scheduled once per 6 months." & vbCr & _
"Your latest project highlights update was " & vbCr & _
"This email is auto generated from Task Database. Please Do Not Reply!"
Set outMail = outApp.CreateItem(olMailItem)
outMail.To = emailTo
outMail.Subject = emailSubject
outMail.Body = emailText
outMail.Display
rs1.Edit
rs1!datemailsend = Date
rs1.Update
rs1.MoveNext
Loop
rs1.Close
Set rs1 = Nothing
Set db = Nothing
Set outMail = Nothing
Set outApp = Nothing
End Function
I want to include each of the employee's 3 latest project highlights, stored in Highlights table, in each of the email I send.
What you need to do is to use a second recordset inside the loop that you have already got that selects the information required. Something like:
If Not (rs1.BOF And rs1.EOF) Then
Do
strProject = ""
strSQL = "SELECT TOP 3 ProjectName, ProjectDate " _
& " FROM Highlights " _
& " WHERE NameID=" & rs1!NameID _
& " ORDER BY ProjectDate DESC;"
Set rsProject = db.OpenRecordset(strSQL)
If Not (rsProject.BOF And rsProject.EOF) Then
Do
strProject = strProject & rsProject!ProjectDate & vbTab & rsProject!ProjectName & vbCrLf
rsProject.MoveNext
Loop Until rsProject.EOF
End If
Set outMail = outApp.CreateItem(olMailItem)
outMail.To = rs1!email
outMail.Subject = "Update CV"
outMail.Body = emailText & strProject
outMail.Display
rs1.MoveNext
Loop Until rs1.EOF
End If
This is assuming that you have a field called NameID that identifies the person to be selected.
Regards,
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 tried this simple code:
Sub sendOutlookEmail()
Dim oApp As Outlook.Application
Dim oMail As MailItem
Set oApp = CreateObject("Outlook.application")
Set oMail = oApp.ActiveExplorer.Selection.Item(1)
Dim HTMLBody As String
HTMLBody = oMail.HTMLBody
HTMLBody = Replace(HTMLBody, Chr(34), Chr(34) & Chr(34), 1)
Dim sql As String
sql = "UPDATE email_body set email_body = " & Chr(34) & HTMLBody & Chr(34)
Debug.Print sql
CurrentDb.Execute sql
Set oMail = Nothing
Set oApp = Nothing
End Sub
This simple code saves the body of the email to my MS Access table with all HTML elements. Later on, I want to run this code:
Sub sendOutlookEmail()
Dim oApp As Outlook.Application
Dim oMail As MailItem
Set oApp = CreateObject("Outlook.application")
Set oMail = oApp.CreateItem(olMailItem)
Dim sql As String
sql = "Select email_body from email_body"
Dim rs As DAO.Recordset
Set rs = CurrentDb.OpenRecordset(sql)
oMail.Body = rs("email_body")
oMail.Subject = "email sent from ms access using vba 2"
oMail.To = "receiver#somthing.com"
oMail.Display
Set oMail = Nothing
Set oApp = Nothing
End Sub
That code should take whatever was stored in my MS Access table and create a new email. What it does though, it copies the literal HTML code into the body of the email which is obviously not what I want. Is there a way to get it displayed the proper way?
Use the MailItem.HTMLBody property, as opposed to the MailItem.Body property.
[The HTMLBody property] returns or sets a String representing the HTML body of the specified item. [It is both] read/write.
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