The idea is to attach an Excel file using Attachment.Add.
A macro reads the files within a folder and displays it in a column. I would like to attach those files via Excel.
I get an error on
.Attachments.Add Filelist & "\" & "Attch"
Sub Sendemailusingword()
Dim Olapp As Outlook.Application
Dim Olemail As Outlook.MailItem
Dim olmail As Object
Dim olinsp As Outlook.Inspector
Dim wddoc As Word.Document
Dim count As Integer
Dim x As Integer
Dim Filelist As String
Dim Attch As String
x = 1
row_number = 7
count = Sheet1.Range("K1")
For x = 1 To count
row_number = row_number + 1
Attch = Sheet1.Range("D" & row_number).Value
Filelist = "K:\3SHARE\2016 Plan\Statment Email Send"
Set Olapp = New Outlook.Application
Set Olemail = Olapp.CreateItem(olMailItem)
With Olemail
.Display
.To = Sheet1.Range("G" & row_number)
.Subject = Sheet1.Range("D6") & Sheet1.Range("F" & row_number)
.SentOnBehalfOfName = "ComdataCommissions#comdata.com"
.BodyFormat = olFormatHTML
.CC = Sheet1.Range("H" & row_number) & ";" & Sheet1.Range("I" & row_number)
Set olinsp = .GetInspector
Set wddoc = olinsp.WordEditor
Sheet1.Activate
Range("B2").CurrentRegion.Copy
wddoc.Range.Paste
.Attachments.Add Filelist & "\" & "Attch"
End With
Next x
End Sub
.Attachments.Add Filelist & "\" & Attch
Assuming the variable Attch contains the filename of the file to be attached.
EDIT: noticed you tagged with excel-vba-mac, in which case I don't think backslash will work as a path separator. : or maybe / should work, or use Application.PathSeparator
Related
I would like the message to be sent when there is a value in column H, for example "y" -> enter image description here
Sub sendCustEmails()
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
Dim objEmail As Object
Set objEmail = objOutlook.CreateItem(oMailItem)
Dim strMailBody As String
intRow = 2
strISO = ThisWorkbook.Sheets("MS_Data").Range("B" & intRow).Text
While (strISO <> "")
Set objEmail = objOutlook.CreateItem(oMailItem)
StrMailSubject = ThisWorkbook.Sheets("Mail_Details").Range("A2").Text
strMailBody = "<BODY style='font-size:11pt;font-family:Calibri(Body)'>" & ThisWorkbook.Sheets("Mail_Details").Range("B2").Text & "</BODY>"
strMailBody = Replace(strMailBody, Chr(10), "<br>")
strFolder = "C:\Users\CIOTTIC\OneDrive - IAEA\Desktop\AL TEST"
strISO = ThisWorkbook.Sheets("MS_Data").Range("B" & intRow).Text
strSalutation = ThisWorkbook.Sheets("MS_Data").Range("C" & intRow).Text
strEmail = ThisWorkbook.Sheets("MS_Data").Range("D" & intRow).Text
strCC = ThisWorkbook.Sheets("MS_Data").Range("E" & intRow).Text
strFile = ThisWorkbook.Sheets("MS_Data").Range("F" & intRow).Text
strFile2 = ThisWorkbook.Sheets("MS_Data").Range("G" & intRow).Text
StrMailSubject = Replace(StrMailSubject, "<ISO>", strISO)
strMailBody = Replace(strMailBody, "<Salutation>", strSalutation)
With objEmail
.To = CStr(strEmail)
.CC = CStr(strCC)
.Subject = StrMailSubject
.BodyFormat = olFormatHTML
.Display
.Attachments.Add strFolder & "\" & strFile
.Attachments.Add strFolder & "\" & strFile2
.HTMLBody = strMailBody & .HTMLBody
.Send
End With
intRow = intRow + 1
strISO = ThisWorkbook.Sheets("MS_Data").Range("B" & intRow).Text
Wend
MsgBox "Done"
End Sub
Thank you very much!
How about :
Sub Test()
If Range("A1").Value <> "" Then
GoTo SendEmail
Else: Exit Sub
End If
Send Email:
'Enter the rest of your code here.
End Sub
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Private Sub sendCustEmails_WithCondition()
' Late binding
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
Dim objEmail As Object
Dim strISO As String
Dim strMailSubject As String
Dim longRow As Long
longRow = 2
strISO = ThisWorkbook.Sheets("MS_Data").Range("B" & longRow).Text
Debug.Print "strISO: " & strISO
While (strISO <> "")
If ThisWorkbook.Sheets("MS_Data").Range("H" & longRow).Text = "Y" Then
'Typo - use Option Explicit
'Set objEmail = objOutlook.CreateItem(oMailItem)
' For early binding oMailItem should be olMailItem
' This is "accepted" in late binding without Option Explicit.
' Appears the variable "oMailItem" which is empty is treated as a zero.
Set objEmail = objOutlook.CreateItem(0)
'strMailSubject = ThisWorkbook.Sheets("Mail_Details").Range("A2").Text
strMailSubject = "Subject is <ISO>"
strISO = ThisWorkbook.Sheets("MS_Data").Range("B" & longRow).Text
strMailSubject = Replace(strMailSubject, "<ISO>", strISO)
Debug.Print " strMailSubject: " & strMailSubject
With objEmail
.Subject = strMailSubject
.Display
End With
Else
' Not Y
Debug.Print " No mail."
End If
longRow = longRow + 1
strISO = ThisWorkbook.Sheets("MS_Data").Range("B" & longRow).Text
Debug.Print "strISO: " & strISO
Wend
MsgBox "Done"
End Sub
Sub Display()
Dim myMail As Outlook.MailItem
Dim myReply As Outlook.MailItem
Dim numItems As Integer
Dim mySelected As Selection
Dim i As Integer
Dim myText As String
Dim signature As String
signature = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(signature, vbDirectory) <> vbNullString Then
signature = signature & Dir$(signature & "*.htm")
Else:
signature = ""
End If
signature = CreateObject("Scripting.FileSystemObject").GetFile(signature).OpenAsTextStream(1, -2).ReadAll
Set mySelected = Outlook.ActiveExplorer.Selection
numItems = mySelected.Count
For i = 1 To numItems
Set myMail = mySelected(1)
Set myReply = myMail.Reply
myText = myMail.Body
myReply.Subject = "RO Finalized WF: Annual Review. Entity"
myText = "Hi All," & vbCrLf & vbCrLf & "Worflow ID:" & vbCrLf & vbCrLf & "infoinfoinfoinfo" & vbCrLf & vbCrLf & "Thanks," & vbCrLf & "Josh" & signature
myReply.HTMLBody = myText & vbCrLf & vbCrLf & myMail.HTMLBody
Myreply.display
Set myMail = Nothing
Set myReply = Nothing
Next
Set mySelected = Nothing
End Sub
The code above displays a reply to the email you currently have open in Outlook including who sent it (placed in To:) with the whole body of the email you currently have open in Outlook.
This is what I want it to do except instead of replying to the open email, I want it to reply to the email specifically by it's subject. Also I want it to include exactly what all replies include in Outlook (the line separating each email, with the From:, Sent,: To:, CC:, Subject: of the previous email showing). Also vbCrLf is not doing it's purpose after MyText.
I would also like it to place the CC: from the previous email in the CC of the email I am creating.
I am not an expert in VBA and have tried as much as I could think of.
Thank you for the help in advance :)
I have found another option and the code is displayed below.
This will populate a reply email, with everything I need except my customized body.
Sub Display()
Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim olMail As Variant
Dim i As Integer
Dim IsExecuted As Boolean
signature = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(signature, vbDirectory) <> vbNullString Then
signature = signature & Dir$(signature & "*.htm")
Else:
signature = ""
End If
signature = CreateObject("Scripting.FileSystemObject").GetFile(signature).OpenAsTextStream(1, -2).ReadAll
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
IsExecuted = False
For Each olMail In Fldr.Items
If InStr(olMail.Subject, "checklist") <> 0 Then
If Not IsExecuted Then
With olMail.ReplyAll
.HTMLBody = "Dear All," & "<br>" & signature
End With
IsExecuted = True
olmail.ReplyAll.Display
End If
End If
Next olMail
End Sub
Solution
Sub Display()
Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim olMail As Variant
Dim i As Integer
Dim IsExecuted As Boolean
signature = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(signature, vbDirectory) <> vbNullString Then
signature = signature & Dir$(signature & "*.htm")
Else:
signature = ""
End If
signature = CreateObject("Scripting.FileSystemObject").GetFile(signature).OpenAsTextStream(1, -2).ReadAll
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
IsExecuted = False
For Each olMail In Fldr.Items
If InStr(olMail.Subject, "Subject") <> 0 Then
If Not IsExecuted Then
With olMail.ReplyAll
.HTMLBody = "<p>" & "Dear All," & "</p><br>" & signature & .HTMLBody
.Display
End With
IsExecuted = True
End If
End If
Next olMail
End Sub
Hi I am using below code to add chart and send email to multiple recipients. It works fine. In my sent item i can see a perfect email created and sent. But all the recipients are not able to see the charts. All they see is two red X
Sub Send_Email_Updated()
Dim olApp As Object
Dim NewMail As Object
Dim NewMail1 As Object
Dim ChartName As String
Dim ChartName1 As String
Dim SendingRng As Range
Dim htmlString As String
Dim OMail As Outlook.MailItem
Set wb = ActiveWorkbook
Set S1 = wb.Worksheets("Incident Tickets")
Set S2 = wb.Worksheets("Assets and Representatives")
Set S3 = wb.Worksheets("Email")
'Set SendingRng = Worksheets("Email").Table("A30:C43")
Set SendingRng = Worksheets("Email").Range("A30:C43")
Set olApp = CreateObject("Outlook.Application")
Set OMail = olApp.CreateItem(olMailItem)
' Group 1
If S3.Cells(7, 2) <> 0 Or S3.Cells(8, 2) <> 0 Or S3.Cells(9, 2) <> 0 Then
OMail.Display
'fill in the file path/name of the gif file app graph
ChartName = Environ$("Temp") & "\Chart 1.gif"
ActiveWorkbook.Worksheets("Email").ChartObjects("Chart 1").Chart.Export _
Filename:=ChartName, FilterName:="GIF"
'fill in the file path/name of the gif file trend graph
ChartName1 = Environ$("Temp") & "\Chart 31.gif"
ActiveWorkbook.Worksheets("Email").ChartObjects("Chart 31").Chart.Export _
Filename:=ChartName1, FilterName:="GIF"
Set NewMail = olApp.CreateItem(0)
With NewMail
.Subject = "Action Required on Incidents and Problem Candidates for GC060.1 - Group 1"
.To = "animesh.das#xyz.com"
.HTMLBody =
"<img src=" & "'" & ChartName1 & "'>" & "<br/>" & "<br/>" & "_
"<img src=" & "'" & ChartName & "'>" & "<br/>" & "<br/>" & _
.Send
End With
ChartName = vbNullString
ChartName1 = vbNullString
End If
End Sub
I'm tying to add range of cells as a picture from the active workbook along with some text.
But for some reason it skipping the text and only pasting the image in the email body.
How do I fix this?
Option Explicit
Public Sub POSTRUN()
Dim olApp As Outlook.Application
Set olApp = New Outlook.Application
Dim Olobj As Outlook.Application
Set Olobj = CreateObject("Outlook.Application")
Dim olNs As Outlook.Namespace
Set olNs = olApp.GetNamespace("MAPI")
Dim Inbox As Outlook.MAPIFolder
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Dim subject As String
subject = ThisWorkbook.Sheets("SendMail").Range("I5").Text
Debug.Print subject
Dim i As Long
Dim Filter As String
Filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:datereceived" & _
Chr(34) & " >= '01/01/1900' And " & _
Chr(34) & "urn:schemas:httpmail:datereceived" & _
Chr(34) & " < '12/31/2100' And " & _
Chr(34) & "urn:schemas:httpmail:subject" & _
Chr(34) & "Like '%" & subject & "%'"
Dim Items As Outlook.Items
Set Items = Inbox.Items.Restrict(Filter)
Items.Sort "[ReceivedTime]", False
For i = Items.Count To 1 Step -1
DoEvents
If TypeOf Items(i) Is MailItem Then
Dim Item As Object
Set Item = Items(i)
Debug.Print Item.subject ' Print on Immediate Window
Debug.Print Item.ReceivedTime ' Print on Immediate Window
Dim r As Range
Set r = ThisWorkbook.Sheets("post").Range("A1:M30")
r.Copy
Dim outMail As Outlook.MailItem
Set outMail = Olobj.CreateItem(olMailItem)
Dim body
Dim ReplyAll As Outlook.MailItem
Set ReplyAll = Item.ReplyAll
Dim wordDoc As Word.Document
Set wordDoc = ReplyAll.GetInspector.WordEditor
With ReplyAll
.HTMLBody = "<font size=""3"" face=""Calibri"">" & _
"Hi <br><br>" & _
"The " & Left(ActiveWorkbook.Name, _
InStr(ActiveWorkbook.Name, ".") - 1) & _
"</B> has been posted.<br>" & _
.HTMLBody
wordDoc.Range.PasteAndFormat wdChartPicture
.Display
Exit For
End With
End If
Next
End Sub
Its not skipping, you are simply overriding the HTMLBody with the image your pasting, so what you need to do is work with Paragraphs Object (Word)
Example
With ReplyAll
.HTMLBody = "<font size=""3"" face=""Calibri"">" & _
"Hi <br><br>" & _
"The " & Left(ActiveWorkbook.Name, _
InStr(ActiveWorkbook.Name, ".") - 1) & _
"</B> has been posted.<br>" & .HTMLBody
.Display
With wordDoc.Paragraphs(2)
.Range.InsertParagraphAfter
.Range.PasteAndFormat Type:=wdChartPicture
.Range.ParagraphFormat.LineSpacingRule = wdLineSpaceDouble
End With
Exit For
End With
Also remove following code
Dim Olobj As Outlook.Application
Set Olobj = CreateObject("Outlook.Application")
Dim outMail As Outlook.MailItem
Set outMail = Olobj.CreateItem(olMailItem)
Dim body
You already have it
Dim olApp As Outlook.Application
Set olApp = New Outlook.Application
Dim Item As Object
Set Item = Items(i)
I would like to modify this script to include an attachment in the email that it creates. Cell F5 on worksheet "Instructions" contains the file path. I've tried to modify it using information from several different sources.
Here is a working version, pre-attachment attempts:
Sub CreateMails()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As String
Dim rngAttach As Range
Dim SigString As String
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With Worksheets("Data validation")
Set rngTo = .Range("J63")
Set rngSubject = .Range("J61")
strbody = "One time vendor number request." & vbNewLine & vbNewLine & _
"Thank you," & vbNewLine & vbNewLine & _
"__________________________________" & vbNewLine & _
.Range("J67") & vbNewLine & vbNewLine & _
"My Company" & vbNewLine & _
"123 Address street" & vbNewLine & _
"City, State, Zip, USA" & vbNewLine & _
"Telephone:"
End With
With objMail
.To = rngTo.Value
.Subject = rngSubject.Value
.Body = strbody
.Save
End With
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set strbody = Nothing
Set rngAttach = Nothing
End Sub
All you should need is:
With objMail
.To = rngTo.Value
.Subject = rngSubject.Value
.Body = strbody
.attachments.Add Range("F5").Value 'add the attachment
.Save
End With
Using your code, this worked for me.
Hi I can share the below template code which i use for creating and attaching a sheet from my workbook as a PDF _ i've changed some of the "text" values but the rest is the same.
You could work with this to include the attachment, and send as xlsx if required.
Sub SendWorkSheetToPDF()
Dim Wb As Workbook
Dim FileName As String
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim SH As Worksheet
Dim cell As Range
Dim strto As String
Dim Strcc As String
Application.ScreenUpdating = False
'To'
For Each cell In ThisWorkbook.Sheets("Mail_addresses").Range("A2:A15")
If cell.Value Like "?*#?*.?*" Then
strto = strto & cell.Value & ";"
End If
Next cell
If Len(strto) > 0 Then strto = Left(strto, Len(strto) - 1)
On Error Resume Next
'CC'
For Each cell In ThisWorkbook.Sheets("Mail_addresses").Range("B2:B15")
If cell.Value Like "?*#?*.?*" Then
Strcc = Strcc & cell.Value & ";"
End If
Next cell
If Len(Strcc) > 0 Then Strcc = Left(Strcc, Len(Strcc) - 1)
On Error Resume Next
Set Wb = Application.ActiveWorkbook
FileName = "afilename"
xIndex = VBA.InStrRev(FileName, ".")
If xIndex > 1 Then FileName = VBA.Left(FileName, xIndex - 1)
FileName = FileName & ".pdf"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=FileName
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
With OutlookMail
.To = strto
.CC = Strcc
.BCC = ""
.Subject = "subject text"
.Body = "All," & vbNewLine & vbNewLine & _
"Please see attached daily " & vbNewLine & vbNewLine & _
"Kind Regards" & vbNewLine & _
" "
.Attachments.Add FileName
.Send
End With
Kill FileName
Set OutlookMail = Nothing
Set OutlookApp = Nothing
MsgBox "Email Sent"
End Sub