Question

我正在尝试通过宏创建邮件，邮件草图的来源是excel内容，如下面的屏幕截图所示。

电子邮件的来源，如To，CC，Body等

source of the email like To, CC, Body, etc

创建邮件后，我无法打开它们;

以下是代码：

Option Explicit

Sub ESRMail()

    Dim OlApp As Outlook.Application
    Dim OLMail As Outlook.MailItem
    Dim OlInsp As Outlook.Inspector
    Dim WdDoc As Word.Document
    Dim SaveLoc As String
    Dim X As Integer
    Dim StrGreeting As String
    Dim CurrItem As Outlook.MailItem
    Dim N As Integer

    With Application
        .CutCopyMode = False
        .AskToUpdateLinks = False
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With

    Set OlApp = Outlook.Application
    Set OLMail = OlApp.CreateItem(olMailItem)

    ThisWorkbook.Sheets("Sheet1").Activate
    Range("a1").Select
    ActiveCell.Offset(1, 0).Activate

    X = Range("a1", Range("a2").End(xlDown)).Count


    For X = 2 To X
        With OLMail
            SaveLoc = "C:\Users\AmanPanday\Desktop\Tech\VBA\Project\ESR Mail\" _
                    & ActiveCell.Value & ".msg"
            .BodyFormat = olFormatHTML
            .Display
            .Body = ""
            ActiveCell.Offset(, 1).Activate
            .To = ActiveCell.Value
            ActiveCell.Offset(0, 1).Activate
            .CC = ActiveCell.Value
            ActiveCell.Offset(0, 1).Activate
            .Subject = ActiveCell.Value
            ActiveCell.Offset(0, 2).Activate

            ''THIS CODES WILL REMOVE ATTACHMENT IF THERE ARE ANY.
            Set CurrItem = ActiveInspector.CurrentItem

            N = CurrItem.Attachments.Count

            Do Until N = 0
                If N <> 0 Then CurrItem.Attachments(N).Delete
                N = CurrItem.Attachments.Count
            Loop

            .Attachments.Add ActiveCell.Value

            Set OlInsp = .GetInspector
            Set WdDoc = OlInsp.WordEditor

            WdDoc.Range.InsertBefore ActiveCell.Offset(0, -1).Value
            'WdDoc.Range(Len(StrGreeting), Len(StrGreeting)).Paste

            .SaveAs SaveLoc, 5
            .Close 1
        End With
        ActiveCell.Offset(1, -5).Activate
    Next X

    MsgBox "All E-Mails are Created"

    With Application
        .CutCopyMode = True
        .AskToUpdateLinks = True
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With

    'Set X = Nothing
    'Set WdDoc = Nothing
    'Set OlApp = Nothing
    'Set OLMail = Nothing
    'Set OlInsp = Nothing
    'Set SaveLoc = Nothing
    'Set StrGreeting = Nothing

End Sub