将 Excel 工作表中嵌入的 Word Doc 作为电子邮件正文发送

Question

我当前的 vba 代码在电子邮件正文中发送了一封包含此代码内容的电子邮件，我想对其进行更改，以便它发送我在名为 (Email) 的隐藏表单中拥有的嵌入 Word 文档，其中包含一些图像和文本以及从该宏中填写的用户表单中填写的文本。

这是我目前用于电子邮件的部分代码

strMsg = "<p>Hello Good Day</p></br>" & _        "<p>¡Welcome!</p></br>" & _
        "<p><strong>Attached you will find:</strong></p></br>" & _
        "<ul><li>A welcome presentation.</li>" & _
        "<li>Your welcome letter</li>" & _
        "<li>Directions to you work location <SITE></li>" & _
        "<li>First day Guide and Agenda. (Please bring all of this with you)</li>"


strMsg = strMsg & "<li>Bring Copies of your documents.</li></ul>"


strMsg = strMsg & "<p>Your hire date is <strong><u><HIREDATE></u></strong>. Please be on time " & _
        "at the work location <SITE> (<ADDRESS>) at <strong><HIRETIME>, in <ROOM>.</strong></p></br>" & _
        "<p>Be reminded if you are late your hires date maybe pushed back</p></br>" & _
        "<p><strong>Notes</strong>:</p>" & _
        "<ul><li>Dont forget your picture ID</li>" & _
        "<li>If You have any questions please dial Ext <u>5280</u>." & _
        " 24 hours a day 7 days a week</li></ul></br>" & _
        "<p>Please let me know if you have any questions.</p></br>" & _
        "<p>Regards.</p>" & _
        "<p>" & Application.UserName & "</p>" & _
        "<p><a title='MYICON' target='_blank' rel='noopener'><img src='https://www.underconsideration.com/brandnew/archives/MYICON_logo_detail.png' width='157' height='85' /></a></p>"


strMsg = Replace(strMsg, "<SITE>", strSite)
strMsg = Replace(strMsg, "<HIREDATE>", strHireDate)
strMsg = Replace(strMsg, "<ADDRESS>", strSiteAddress)
strMsg = Replace(strMsg, "<HIRETIME>", strTime)
strMsg = Replace(strMsg, "<ROOM>", strSiteRoom)


   Set olApp = GetObject("", "Outlook.Application")
    On Error GoTo 0
    If olApp Is Nothing Then
        On Error Resume Next
        Set olApp = CreateObject("Outlook.Application")
        On Error GoTo 0
        If olApp Is Nothing Then
            MsgBox "Outlook is not available!"
            Exit Sub
        End If
    End If

这是我厌倦了调用工作表但不起作用的代码

With WB


    .Worksheets("Email").Visible = True
    .Worksheets("Email").Copy Before:=WB.Worksheets(WB.Worksheets.Count)
    .Worksheets("Email").Visible = xlSheetVeryHidden
    .Worksheets("Email (2)").Shapes("objWordEmail").OLEFormat.Verb 2

On Error Resume Next
    Set WordDoc = GetObject(, "Word.Application").ActiveDocument


If Err.Number <> 0 Then
        Err.Clear
        Set WordApp = CreateObject("Word.Application")
        WordApp.Visible = False
        Set WordDoc = GetObject(, "Word.Application").ActiveDocument
End If

    With WordDoc
        With .Content.Find
        .Text = "<HIREDATE>"
        .Replacement.Text = strHireDate
        .Wrap = wdFindContinue
        .Execute Replace:=wdReplaceAll

        .Text = "<HIRETIME>"
        .Replacement.Text = strTime
        .Wrap = wdFindContinue
        .Execute Replace:=wdReplaceAll

        .Text = "<ROOM>"
        .Replacement.Text = strSiteRoom
        .Wrap = wdFindContinue
        .Execute Replace:=wdReplaceAll

        .Text = "<CONTACTEXT>"
        .Replacement.Text = strContactPhoneExt
        .Wrap = wdFindContinue
        .Execute Replace:=wdReplaceAll

    End With
End With

我不确定我还需要什么才能只显示嵌入的 word 文档，它只是继续显示与以前相同的电子邮件？

Answer 1

感谢大家的意见...我不知道这样做是否正确，但我找到了另一种方法来完成此操作，将电子邮件保存为模板，然后调用它并填写下面的代码...我只是希望这对将使用我的宏的人来说没问题...如果您有任何其他建议，请告诉我，但现在已经解决了

    On Error GoTo 0
    If olApp Is Nothing Then
        On Error Resume Next
        Set olApp = CreateObject("Outlook.Application")
        On Error GoTo 0
        If olApp Is Nothing Then
            MsgBox "Outlook is not available!"
            Exit Sub
        End If
    End If

Set olAppMsg1 = olApp.CreateItemFromTemplate("\\mypath\Onboarding Files\Confirmacion de ingreso.oft")
    With olAppMsg1
        .HTMLBody = Replace(.HTMLBody, "[ROOM]", strSiteRoom)
        .HTMLBody = Replace(.HTMLBody, "[HIREDATE]", strHireDate)
        .HTMLBody = Replace(.HTMLBody, "[HIRETIME]", strTime)
        .HTMLBody = Replace(.HTMLBody, "[CONTACTEXT]", strContactPhoneExt)
        .To = strEmpEmail
        .Importance = olImportanceHigh
        .Attachments.Add ("\\mypath\Onboarding Files\Aceptación de formatos en WD.PPTX")
        .Attachments.Add (pathSaveIDPass)
        .Attachments.Add (strZip)
        .Display

    End With