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
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
The Excel macro below works great, except that images in the Excel range that gets pasted into the body gets resized (most of them to 55%).
I can't figure out what is wrong.
If I manually copy the exact same range and paste it into an email, the image stays intact.
Sub mailpaste()
Dim OutApp As Object
Dim OutMail As Object
Dim olInsp As Object
Dim xlSheet As Worksheet
Dim wdDoc As Object
Dim oRng As Object
Dim rngTo As Range
Dim rngSubject As Range
Application.Range("Report").copy
On Error Resume Next
Set OutApp = GetObject(, "Outlook.Application")
If Err <> 0 Then Set OutApp = CreateObject("Outlook.Application")
On Error GoTo 0
With ActiveSheet
Set rngTo = .Range("AA12")
Set rngSubject = .Range("AA15")
End With
Set OutMail = OutApp.CreateItem(0)
With OutMail
.BodyFormat = 2
.To = rngTo.Value
.CC = ""
.BCC = ""
.Subject = rngSubject.Value
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
oRng.collapse 1
oRng.Paste
.Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
End Sub
You are already using Word object so work with InlineShapes property height/Width of an inline shape
Example
Set OutMail = OutApp.CreateItem(0)
Set wdDoc = OutMail.GetInspector.WordEditor
With OutMail
.BodyFormat = 2
.To = rngTo.Value
.CC = ""
.BCC = ""
.Subject = rngSubject.Value
.Display
wdDoc.Range.PasteAndFormat Type:=wdChartPicture
With wdDoc
.InlineShapes(1).Height = 130
.InlineShapes(1).Width = 130
End With
End With
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
Tried all other codes on similar pages but failed to work.
This is my current version. Works only if I currently have a new email window open and oddly, my code will paste the .body and cell range details into 2 separate new email windows.
I just want the code to open a new email window with contents .body and cell range details (contains chart). Anybody have any ideas where my code went wrong?
Sub pasting01()
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.TO = "xyz#anc.com"
.CC = "abc#xyz.com"
.Subject = "Test"
.Body = "Dear Mr Lee" & vbNewLine
ActiveSheet.Range("A1:J30").Copy
Set vInspector = OutMail.GetInspector
Set wEditor = vInspector.WordEditor
wEditor.Application.Selection.Start = Len(.Body)
wEditor.Application.Selection.End = wEditor.Application.Selection.Start
wEditor.Application.Selection.Paste
.display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
You have some errors on your code, try using Option Explicit top of your module
Option Explicit
Public Sub pasting01()
Dim Sht As Excel.Worksheet
Set Sht = ThisWorkbook.ActiveSheet
Dim rng As Range
Set rng = Sht.Range("A1:J30")
rng.Copy
Dim OutApp As Object
Set OutApp = CreateObject("Outlook.Application")
Dim OutMail As Object
Set OutMail = OutApp.CreateItem(0)
Dim vInspector As Object
Set vInspector = OutMail.GetInspector
Dim wEditor As Object
Set wEditor = vInspector.WordEditor
With OutMail
.TO = "xyz#anc.com"
.CC = "abc#xyz.com"
.Subject = "Test"
.display
wEditor.Paragraphs(1).Range.Text = "Dear Mr Lee" & vbCr
wEditor.Paragraphs(2).Range.Paste
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Can you mess about with the following to suit your purpose?
Option Explicit
Sub pasting01()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Dim myChart As Chart
Set myChart = ThisWorkbook.Worksheets("Sheet1").ChartObjects("Chart 1").Chart
Dim myPicture As String
Dim fileName As String
Dim myPath As String
myPicture = "Chart1.png"
myPath = "C:\Users\User\Desktop\"
fileName = myPath & myPicture
myChart.Export fileName
With OutMail
.TO = "xyz#anc.com"
.CC = "abc#xyz.com"
.Subject = "Test"
.Body = "Dear Mr Lee" & vbNewLine
.Attachments.Add fileName
.HTMLBody = "<html><p>First Line... </p>" & _
"<img src=cid:" & Replace(myPicture, " ", "%20") & " height=2*240 width=2*180>" & _
"<p>Salutation</p>" & _
"<p>" & "More text" & "</p></html>"
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Kill fileName
End Sub
Result: