Autofit in Outlook mail using Excel MailEnvelope - excel

Question

I'm trying to send mail using Mail MailEnvelope but the content is wrapped after sending the mail like below image.
Sub Sample_MailEnvelope()
Application.ScreenUpdating = False
Sheets("Mail").Visible = True
Dim foliorange As Range
Set foliorange = Sheets("Countsheet").Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
For Each mycell In foliorange
Worksheets("Mail").Unprotect (".")
Sheets("Mail").Range("A7:B7") = mycell.Offset(0, 2).Value
Sheets("Mail").Range("C7:D7") = mycell.Offset(0, 3).Value
Sheets("Mail").Range("E7:F7") = mycell.Offset(0, 4).Value
Dim Sendrng As Range
On Error GoTo StopMacro
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Sheets("Mail").Activate
Range("A1").Select
Set Sendrng = Selection
With Sendrng
ActiveWorkbook.EnvelopeVisible = True
With .Parent.MailEnvelope
''.Introduction = "Hi," & vbNewLine & vbNewLine & "Kindly note that we have received the following transactions from you today." & vbNewLine & vbNewLine & vbNewLine & vbNewLine & vbNewLine
.Introduction = ""
With .Item
.To = mycell.Offset(0, 6).Value '"email#email.com"
.CC = mycell.Offset(0, 7).Value
.BCC = ""
.Subject = "OCBC - IUTA CONFIRMATION"
.Display
.send
End With
End With
End With
StopMacro:
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
ActiveWorkbook.EnvelopeVisible = fasle
Next mycell
Worksheets("Mail").Protect "."
Sheets("Mail").Visible = False
Application.ScreenUpdating = True
End Sub
How to overcome this wrapping problem?
I tried to attach my sample macro file but I didn't find any option to attach files here.

Answer 1

Try something like below, modify as needed
Option Explicit
Public Sub Exampple()
Dim olApp As Object
Dim Email As Object
Dim Sht As Excel.Worksheet
Dim wdDoc As Word.Document
Set Sht = ActiveWorkbook.Sheets("Mail")
Dim rng As Range
Set rng = Sht.Range("A7:E7")
rng.Copy 'Picture Appearance:=xlScreen, Format:=xlPicture
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set olApp = CreateObject("Outlook.Application")
Set Email = olApp.CreateItem(0)
Set wdDoc = Email.GetInspector.WordEditor
With Email
.To = "email#email.com"
.Subject = "OCBC - IUTA CONFIRMATION"
.Attachments.Add ""
.Display
wdDoc.Paragraphs(1).Range.PasteAndFormat Type:=wdChartPicture
wdDoc.Paragraphs(1).SpaceAfter = 30
' if need setup inlineshapes hight & width
With wdDoc.InlineShapes(1)
.ScaleHeight = 113
.ScaleWidth = 114
End With
' .Display
.Send 'or use .Display
End With
Set wdDoc = Nothing
Set Email = Nothing
Set olApp = Nothing
End Sub
Make sure to Reference to Microsoft Word xx.x Object Library
https://stackoverflow.com/a/42662697/4539709