使用Excel MailEnvelope在Outlook邮件中自动调整

Question

我正在尝试使用Mail MailEnvelope发送邮件，但是在发送邮件后，内容被包装，如下图所示。

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 protected]"
                .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

如何克服这个包装问题？

我尝试附加示例宏文件，但在此处找不到附加文件的选项。

Answer 1

尝试以下类似操作，根据需要进行修改

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 protected]"
        .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

确保参考Microsoft Word xx.x对象库

https://stackoverflow.com/a/42662697/4539709