Question

使用此代码，我可以提取默认签名，并使用工作表中的内容发送电子邮件：

Function RangetoHTML(rng As Range)
    ' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, Outlook 2010, and Office 365.
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

       TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

       ' Copy the range and create a workbook to receive the data.
       rng.Copy
       Set TempWB = Workbooks.Add(1)
       With TempWB.Sheets(1)
           .Cells(1).PasteSpecial Paste:=8
           .Cells(1).PasteSpecial xlPasteAll
           .Cells(1).Select
           Application.CutCopyMode = False
           On Error Resume Next
           .DrawingObjects.Visible = True
           .DrawingObjects.Delete
           On Error GoTo 0
       End With

       ' Publish the sheet to an .htm file.
       With TempWB.PublishObjects.Add( _
            SourceType:=xlSourceRange, _
            Filename:=TempFile, _
            Sheet:=TempWB.Sheets(1).Name, _
            Source:=TempWB.Sheets(1).UsedRange.Address, _
            HtmlType:=xlHtmlStatic)
           .Publish (True)
       End With

    ' Read all data from the .htm file into the RangetoHTML subroutine.
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
        "align=left x:publishsource=")

    ' Close TempWB.
    TempWB.Close savechanges:=False

    ' Delete the htm file.
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
Sub RegionMailer()
    ' Documentations for this macro is on the README.md file attached in this workbook.

    ' For debugging, comment out .send and uncomment .display
    ' CC to uncomment on publish

    ' Get email addresses
    Dim olApp As Outlook.Application
    Dim olNS As Outlook.Namespace
    Dim olAL As Outlook.AddressList
    Dim olEntry As Outlook.AddressEntry
    Dim olMember As Outlook.AddressEntry
    Dim lMemberCount As Long
    Dim objMail As Outlook.MailItem

    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set olAL = olNS.AddressLists("Global Address List")

    Set objMail = olApp.CreateItem(olMailItem)

    ' enter the list name
    Set olEntry = olAL.AddressEntries("ABC")

    ' get count of dist list members
    lMemberCount = olEntry.Members.Count

    ' loop through dist list and extract members
    Dim p As Long
    Dim sn As Long
    Dim rn As Range
    Dim firstName() As String
    Dim dtime As Date
    Dim StrBody As String
    Dim StrBody2 As String

    dtime = Now
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    ReDim EmailList(1 To lMemberCount, 1 To 3) As String
    For p = 1 To lMemberCount
        Set olMember = olEntry.Members.Item(p)
        EmailList(p, 1) = olMember.Name 'LN,FN
        EmailList(p, 2) = olMember.GetExchangeUser.PrimarySmtpAddress 'Email
        EmailList(p, 3) = olMember.GetExchangeUser.OfficeLocation ' Office Location e.g. ABC - 123 - DoReMi
    Next p

    With objMail
        .Display
        Signature = .HTMLBody
    End With

    For sn = 1 To Sheets.Count
        For p = 1 To lMemberCount
            If ActiveSheet.Name = EmailList(p, 1) And EmailList(p, 3) = "ABC - 123 - DoReMi" Then
                Set rn = Nothing
                Set rn = ActiveSheet.UsedRange
                With rn
                    .Borders(xlInsideVertical).LineStyle = xlContinuous
                    .Borders(xlInsideHorizontal).LineStyle = xlContinuous
                    .BorderAround xlContinuous
                End With

                firstName = Split(EmailList(p, 1), ", ", 2)

                With objMail
                    .HTMLBody = ""
                    .To = EmailList(p, 2)
                    .Subject = "Subject as of" & dtime
                    StrBody = "<BODY style=font-size=11pt;font-family:Calibri>Hi " & firstName(1) & ",<br><br>" & _
                        "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum."
                    StrBody2 = "<br><br>Regards,<br><br>"
                    .HTMLBody = StrBody & RangetoHTML(rn) & "<br>" & StrBody2 & Signature
                    '.Display
                    .Send 'to send
                End With
                Set objMail = olApp.CreateItem(olMailItem)
                Exit For
            End If
        Next p
        On Error Resume Next
            Sheets(ActiveSheet.Index + 1).Activate
        If Err.Number <> 0 Then Sheets(1).Activate
    Next sn
End Sub

这里的问题是，每当我运行此代码时，签名图像只会出现在发送的第一封电子邮件中，而不会出现在发送的所有其他电子邮件中。

以下是使用此代码发送的其他电子邮件上的最终签名（出于隐私目的，此处不会显示带有图像屏幕截图的签名）：

也像reference一样，但这也不会显示图像，我也不想打开文件浏览器来选择签名。

电子邮件签名图像显示在发送的第一封电子邮件中，但不显示在其他电子邮件中

0 个答案: