使用 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@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

如何克服這個包裝問題？

我試圖附加我的示例宏文件，但我沒有在此處找到任何附加文件的選項。

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@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

確保參考 Microsoft Word xx.x Object 庫

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