Question

尝试插入我的默认Outlook签名。我似乎无法正常工作。任何对此的想法将不胜感激。

我似乎无法使其与.HTML一起使用

Sub Send_email_fromexcel()

    Dim edress As String
    Dim subj As String
    Dim message As String
    Dim outlookapp As Object
    Dim outlookmailitem As Object
    Dim path As String
    Dim lastrow As Integer
    Dim x As Integer
    Dim header As String
    Dim header1 As String
    Dim header2 As String
    Dim header3 As String
    Dim header4 As String
    Dim header5 As String
    Dim header6 As String
    Dim header7 As String
    Dim hearder8 As String
    Dim data As String
    Dim data1 As String
    Dim data2 As String
    Dim data3 As String
    Dim data4 As String
    Dim data5 As String
    Dim data6 As String
    Dim sig As String

    x = 2
    Do While Sheet1.Cells(x, 1) <> ""

        Set outlookapp = CreateObject("Outlook.Application")
        Set outlookmailitem = outlookapp.createitem(0)

        edress = Sheet1.Cells(x, 1)
        subj = Sheet1.Cells(x, 2)
        header = Sheet1.Cells(1, 3)
        header2 = Sheet1.Cells(1, 4)
        header3 = Sheet1.Cells(1, 5)
        header4 = Sheet1.Cells(1, 6)
        header5 = Sheet1.Cells(1, 7)
        header6 = Sheet1.Cells(1, 8)
        header7 = Sheet1.Cells(1, 9)
        header8 = Sheet1.Cells(1, 10)

        data = Sheet1.Cells(x, 3)
        data1 = Sheet1.Cells(x, 4)
        data2 = Sheet1.Cells(x, 5)
        data3 = Sheet1.Cells(x, 6)
        data4 = Sheet1.Cells(x, 7)
        data5 = Sheet1.Cells(x, 8)
        data6 = Sheet1.Cells(x, 9)


        outlookmailitem.To = edress
        outlookmailitem.cc = ""
        outlookmailitem.bcc = ""
        outlookmailitem.Subject = subj
        outlookmailitem.body = "Good afternoon," & vbNewLine & " " & vbNewLine & "I'm just reaching out because we are attempting to process rewards for customers that were referred using the Lawn Doctor Referral Rewards Program,… I have put it in this email." & vbNewLine & "Please update your records accordingly by going into …(s). Please let me know when this has been completed and I will push their Amazon Gift Card out." & vbCrLf & header & " " & header2 & " " & header3 & " " & header4 & " " & header5 & " " & header6 & " " & header7 & " " & header8 & _
        vbCrLf & data & " " & data1 & " " & data2 & " " & data3 & " " & data4 & " " & data5 & " " & data6 & _
        vbCrLf & vbNewLine & "Regards"

        outlookmailitem.display
        outlookmailitem.send

        lastrow = lastrow + 1
        edress = ""
        x = x + 1

    Loop

    Set outlookapp = Nothing
    Set outlookmailitem = Nothing

End Sub

Answer 1

您需要像这样的东西。首先创建一个函数，然后在电子邮件详细信息之前在Outlook代码中调用它，并在放置电子邮件详细信息时执行类似.HTMLBody = emailMessage & Signature

的操作

'Change only Mysig.htm to the name of your signature
    sigString = Environ("appdata") & _
                "\Microsoft\Signatures\Mysig.htm"

    If Dir(sigString) <> "" Then
        Signature = GetBoiler(sigString)
    Else
        Signature = ""
    End If


Function GetBoiler(ByVal sFile As String) As String

    Dim FSO As Object
    Dim ts As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set ts = FSO.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function

以完整代码为例，以使上面的代码片段更具意义。

Sub SendEmail()

    Dim outlookApp As Object
    Dim outlookMail As Object
    Dim sigString As String
    Dim Signature As String
    Dim insertPhoto As String
    Dim photoSize As String
    Dim outlookPA As Outlook.PropertyAccessor

    Set outlookApp = CreateObject("Outlook.Application")
    Set outlookMail = outlookApp.CreateItem(0)


    'Change only Mysig.htm to the name of your signature
    sigString = Environ("appdata") & _
                "\Microsoft\Signatures\Mysig.htm"

    If Dir(sigString) <> "" Then
        Signature = GetBoiler(sigString)
    Else
        Signature = ""
    End If

    insertPhoto = "C:\Users\marius.dragan\Desktop\Presale.jpg" 'Picture path
    photoSize = "<img src=""cid:Presale.jpg""height=400 width=400>" 'Change image name here

    emailMessage = "<BODY style=font-size:11pt;font-family:Calibri>Dear " & titleName & " " & fullName & "," & _
                    "<p>I hope my email will find you very well." & _
                    "<p>Our <strong>sales preview</strong> starts on Thursday the 22nd until Sunday the 25th of November." & _
                    "<p>I look forward to welcoming you into the store to shop on preview.<p>" & _
                    "<p> It really is the perfect opportunity to get some fabulous pieces for the fast approaching festive season." & _
                    "<p>Please feel free to contact me and book an appointment." & _
                    "<p>I look forward to seeing you then." & _
                    "<p>" & photoSize & _
                    "<p>"


    With outlookMail
        .To = clientEmail
        .CC = ""
        .BCC = ""
        .Subject = "PRIVATE SALE"
        .BodyFormat = 2
        .Attachments.Add insertPhoto, 1, 0
        .HTMLBody = emailMessage & Signature 'Including photo insert and signature
        .Importance = 2
        .ReadReceiptRequested = True
        .Display 'Needs to display the email and then send to display in line image
        .send 'this will send the email without review

    End With

    Set outlookApp = Nothing
    Set outlookMail = Nothing
End Sub
Function GetBoiler(ByVal sFile As String) As String

    Dim FSO As Object
    Dim ts As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set ts = FSO.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function

如何将我的默认Outlook签名插入VBA代码

1 个答案: