Как я могу вставить свою подпись Outlook по умолчанию в код VBA

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