I already made this code, I want to send a image already exist inside the Excel (called Picture 1810) by e-mail. But I cant discovery how to do the .Body.
Anyone can help me?
Sub CreateMail()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngCC As Range
Dim rngSubject As Range
Dim rngBody As Shape
Dim rngAttach As Range
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With ActiveSheet
Set rngTo = .Range("f2")
Set rngCC = .Range("f3")
Set rngSubject = .Range("c2")
Set rngBody = .Shapes("Picture 1810")
End With
With objMail
.To = rngTo.Value
.CC = rngCC.Value
.Subject = rngSubject.Value
.Body = rnbbody
.Send
End With
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
Set rngAttach = Nothing
End Sub
By this you retain your standard email signature and paste the shape either floating over the body text or like a character in between:
With objMail
.To = rngTo.Value
.CC = rngCC.Value
.Subject = rngSubject.Value
.Display
Dim wdDoc As Word.Document
Set wdDoc = .GetInspector.WordEditor
If Not wdDoc Is Nothing Then
With wdDoc.Range
.Collapse wdCollapseStart
.InsertBefore "Hi there," & vbCrLf & "here's my shape:" & vbCrLf
.Collapse wdCollapseEnd
.InsertAfter vbCrLf & "Best wishes," & vbCrLf
.Collapse wdCollapseStart
ActiveSheet.Shapes("Picture 1810").Copy
'.Paste ' over the text
.PasteAndFormat wdChartPicture ' within text
End With
Set wdDoc = Nothing
End If
'.Send
End With
Related
I have the following code but it is not working. I am fairly new to VBA as well. The code works to populate the email template but as soon as I add the .Attachment.Add it does not work.
Sub CreateMail()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As Range
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With ActiveSheet
Set rngTo = .Range("E2")
Set rngSubject = .Range("E3")
Set rngBody = .Range("E4")
.Attachments.Add "Z:\PHS 340B\Letters of Non-Compliance\..Resources\W9 Form\VPNA W-9 01 09 2017"
End With
With objMail
.to = rngTo.Value
.Subject = rngSubject.Value
.Body = rngBody.Value
.Display 'Instead of .Display, you can use .Send to send the email _
or .Save to save a copy in the drafts folder
End With
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
End Sub
Try this:
Sub emailtest()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As Range
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With ActiveSheet
Set rngTo = .Range("E2")
Set rngSubject = .Range("E3")
Set rngBody = .Range("E4")
End With
With objMail
.To = rngTo.Value
.Subject = rngSubject.Value
.Body = rngBody.Value
.Attachments.Add "Z:\PHS 340B\Letters of Non-Compliance\..Resources\W9 Form\VPNA W-9 01 09 2017"
.Display 'Instead of .Display, you can use .Send to send the email _
or .Save to save a copy in the drafts folder
End With
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
End Sub
You need to use the .Attachments.Add when working within Outlook not Excel.
This simple script should illustrate the point of how to add attachments to an email, and then send the email.
Sub Mail_workbook_Outlook_1()
'Working in Excel 2000-2016
'This example send the last saved version of the Activeworkbook
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.to = "ron#debruin.nl"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hi there"
.Attachments.Add ActiveWorkbook.FullName
'You can add other files also 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
https://www.rondebruin.nl/win/s1/outlook/amail1.htm
I found the following script here:
Sub emailtest()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As Range
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With ActiveSheet
Set rngTo = .Range("E2")
Set rngSubject = .Range("E3")
Set rngBody = .Range("E4")
End With
With objMail
.To = rngTo.Value
.Subject = rngSubject.Value
.Body = rngBody.Value
.Attachments.Add "Z:\PHS 340B\Letters of Non-Compliance\..Resources\W9 Form\VPNA W-9 01 09 2017"
.Display 'Instead of .Display, you can use .Send to send the email _
or .Save to save a copy in the drafts folder
End With
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
End Sub
I changed Set rngTo = .Range("E2") to Set rngTo = .Range("G8:G38") , running the script it gives a 440 Error on :.to = rngTo.Value
What am I doing wrong?
What Tim said above. Try this.
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As Range
Dim emails as string
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With ActiveSheet
Set rngTo = .Range("G8:G38")
Set rngSubject = .Range("E3")
Set rngBody = .Range("E4")
End With
For Each E In rngTo
emails = emails & E & ";"
Next
With objMail
.To = emails
.Subject = rngSubject.Value
.Body = rngBody.Value
'.Attachments.Add "Z:\PHS 340B\Letters of Non-Compliance\..Resources\W9 Form\VPNA W-9 01 09 2017"
.Display 'Instead of .Display, you can use .Send to send the email _
or .Save to save a copy in the drafts folder
End With
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
I copy a range and paste into Outlook email with signature.
I want to reflect the range in center of body of email.
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Set rng = Nothing
Set rng = ThisWorkbook.Sheets("Output").Range("D7:E18")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = ""
.BCC = ""
.Subject = "Subject"
.Display
Dim wdDoc As Object
Dim wdRange As Object
Set wdDoc = OutMail.GetInspector.WordEditor
Set wdRange = wdDoc.Range(0, 0)
wdRange.InsertAfter vbCrLf & vbCrLf
rng.Copy
wdRange.Paste
Set OutMail = Nothing
Set OutApp = Nothing
End With
What the code does is, it centers not only the text but also the table (Excel Range) pasted in the outlook body.
Option Explicit
Const wdAlignRowCenter As Integer = 1
Const wdAlignParagraphCenter As Integer = 1
Sub Sample()
Dim OutApp As Object, OutMail As Object
Dim wdDoc As Object, wdRange As Object
Dim rng As Range
Dim i As Long
Set rng = ThisWorkbook.Sheets("Output").Range("D7:E18")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = ""
.BCC = ""
.Subject = "Subject"
.Display
Set wdDoc = .GetInspector.WordEditor
Set wdRange = wdDoc.Range(0, 0)
wdRange.InsertAfter vbCrLf & vbCrLf
rng.Copy
wdRange.Paste
DoEvents
Set wdRange = wdDoc.Range(0, wdDoc.Characters.Count)
wdRange.ParagraphFormat.Alignment = wdAlignParagraphCenter
For i = 1 To wdRange.Tables.Count
wdRange.Tables(i).Rows.Alignment = wdAlignRowCenter
Next i
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Note:
BTW Set wdDoc = .GetInspector.WordEditor will give you error if the default editor is not MS Word...
If there are images in your body then you may have to handle them as well seperately
This is the first time I am trying from Excel to send email using VBA code.
Here is my structure of my Excel. Sometimes the email list will have 1 - 20 or only 1 also
A (col) B C D E F G
Sl.No First Name To Email CC Email Subj File to Send Message
Code:
Option Explicit
Sub SendMail()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As Range
Dim rngAttach As Range
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With ActiveSheet
Set rngTo = .Range("C2")
Set rngSubject = .Range("E2")
Set rngBody = .Range("G2")
Set rngAttach = .Range("F2")
End With
With objMail
.To = rngTo.Value
.Subject = rngSubject.Value
.Body = rngBody.Value
.Attachments.Add rngAttach.Value
.Display
End With
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
Set rngAttach = Nothing
End Sub
Here is my code this was working perfectly fine but for single emails to send, but not for multiple email.
I am struggling here to find how to send for multiple email with attachment using the tested code.
Maybe Try this:
Option Explicit
Sub SendMail()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As Range
Dim rngAttach As Range
Dim i As Integer
Set objOutlook = CreateObject("Outlook.Application")
For i = 2 To 21 ' Loop from 2 to 21
With ActiveSheet
Set rngTo = .Range("C" & i)
Set rngSubject = .Range("E" & i)
Set rngBody = .Range("G" & i)
Set rngAttach = .Range("F" & i)
End With
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = rngTo.Value
.Subject = rngSubject.Value
.HTMLBody = "<B><U>" & rngBody.Value & ":</B></U>"
.Attachments.Add rngAttach.Value
.Display
End With
Set objMail = Nothing
Next
Set objOutlook = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
Set rngAttach = Nothing
End Sub
You can loop through the Range to generate 20 emails.
Update
Added .HTMLBody instead of .Body to make text Bold And Underlined
You can use more HTML commands to make certain portions of the Text Bold and More.
Try it this way.
Make a list in Sheets("Sheet1") with :
In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)
The Macro will loop through each row in "Sheet1" and if there is a E-mail address in column B
and file name(s) in column C:Z it will create a mail with this information and send it.
Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Send 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
https://www.rondebruin.nl/win/s1/outlook/amail6.htm
You need a loop for that. The below code will start with the second row and continue until it finds an empty row.
Option Explicit
Sub SendMail()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As Range
Dim rngAttach As Range
Set objOutlook = CreateObject("Outlook.Application")
Dim r As Long: For r = 2 To ActiveSheet.Range("C2").End(xlDown).Row
With ActiveSheet
Set rngTo = .Range("C" & r)
Set rngSubject = .Range("E" & r)
Set rngBody = .Range("G" & r)
Set rngAttach = .Range("F" & r)
End With
Set objMail = objOutlook.CreateItem(0)
With objMail
.to = rngTo.Value
.Subject = rngSubject.Value
.Body = rngBody.Value
.Attachments.Add rngAttach.Value
.Display
.Send ' If you want to send it without clicking
End With
Next
End Sub
Also note: These Set x = Nothing lines are superfluous, delete them because they just make the code less readable for humans. Regarding this issue you can also refer to this SO question: Is there a need to set Objects to Nothing inside VBA Functions
Update
Sorry this line has to be inside the loop, I updated the code:
Set objMail = objOutlook.CreateItem(0)
This question already has an answer here:
Excel 2010 Paste Range and Picture into Outlook
(1 answer)
Closed 7 years ago.
Pretty simple and straight forward. I am looking to copy a range in a worksheet, open a new email to outlook and paste the range as an image. The following code is what I currently have. Despite my efforts, I have been unable to paste as a photo.
Sub CreateMail()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngBody As Range
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With Sheets("Hourly Labor Model")
Set rngBody = .Range(.Range("A6"), .Range("AA99").End(xlDown))
End With
rngBody.Copy
With objMail
.To = "user#useremail.com"
.Subject = "Hourly Dashboard- " & Sheets("Graphs").Range("AA1") & " on " & Format(Now(), "mm/dd/yyyy") & " # " & Format(Time(), "hh:mm:ss")
.display
End With
SendKeys "^({v})", True
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Please and thank you in advance.
Based on this thread, I think the below would work:
Sub CreateMail()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngBody As Range
Dim outMail As Outlook.MailItem 'new
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
Set outMail = objOutlook.CreateItem(olMailItem)
With Sheets("Hourly Labor Model")
Set rngBody = .Range(.Range("A6"), .Range("AA99").End(xlDown))
End With
rngBody.Copy
With objMail
.To = "user#useremail.com"
.Subject = "Hourly Dashboard- " & Sheets("Graphs").Range("AA1") & " on " & Format(Now(), "mm/dd/yyyy") & " # " & Format(Time(), "hh:mm:ss")
.Display
'outMail.Display
Dim wordDoc As Word.Document
Set wordDoc = .GetInspector.WordEditor ' or use outMail instead of with()
wordDoc.Range.PasteandFormat wdChartPicture
End With
SendKeys "^({v})", True
On Error GoTo 0
Set outMail = Nothing
Set OutApp = Nothing
End Sub