Not sure why this is failing with a
"runtime error operation failed"
It seems to be crashing on the ".Attachments.Add fileName" line. I've read that you can run into issues if you are passing an object to the attachments, but I don't think I've done that.
Public Sub DraftEmailWithAttachment(strTo As String, strSubject As String, _
strBody As String, fileName As String)
Dim oApp As Object
Dim oEmail As Object
Set oApp = CreateObject("Outlook.Application")
Set oEmail = oApp.CreateItem(0)
With oEmail
.To = strTo
.subject = strSubject
.Attachments.Add fileName
.display
.HTMLBody = strBody & oEmail.HTMLBody
End With
End Sub
and
Private Sub btnEmailActionItems_Click()
Dim fileName As String
Dim todayDate As String
Dim strTo As String
Dim strSubject As String
Dim strBody As String
Dim filter As String
Dim oApp As Object
Dim oEmail As Object
Set oApp = CreateObject("Outlook.Application")
Set oEmail = oApp.CreateItem(0)
strTo = Nz(Me.cboUnderwriter.Column(2), "")
strSubject = Nz(Me.txtNamedInsured.Value, "") & " - " & _
Nz(Me.txtSubmissionNumber.Value, "") & " - " & _
Nz(Me.txtQuoteNumber.Value, "")
strBody = "Hello " & Me.cboUnderwriter.Column(3) & ", <br/><br/>"
todayDate = Format(Date, "MM.DD.YYYY")
fileName = "C:\Users\crewsj3\Desktop\tmp\Action Items Report -" & _
strSubject & " " & todayDate & ".pdf\"
filter = "submission_number=" & Nz(Me.txtSubmissionNumber.Value, "")
'generate filtered report
Call ExportFilteredReportToPDF("rptActionItemsForAllPolicies", fileName, filter)
'generate email
Call DraftEmailWithAttachment(strTo, strSubject, strBody, fileName)
End Sub
Any ideas?
Edit:
It looks like the problem was the trailing slash. works fine now. Thanks for the help.
The source of the attachment can be a file (represented by the full file system path with a file name) or an Outlook item that constitutes the attachment. See Attachments.Add for more information.
Based on the code listed above you just need to make sure the file path is valid and doesn't contain forbidden symbols. Try to copy the actual file path at runtime and paste it into any windows explorer window. Following that way, you can be sure that a file can be found and read.
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 convert a worksheet into a PDF and am trying to have that PDF emailed to me and copied to another person. All of this will be assigned to an action button/trigger.
Option Explicit
Sub SendExcelFileAsPDF()
Dim OutlookApp As Outlook.Application
Dim emItem As Object
Dim Receipt As String, Subject As String
Dim Message As String, Fname As String
Dim Recipient As Outlook.Recipient
Recipient = "xxxxx.xxxxx#fedex.com"
Subject = "Weekly Critical Items" & " " & Range("L1")
Message = Range("D2") & Range("J2") & "Weekly Critical Items submitted" &
Range("L1") & " " & "in PDF Format"
Message = Message & vbNewLine & vbNewLine & "Offload Ops"
Fname = Application.DefaultFilePath & "/" & ActiveWorkbook.Name & ".pdf"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Fname
Set OutlookApp = New Outlook.Application
Set emItem = OutlookApp.CreateItem(olMailItem)
With emItem
.To = Recipient = "xxxxx.xxxxx#fedex.com"
.Subject = Subject
.Body = Message
.Attachements.Add Fname
.Send
End With
Set OutlookApp = Nothing
End Sub
The recipient line is where I am having issues. When I run the debugger, it's giving
Run-Time error '91: Object variable or with block variable not set
I would dim recipient as string and update the .to assignment:
Change
Dim Recipient As Outlook.Recipient
.To = Recipient = "dennis.aikens#fedex.com"
to
Dim Recipient As string
.To = Recipient
This line
.To = Recipient = "dennis.aikens#fedex.com"
Should be just
.To = Recipient
I created a form that contains an attachment field that screenshots are attached to in .jpg format.
I am trying to send emails from the form.
I would like to attach the screenshots to the email, (the one that is already attached on the form).
I tried using the .attachment.add me.attachmentfield. This is not attaching anything to the email.
Also I am using a combobox to select a person to send the email to, (this is stored in another table along with an email address). I am unable to populate the To box in the email with the email address of the individual selected.
Actually an Access attachment field is not an email attachment. Access doesn't have a build in email client, so you must use an email client library like CDO or the Outlook Object library:
Public Function SendEmail(strRecipients As String, strSubject As String, _
Optional strBody As String, Optional strFilePath As String, _
Optional strFileExtension As String) As String
On Error GoTo ProcError
Dim myObject As Object
Dim myItem As Object
Dim strFullPath As String
Dim strFileName As String
Dim strAttachPath As Variant
Dim intAttachments As Integer
Set myObject = CreateObject("Outlook.Application")
Set myItem = myObject.CreateItem(0)
With myItem
.Subject = strSubject
.To = strRecipients
If Len(Trim(strBody)) > 0 Then
.body = strBody
End If
If Len(Trim(strFileExtension)) = 0 Then
strFileExtension = "*.*"
End If
If Len(strFilePath) > 0 Then
strFullPath = strFilePath & "\" & strFileExtension
If Len(Trim(strFullPath)) > 0 Then 'An optional path was included
strFileName = Dir(strFullPath)
Do Until strFileName = ""
intAttachments = intAttachments + 1
strAttachPath = (strFilePath & "\" & strFileName)
.Attachments.add (strAttachPath)
' Debug.Print strAttachPath
strFileName = Dir()
Loop
End If
End If
.Send
SendEmail = "Message placed in outbox with " & intAttachments & " file attachment(s)."
End With
ExitProc:
Set myItem = Nothing
Set myObject = Nothing
Exit Function
ProcError:
MsgBox "Error " & Err.Number & ": " & Err.Description, _
vbCritical, "Error in SendMail Function..."
SendEmail = "A problem was encountered attempting to automate Outlook."
Resume ExitProc
End Function
Use Field.SaveToFile to dump the Access attachment to a temp file.
I have some Excel VBA code which save active sheet as PDF then attach that PDF file to outlook new mail everything works fine except the signature in outlook when the code starts outlook and new message it does not show the signature despite its in HTML and I can already insert it manually.
so any adjustment to the code will be appreciated.
Sub Send_To_Pdf()
Dim PdfPath As String
Dim BoDy As String
BoDy = Msg = "Dear Mr. " & vbCrLf & vbCrLf & "Good Day" & vbCrLf & vbCrLf & "Kindly find the attahched P.O to be delivered to " & Cells(10, 12)
PdfPath = Save_as_pdf
EnvoiMail Right(PdfPath, InStr(1, StrReverse(PdfPath), "\") - 1), "recepient1#domain.com;recepient2#domain.com", , , BoDy, 1, PdfPath
End Sub
Public Function Save_as_pdf() As String
Dim FSO As Object
Dim s(1) As String
Dim sNewFilePath As String
Set FSO = CreateObject("Scripting.FileSystemObject")
s(0) = "C:\Users\" & Environ("UserName") & "\Desktop\" & ThisWorkbook.Name
If FSO.FileExists(ThisWorkbook.FullName) Then
'//Change Excel Extension to PDF extension in FilePath
s(1) = FSO.GetExtensionName(s(0))
If s(1) <> "" Then
s(1) = "." & s(1)
sNewFilePath = Replace(s(0), s(1), ".pdf")
'//Export to PDF with new File Path
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=sNewFilePath, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
End If
Else
'//Error: file path not found
MsgBox "Error: this workbook may be unsaved. Please save and try again."
End If
Set FSO = Nothing
Save_as_pdf = sNewFilePath
End Function
Sub EnvoiMail(Subject As String, Destina As String, Optional CCdest As String, Optional CCIdest As String, Optional BoDyTxt As String, Optional NbPJ As Integer, Optional PjPaths As String)
Dim MonOutlook As Object
Dim MonMessage As Object
Set MonOutlook = CreateObject("Outlook.Application")
Set MonMessage = MonOutlook.createitem(0)
Dim PJ() As String
PJ() = Split(PjPaths, ";")
With MonMessage
.Subject = Subject '"Je suis content"
.To = Destina '"marcel#machin.com;julien#chose.com"
.cc = CCdest '"chef#machin.com;directeur#chose.com"
.bcc = CCIdest '"un.copain#supermail.com;une-amie#hotmail.com"
.BoDy = BoDyTxt
If PjPaths <> "" And NbPJ <> 0 Then
For i = 0 To NbPJ - 1
'MsgBox PJ(I)
.Attachments.Add PJ(i) '"C:\Mes Documents\Zoulie Image.gif"
Next i
End If
.display
'.send '.Attachments.Add ActiveWorkbook.FullName
End With '?plusieurs?MonMessage.Attachments.Add "D:\Prof\Janvier\Base clients.mdb"
Set MonOutlook = Nothing
End Sub
After a new message is created you need to insert a new text before the default signature (not to overwrite it), for example:
.BoDy = BoDyTxt
The default signature will be erased in that case.
.Body = BoDyTxt & .Body
In that case the text will be inserted in the beginning of the message leaving the signature as is.
The Outlook object model provides three different ways for working with item bodies:
Body - a plain text.
HTMLBody - an HTML markup.
The Word Editor. Outlook uses Word as an email editor, so you can use it to format the email message. The WordEditor property of the Inspector class returns an instance of the Document class which represents the message body.
You can read more about all these ways in the Chapter 17: Working with Item Bodies in MSDN.
thanks Eugene Astafiev
i changed some of the code and i got it worked after all
the changed part is as following:
Sub EnvoiMail(Subject As String, Destina As String, Optional CCdest As String, Optional CCIdest As String, Optional BoDyTxt As String, Optional NbPJ As Integer, Optional PjPaths As String)
Dim MonOutlook As Object
Dim MonMessage As Object
Dim strbody As String 'i added this part <<>>>'
Set MonOutlook = CreateObject("Outlook.Application")
Set MonMessage = MonOutlook.CreateItem(0)
strbody = "Hello" ' i put my messages here as well which i change it in my main code to get values from cells <<<<>>>'
Dim PJ() As String
PJ() = Split(PjPaths, ";")
With MonMessage
.Display ' <<<<< the most important part of the code which solved 50% of the problem >>>>'
.Subject = Subject
.To = Destina
.CC = CCdest
.BCC = CCIdest
.HTMLBoDy = strbody & "<br>" & .HTMLBoDy ' <<<< the second import part of the code and solved the other 50% >>>>> '
If PjPaths <> "" And NbPJ <> 0 Then
For i = 0 To NbPJ - 1
'MsgBox PJ(I)
.Attachments.Add PJ(i)
Next i
End If
.Display
'.send
End With
Set MonOutlook = Nothing
End Sub
I have a button in Access that opens Outlook, creating an appointment.
Private Sub addAppointEstimate_Click()
Dim objOutlook As Object
Dim objOutLookApp As Object
Dim strSubject As String
Dim strBody As String
strSubject = Forms!frmMain.LastName 'more stuff to add
strBody = DLookup("EstimateText", "tblEstimateItems", "EstimateID = 78") '& Forms!frmMain!frmSubTransaction!frmSubEstimate.Form.EstimateID)
Set objOutlook = CreateObject("Outlook.Application")
Set objOutLookApp = objOutlook.CreateItem(1)
With objOutLookApp
.subject = strSubject
.RTFBody = StrConv(strBody, vbFromUnicode)
.Display
End With
End Sub
The problem is that I want to insert Rich text into the Body but it doesn't format correctly, as it shows all the HTML tags instead e.g:
<div><strong>example </strong><font color=red>text</font></div>
Is there a way I can send or convert the rich text to Outlook in a format it will recognise? (Maybe using the clipboard)
It seems many people have solution for Excel, but I am struggling to get them to work in Access:
HTML Text with tags to formatted text in an Excel cell
http://dailydoseofexcel.com/archives/2005/02/23/html-in-cells-ii/
To pass RTF formatted string to outlook email body is simple as following
Function RTF2Outlook(strRTF as String) as boolean
Dim myOlApp, myOlItem
Dim arrFiles() As String, arrDesc() As String, i As Long
Set myOlApp = CreateObject("Outlook.Application")
Set myOlItem = myOlApp.CreateItem(olMailItem)
With myOlItem
.BodyFormat = olFormatRichText
.Body = StrConv(strRTF, vbFromUnicode) 'Convert RTF string to byte array
End With
Set myOlApp = Nothing
Set myOlItem = Nothing
End Function
The secret is not to use ".RTFBody" but just ".Body" and pass to it byte array as in the code above. It took me awhile to figure it out.
Thanks to Microsoft we always will have something to figure out.
You can use a little extra overhead to create a message with the formatted HTMLBody content, then copy the content to an Appointment item.
Start by creating a message and an appointment and populating them as desired. Put the body text in the message, skip the body in the appointment for now.
Dim objOutlook As Object
Dim objMyMsgItem As Object
Dim objMyApptItem As Object
Dim strSubject As String
strSubject = "Some text" 'Forms!frmMain.LastName 'more stuff to add
Set objOutlook = CreateObject("Outlook.Application")
Set objMyMsgItem = objOutlook.CreateItem(0) 'Message Item
With objMyMsgItem
.HTMLBody = "<div><strong>example </strong><font color=red>text</font></div>"
'DLookup("EstimateText", "tblEstimateItems", "EstimateID = 78")
.Display
End With
Set objMyApptItem = objOutlook.CreateItem(1) 'Appointment Item
With objMyApptItem
.Subject = strSubject
.Display
End With
Then use the GetInspector property to interact with the body of each item via a Word editor, and copy the formatted text that way.
Dim MyMsgInspector As Object
Dim wdDoc_Msg As Object
Set MyMsgInspector = objMyMsgItem.GetInspector
Set wdDoc_Msg = MyMsgInspector.WordEditor
Dim MyApptInspector As Object
Dim wdDoc_Appt As Object
Set MyApptInspector = objMyApptItem.GetInspector
Set wdDoc_Appt = MyApptInspector.WordEditor
wdDoc_Appt.Range.FormattedText = wdDoc_Msg.Range.FormattedText
This code is tested and works in Access 2013.
You are setting the plain text Body property. Set the HTMLBody property to a properly formatted HTML string.
I came up with a solution. I have just copied and pasted the entire sub, but the answer is in there I promise. I have also highlighted the important bits.
I works on my home machine, but not on the clients. So I cant use it, but if you can improve on it let me know.
Private Sub addAppointmentEst_Click()
Dim objOutlook As Object
Dim objOutLookApp As Object
Dim strSubject As String
Dim strBody As String
On Error GoTo appointmentEstError
If Not IsNull(DLookup("EstimateID", "tblEstimate", "TransactionID = " & Me.TransactionID.Value)) Then
DoCmd.OpenForm "frmEditEstimate", , , , , acHidden '<------ OPEN FORMATTED TEXT IN A FORM
Forms!frmEditEstimate.SetFocus
Forms!frmEditEstimate!frmSubEstimateItems.Form.EstimateText.SetFocus
DoCmd.RunCommand acCmdCopy '<------ COPY FORMATTED TEXT
DoCmd.Close acForm, "frmEditEstimate", acSaveNo
End If
' If Not IsNull(Forms!frmMain.Title.Value) Then
' strSubject = strSubject & Forms!frmMain.Title.Value
' End If
If Not IsNull(Forms!frmMain.FirstName.Value) Then
strSubject = strSubject & Forms!frmMain.FirstName.Value
End If
If Not IsNull(Forms!frmMain.LastName.Value) Then
strSubject = strSubject & " " & Forms!frmMain.LastName.Value
End If
If Not IsNull(Forms!frmMain.Organisation.Value) Then
strSubject = strSubject & " (" & Forms!frmMain.Organisation.Value & ")"
End If
If Not IsNull(Forms!frmMain!frmSubTransaction.Form.Property.Value) Then
strSubject = strSubject & " - " & Forms!frmMain!frmSubTransaction.Form.Property.Value
End If
Set objOutlook = CreateObject("Outlook.Application")
Set objOutLookApp = objOutlook.CreateItem(1)
With objOutLookApp
.subject = strSubject
.Display
End With
If Not IsNull(DLookup("EstimateID", "tblEstimate", "TransactionID = " & Me.TransactionID.Value)) Then
Set objectOutlookBody = objOutlook.ActiveInspector.WordEditor
objOutLookApp.Body = vbCrLf & "Estimate ID: " & Forms!frmMain!frmSubTransaction!frmSubEstimate.Form.EstimateID.Value & _
vbCrLf & "Estimate Date: " & Forms!frmMain!frmSubTransaction!frmSubEstimate.Form.EstimateDate.Value
objectOutlookBody.Application.Selection.Paste '<----- PASTE TEXT INTO APPOINTMENT
Forms!frmMain.EmptyValue.Value = " " '<----- EMPTY CLIPBOARD
Forms!frmMain.EmptyValue.SetFocus
DoCmd.RunCommand acCmdCopy
End If
Exit Sub
appointmentEstError:
MsgBox _
Prompt:="Failed create an appointment in Outlook, with the estimate attached", _
Buttons:=vbOKOnly + vbExclamation, _
Title:="Error"
End Sub
As in previous answer, this line is the key, it copies text, hyperlinks, pictures etc. without modifying clipboard content:
wdDoc_Appt.Range.FormattedText = wdDoc_Msg.Range.FormattedText