How to create Outlook email and resize all images - excel

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

Related

VBA Help Attach PDF to Email [duplicate]

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

How to add an attachment to an email and send to multiple adresses from excel

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

Attaching an Outlook email item and an excel workbook into my email

I had already code for attaching the excel workbook. I just need code for attaching an email item into the email.. please assist

Try below code (change the sheet name and range as per your requirements)
Sub Mail()
Dim r As Range
Set r = Worksheets("to_Mail").Range("A1:AD69")
r.Copy
Dim OutApp As Object
Dim outMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set outMail = OutApp.CreateItem(0)
On Error Resume Next
With outMail
.HTMLBody = activeMailMessage.HTMLBody
.To = ""
.CC = ""
.BCC = ""
.Subject = "Report Complete"
Dim wordDoc As Word.document
Set wordDoc = outMail.GetInspector.WordEditor
wordDoc.Range.PasteAndFormat wdChartPicture
outMail.send
End With
End Sub

Paste Excel range in center of body of Outlook email

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

Auto Email Send from outlook using excel information from the cell

I need to send auto email from Excel using Excel Outlook, I was trying coding but unable to do it. I have attached sheet for your reference.
Sub SendEmail()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = "ABC#gmail.com"
.CC = ""
.BCC = ""
.Subject = "Report"
.Body = "Hello!"
.Attachments.Add ActiveWorkbook.FullName
.Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
Application.OnTime TimeValue("17:00:00"), "SendEmail"
End Sub

You will need to reference and login into the Outlook.Namespace before creating the email.
Try adding this to to your code:
Set OutApp = CreateObject("Outlook.Application")
'** -> add this block here
Dim OutNS as Object
Set OutNS = OutApp.GetNamespace("MAPI")
OutNS.Logon
'**
Set OutMail = OutApp.CreateItem(0)

Resources