excel - 将签名添加到电子邮件

Question

我在发送自动电子邮件时尝试使用我的默认签名。
我的代码粘贴签名的位置而不是签名本身。

Sub CreateEmailForGTB()
        
    Dim wb As Workbook
       
    Set wb = Workbooks.Add
    ThisWorkbook.Sheets("BBC").Copy After:=wb.Sheets(1)
       
    'save the new workbook in a dummy folder
    wb.SaveAs "location.xlsx"
         
    'close the workbook
    ActiveWorkbook.Close
         
    'open email
    Dim OutApp As Object
    Dim OutMail As Object
    Dim newDate: newDate = Format(DateAdd("M", -1, Now), "MMMM")
    Dim sigstring As String
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    sigstring = Environ("appdata") & _
                "\Microsoft\Signatures\zbc.htm"
    
    'fill out email
    With OutMail
        .To = "abc@domain.com;"
        .CC = "xyz@domain.com;"
        .BCC = ""
        .Subject = "VCR - CVs for BBC " & "- " & newDate & " month end."
        .Body = "Hi all," & vbNewLine & vbNewLine & _
                 "Please fill out the attached file for " & newDate & " month end." & vbNewLine & vbNewLine & _
                 "Looking forward to your response." & vbNewLine & vbNewLine & _
                 "Many thanks." & vbNewLine & vbNewLine & _
                 sigstring

Answer 1

还有另一种方法可以在电子邮件中显示签名，我认为这种方法更易于使用。它确实要求您已将签名设置为默认显示在新消息上。

请参阅我在下面设置的例程以了解如何实现。

Sub SendMail(strTo As String, strSubject As String, strBody As String, strAttachments As String, Optional strCC As String, Optional strFolder As String, Optional blSend As Boolean)

'*******************************************************************
'**    Sub:         SendMail
'**    Purpose:     Prepares email to be sent
'**    Notes:       Requires declaration of Outlook.Application outside of sub-routine
'**                 Passes file name and folder for attachments separately
'**                 strAttachments is a "|" separated list of attachment paths
'*******************************************************************

'first check if outlook is running and if not open it
Dim olApp As Outlook.Application

On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then Set olApp = New Outlook.Application

Dim olNS As Outlook.Namespace
Dim oMail As Outlook.MailItem

'login to outlook
Set olNS = olApp.GetNamespace("MAPI")
olNS.Logon

'create mail item
Set oMail = olApp.CreateItem(olMailItem)

'display mail to get signature
With oMail
    .display
End With

Dim strSig As String
strSig = oMail.HTMLBody

'build mail and send
With oMail

    .To = strTo
    .CC = strCC
    .Subject = strSubject
    .HTMLBody = strBody & strSig

    Dim strAttach() As String, x As Integer
    strAttach() = Split(strAttachments, "|")

    For x = LBound(strAttach()) To UBound(strAttach())
        If FileExists(strFolder & strAttach(x)) Then .Attachments.Add strFolder & strAttach(x)
    Next

    .display
    If blSend Then .send

End With

Set olNS = Nothing
Set oMail = Nothing

End Sub