Question

我正在Access中编写一个VBA脚本，用于创建和自动填充几十封电子邮件。到目前为止，它一直是流畅的编码，但我是Outlook的新手。创建mailitem对象后，如何将默认签名添加到电子邮件？

这是创建新电子邮件时自动添加的默认签名。
理想情况下，我只想使用ObjMail.GetDefaultSignature，但我找不到类似的内容。
目前，我正在使用以下功能（在互联网上找到elsewhere）并参考确切路径＆amp; htm文件的文件名。但是这将由几个人使用，他们的默认htm签名文件可能有不同的名称。所以这有效，但它并不理想：
```
Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
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
```
（用getboiler(SigString = "C:\Users\" & Environ("username") & "\AppData\Roaming\Microsoft\Signatures\Mysig.txt")调用）

修改

感谢JP（请参阅评论），我意识到默认签名首先出现，但是当我使用HTMLBody向电子邮件添加表格时它会消失。所以我想我现在的问题是：如何显示默认签名并仍显示html表？

Sub X()
    Dim OlApp As Outlook.Application
    Dim ObjMail As Outlook.MailItem

    Set OlApp = Outlook.Application
    Set ObjMail = OlApp.CreateItem(olMailItem)

    ObjMail.BodyFormat = olFormatHTML
    ObjMail.Subject = "Subject goes here"
    ObjMail.Recipients.Add "Email goes here"

    ObjMail.HTMLBody = ObjMail.Body & "HTML Table goes here"
    ObjMail.Display

End Sub

Answer 1

以下代码将创建一个展望消息＆amp;保持自动签名

Dim OApp As Object, OMail As Object, signature As String
Set OApp = CreateObject("Outlook.Application")
Set OMail = OApp.CreateItem(0)
    With OMail
    .Display
    End With
        signature = OMail.body
    With OMail
    '.To = "someone@somedomain.com"
    '.Subject = "Type your email subject here"
    '.Attachments.Add
    .body = "Add body text here" & vbNewLine & signature
    '.Send
    End With
Set OMail = Nothing
Set OApp = Nothing

Answer 2

我的解决方案是首先显示空消息（使用默认签名！）并将预期的strHTMLBody插入现有HTMLBody。

如果像PowerUser所述，在编辑HTMLBody时签名被删除，您可以考虑在ObjMail.HTMLBody之后立即将strTemp的内容存储到变量ObjMail.Display中并添加strTemp之后但这不是必要的。

Sub X(strTo as string, strSubject as string, strHTMLBody as string)

   Dim OlApp As Outlook.Application   
   Dim ObjMail As Outlook.MailItem 

   Set OlApp = Outlook.Application
   Set ObjMail = OlApp.CreateItem(olMailItem)

   ObjMail.To = strTo
   ObjMail.Subject = strSubject   
   ObjMail.Display
   'You now have the default signature within ObjMail.HTMLBody.
   'Add this after adding strHTMLBody
   ObjMail.HTMLBody = strHTMLBody & ObjMail.HTMLBody

   'ObjMail.Send 'send immediately or 
   'ObjMail.close olSave 'save as draft
   'Set OlApp = Nothing

End sub

Answer 3

Dim OutApp As Object, OutMail As Object, LogFile As String
Dim cell As Range, S As String, WMBody As String, lFile As Long

S = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(S, vbDirectory) <> vbNullString Then S = S & Dir$(S & "*.htm") Else S = ""
S = CreateObject("Scripting.FileSystemObject").GetFile(S).OpenAsTextStream(1,  -2).ReadAll

WMBody = "<br>Hi All,<br><br>" & _
         "Last line,<br><br>" & S 'Add the Signature to end of HTML Body

我想我会分享如何实现这一目标。不确定它是否在定义变量意义上是正确的，但它很小且易于阅读，这就是我喜欢的。

我将WMBody附加到对象Outlook.Application OLE中的.HTMLBody。

希望它有所帮助。

谢谢，韦斯。

Answer 4

我在寻找如何以定期计划发送消息的同时构建了这种方法。我发现你引用创建的消息的Inspector属性的方法没有添加我想要的签名（我在Outlook中设置了多个帐户，并且有单独的签名。）

以下方法相当灵活，而且仍然很简单。

    Private Sub Add_Signature(ByVal addy as String, ByVal subj as String, ByVal body as String)
       Dim oMsg As MailItem
       Set oMsg = Application.CreateItem(olMailItem)
       oMsg.To = addy
       oMsg.Subject = subj
       oMsg.Body = body
       Dim sig As String
       ' Mysig is the name you gave your signature in the OL Options dialog 
       sig = ReadSignature("Mysig.htm")
       oMsg.HTMLBody = Item.Body & "<p><BR/><BR/></p>" & sig ' oMsg.HTMLBody
       oMsg.Send
       Set oMsg = Nothing
    End Sub

    Private Function ReadSignature(sigName As String) As String
       Dim oFSO, oTextStream, oSig As Object
       Dim appDataDir, sig, sigPath, fileName As String
       appDataDir = Environ("APPDATA") & "\Microsoft\Signatures"
       sigPath = appDataDir & "\" & sigName

       Set oFSO = CreateObject("Scripting.FileSystemObject")
       Set oTextStream = oFSO.OpenTextFile(sigPath)
       sig = oTextStream.ReadAll
       ' fix relative references to images, etc. in sig
       ' by making them absolute paths, OL will find the image
       fileName = Replace(sigName, ".htm", "") & "_files/"
       sig = Replace(sig, fileName, appDataDir & "\" & fileName)
       ReadSignature = sig
    End Function

Answer 5

当您调用MailItem.Display（导致消息显示在屏幕上）或访问{{}时，Outlook会将签名添加到新的未修改消息（您不应在此之前修改正文） 1}} property - 您不必对返回的Inspector对象执行任何操作，但Outlook将使用签名填充邮件正文。

添加签名后，请阅读MailItem.GetInspector属性并将其与您尝试设置的HTML字符串合并。请注意，您不能简单地连接2个HTML字符串 - 需要合并字符串。例如。如果要在HTML正文的顶部插入字符串，请查找HTMLBody子字符串，然后查找下一次出现的“＆gt;” （这会处理带有属性的"<body"元素），然后在“＆gt;”之后插入HTML字符串。

Outlook对象模型根本不公开签名。

一般情况下，签名的名称存储在可通过IOlkAccountManager扩展MAPI界面访问的帐户配置文件数据中。由于该接口是扩展MAPI，因此只能使用C ++或Delphi进行访问。如果单击<body>按钮，则可以在OutlookSpy中查看界面及其数据获得签名后，您可以从文件系统中读取HTML文件（请记住文件夹名称（英文签名）已本地化。
另请注意，如果签名包含图像，则还必须将它们作为附件添加到邮件中，并调整签名/邮件正文中的IOlkAccountManager标记以将<img>属性指向附件而不是Signatures文件夹的子文件夹，用于存储图像您还有责任将签名HTML文件中的HTML样式与消息本身的样式合并。

如果使用Redemption是一个选项，则可以使用其RDOAccount对象（可以使用任何语言访问，包括VBA）。新邮件签名名称存储在src属性中，回复签名位于0x0016001F中。您还可以使用RDOAccount。0x0017001F和ReplySignature属性 Redemption还公开RDOSignature。NewSignature方法，该方法获取指向RDOMail对象的指针，并在指定位置插入签名，正确合并图像和样式：

ApplyTo

编辑：截至2017年7月，Outlook 2016中的set Session = CreateObject("Redemption.RDOSession") Session.MAPIOBJECT = Application.Session.MAPIOBJECT set Drafts = Session.GetDefaultFolder(olFolderDrafts) set Msg = Drafts.Items.Add Msg.To = "user@domain.demo" Msg.Subject = "testing signatures" Msg.HTMLBody = "<html><body>some <b>bold</b> message text</body></html>" set Account = Session.Accounts.GetOrder(2).Item(1) 'first mail account if Not (Account Is Nothing) Then set Signature = Account.NewMessageSignature if Not (Signature Is Nothing) Then Signature.ApplyTo Msg, false 'apply at the bottom End If End If Msg.Send不再插入签名。只有MailItem.GetInspector可以。

Answer 6

我已将此作为社区Wiki答案，因为如果没有PowerUser的研究和早期评论中的帮助，我就无法创建它。

我使用了PowerUser的Sub X并添加了

Debug.Print "n------"    'with different values for n
Debug.Print ObjMail.HTMLBody

每次发言后

。由此我发现签名不在.HTMLBody之后ObjMail.Display，然后才会在身体中添加任何内容。

我回到了PowerUser之前使用C:\Users\" & Environ("username") & "\AppData\Roaming\Microsoft\Signatures\Mysig.txt")的解决方案。 PowerUser对此并不满意，因为他希望他的解决方案适用于拥有不同签名的其他人。

我的签名位于同一文件夹中，我找不到任何更改此文件夹的选项。我只有一个签名，所以通过阅读此文件夹中唯一的HTM文件，我获得了我的唯一/默认签名。

我创建了一个HTML表格并将其插入到＆lt; body＆gt;之后的签名中。元素并将html主体设置为结果。我发送电子邮件给自己，结果是完全可以接受的，只要我喜欢我的格式，我就可以检查一下。

我修改过的子程序是：

Sub X()

  Dim OlApp As Outlook.Application
  Dim ObjMail As Outlook.MailItem

  Dim BodyHtml As String
  Dim DirSig As String
  Dim FileNameHTMSig As String
  Dim Pos1 As Long
  Dim Pos2 As Long
  Dim SigHtm As String

  DirSig = "C:\Users\" & Environ("username") & _
                               "\AppData\Roaming\Microsoft\Signatures"

  FileNameHTMSig = Dir$(DirSig & "\*.htm")

  ' Code to handle there being no htm signature or there being more than one

  SigHtm = GetBoiler(DirSig & "\" & FileNameHTMSig)
  Pos1 = InStr(1, LCase(SigHtm), "<body")

  ' Code to handle there being no body

  Pos2 = InStr(Pos1, LCase(SigHtm), ">")

  ' Code to handle there being no closing > for the body element

   BodyHtml = "<table border=0 width=""100%"" style=""Color: #0000FF""" & _
         " bgColor=#F0F0F0><tr><td align= ""center"">HTML table</td>" & _
         "</tr></table><br>"
  BodyHtml = Mid(SigHtm, 1, Pos2 + 1) & BodyHtml & Mid(SigHtm, Pos2 + 2)

  Set OlApp = Outlook.Application
  Set ObjMail = OlApp.CreateItem(olMailItem)
  ObjMail.BodyFormat = olFormatHTML
  ObjMail.Subject = "Subject goes here"
  ObjMail.Recipients.Add "my email address"
  ObjMail.Display

End Sub

由于PowerUser和我都在C:\Users\" & Environ("username") & "\AppData\Roaming\Microsoft\Signatures找到了我的签名，我建议这是任何Outlook安装的标准位置。可以更改此默认值吗？我发现它无法找到任何建议。上面的代码显然需要一些开发，但它确实实现了PowerUser的目标，即创建一个包含签名上方的HTML表格的电子邮件正文。

Answer 7

我找到了办法，但对大多数人来说可能太草率了。我有一个简单的Db，我希望它能够为我生成电子邮件，所以这里是我使用的简单和肮脏的解决方案：

我发现正文的开头是我在新电子邮件的HTMLBody中看到“<div class=WordSection1>”的唯一地方，所以我只做了一个简单的替换，替换

“<div class=WordSection1><p class=MsoNormal><o:p>”

带

"<div class=WordSection1><p class=MsoNormal><o:p>" & sBody

其中sBody是我要插入的正文内容。似乎到目前为止工作。

.HTMLBody = Replace(oEmail.HTMLBody, "<div class=WordSection1><p class=MsoNormal><o:p>", "<div class=WordSection1><p class=MsoNormal><o:p>" & sBody)

Answer 8

我需要50位代表才能对我发现最有帮助的签名选项发表评论，但是我遇到了图片显示不正确的问题所以我必须找到一个解决方法。这是我的解决方案：

以@Morris Maynard的答案为基础https://stackoverflow.com/a/18455148/2337102然后我必须经历以下事项：

备注：
在开始，复制和放大之前备份.htm文件粘贴到辅助文件夹

您将同时使用SignatureName.htm和SignatureName_files Folder

您不需要HTML经验，文件将在编辑程序（如记事本或Notepad ++）或指定的HTML程序中打开

导航至您的签名文件位置（标准应为C:\Users\"username"\AppData\Roaming\Microsoft\Signatures）

在text / htm编辑器中打开SignatureName.htm文件（右键单击文件“使用程序编辑”）

使用Ctrl+F并输入.png; .jpg或者如果您不知道自己的图片类型，请使用image001 您会看到类似：src="signaturename_files/image001.png"

的内容

您需要将其更改为图像位置的整个地址 C:\Users\YourName\AppData\Roaming\Microsoft\Signatures\SignatureNameFolder_files\image001
或
src="E:\location\Signatures\SignatureNameFolder_files\image001.png"

保存您的文件（覆盖它，您当然备份了原始文件）

返回Outlook并打开新邮件项目，添加您的签名。我收到一个警告说文件已被更改，我点击确定，我需要两次，然后在“编辑签名菜单”中执行一次。

Some of the files in this webpage aren't in the expected location. Do you want to download them anyway? If you're sure the Web page is from a trusted source, click Yes."

运行您的微距事件，现在应该显示图像。

<强>信用卡
MrExcel - VBA代码签名代码失败：http://bit.ly/1gap9jY

Answer 9

其他大多数答案都只是简单地将HTML主体与HTML签名连接起来。但是，这不适用于图像，事实证明有一种更“标准”的方式。1

使用WordEditor作为其编辑器配置的2007年之前的Microsoft Outlook，以及Microsoft Outlook 2007及更高版本，使用Word编辑器的略微缩减版本来编辑电子邮件。这意味着我们可以使用Microsoft Word文档对象模型对电子邮件进行更改。

Set objMsg = Application.CreateItem(olMailItem)
objMsg.GetInspector.Display 'Displaying an empty email will populate the default signature
Set objSigDoc = objMsg.GetInspector.WordEditor
Set objSel = objSigDoc.Windows(1).Selection
With objSel
   .Collapse wdCollapseStart
   .MoveEnd WdUnits.wdStory, 1
   .Copy 'This will copy the signature
End With
objMsg.HTMLBody = "<p>OUR HTML STUFF HERE</p>"
With objSel
   .Move WdUnits.wdStory, 1 'Move to the end of our new message
   .PasteAndFormat wdFormatOriginalFormatting 'Paste the copied signature
End With 
'I am not a VB programmer, wrote this originally in another language so if it does not
'compile it is because this is my first VB method :P

Microsoft Outlook 2007 Programming (S. Mosher)> Chapter 17, Working with Item Bodies: Working with Outlook Signatures

Answer 10

我喜欢Mozzi的回答，但发现它没有保留用户特定的默认字体。文本全部以系统字体显示为普通文本。下面的代码保留了用户最喜欢的字体，同时只需要更长的时间。它基于Mozzi的方法，使用正则表达式替换默认正文文本，并使用GetInspector.WordEditor将用户选择的正文文本放置在它所属的位置。我发现对GetInspector的调用不在此主题中将HTML实体填充为dimitry streblechenko，至少在Office 2010中没有，因此该对象仍显示在我的代码中。顺便提一下，请注意，将MailItem创建为Object非常重要，而不是简单的MailItem - 请参阅here了解更多信息。（哦，对不同品味的人抱歉，但我更喜欢更长的描述性变量名，以便我可以找到例程！）

Public Function GetSignedMailItemAsObject(ByVal ToAddress As String, _
                      ByVal Subject As String, _
                      ByVal Body As String, _
                      SignatureName As String) As Object
'================================================================================================================='Creates a new MailItem in HTML format as an Object.
'Body, if provided, replaces all text in the default message.
'A Signature is appended at the end of the message.
'If SignatureName is invalid any existing default signature is left in place.
'=================================================================================================================
' REQUIRED REFERENCES
' VBScript regular expressions (5.5)
' Microsoft Scripting Runtime
'=================================================================================================================
Dim OlM As Object               'Do not define this as Outlook.MailItem.  If you do, some things will work and some won't (i.e. SendUsingAccount)
Dim Signature As String
Dim Doc As Word.Document
Dim Regex As New VBScript_RegExp_55.RegExp       '(can also use use Object if VBScript is not Referenced)

Set OlM = Application.CreateItem(olMailItem)
With OlM
    .To = ToAddress
    .Subject = Subject
    'SignatureName is the exactname that you gave your signature in the Message>Insert>Signature Dialog
    Signature = GetSignature(SignatureName)
    If Signature <> vbNullString Then
'        Should really strip the terminal </body tag out of signature by removing all characters from the start of the tag
'        but Outlook seems to handle this OK if you don't bother.
        .Display                                'Needed.  Without it, there is no existing HTMLbody available to work with.
        Set Doc = OlM.GetInspector.WordEditor   'Get any existing body with the WordEditor and delete all of it
        Doc.Range(Doc.Content.Start, Doc.Content.End) = vbNullString 'Delete all existing content - we don't want any default signature
        'Preserve all local email formatting by placing any new body text, followed by the Signature, into the empty HTMLbody.
        With Regex
            .IgnoreCase = True                  'Case insensitive
            .Global = False                     'Regex finds only the first match
            .MultiLine = True                   'In case there are stray EndOfLines (there shouldn't be in HTML but Word exports of HTML can be dire)
            .Pattern = "(<body.*)(?=<\/body)"   'Look for the whole HTMLbody but do NOT include the terminal </body tag in the value returned
            OlM.HTMLbody = .Replace(OlM.HTMLbody, "$1" & Signature)
        End With ' Regex
        Doc.Range(Doc.Content.Start, Doc.Content.Start) = Body 'Place the required Body before the signature (it will get the default style)
        .Close olSave                           'Close the Displayed MailItem (actually Object) and Save it.  If it is left open some later updates may fail.
    End If ' Signature <> vbNullString
End With ' OlM
Set GetSignedMailItemAsObject = OlM
End Function

Private Function GetSignature(sigName As String) As String
Dim oTextStream As Scripting.TextStream
Dim oSig As Object
Dim appDataDir, Signature, sigPath, fileName As String
Dim FileSys As Scripting.FileSystemObject        'Requires Microsoft Scripting Runtime to be available
    appDataDir = Environ("APPDATA") & "\Microsoft\Signatures"
    sigPath = appDataDir & "\" & sigName & ".htm"
    Set FileSys = CreateObject("Scripting.FileSystemObject")
    Set oTextStream = FileSys.OpenTextFile(sigPath)
    Signature = oTextStream.ReadAll
    ' fix relative references to images, etc. in Signature
    ' by making them absolute paths, OL will find the image
    fileName = Replace(sigName, ".htm", "") & "_files/"
    Signature = Replace(Signature, fileName, appDataDir & "\" & fileName)
    GetSignature = Signature
End Function

Answer 11

现有答案对我来说有一些问题：

我需要以html格式插入文本（例如“ Good Day John Doe”）。
至少在我的计算机上，Outlook在签名上方添加了2个空白行，您应在其中开始输入。这些显然应该被删除（替换为自定义HTML）。

下面的代码完成了这项工作。请注意以下几点：

“发件人”参数可让您选择帐户（因为不同的电子邮件帐户可能会有不同的默认签名）
“收件人”参数需要一组电子邮件，它将“解析”添加的电子邮件（即在联系人中找到它，就像您在“收件人”框中键入了一样）
使用了后期绑定，因此不需要引用

'Opens an outlook email with the provided email body and default signature
'Parameters:
'  from: Email address of Account to send from.  Wildcards are supported e.g. *@example.com
'  recipients: Array of recipients.  Recipient can be a Contact name or email address
'  subject: Email subject
'  htmlBody: Html formatted body to insert before signature (just body markup, should not contain html, head or body tags)
Public Sub CreateMail(from As String, recipients, subject As String, htmlBody As String)
    Dim oApp, oAcc As Object
    
    Set oApp = CreateObject("Outlook.application")
    
    With oApp.CreateItem(0) 'olMailItem = 0
        'Ensure we are sending with the correct account (to insert the correct signature)
        'oAcc is of type Outlook.Account, which has other properties that could be filtered with if required
        'SmtpAddress is usually equal to the raw email address
        .SendUsingAccount = Nothing
        For Each oAcc In oApp.Session.Accounts
            If CStr(oAcc.SmtpAddress) = from Or CStr(oAcc.SmtpAddress) Like from Then
                Set .SendUsingAccount = oAcc
            End If
        Next oAcc
        If .SendUsingAccount Is Nothing Then Err.Raise -1, , "Unknown email account " & from
        For Each addr In recipients
            With .recipients.Add(addr)
                'This will resolve the recipient as if you had typed the name/email and pressed Tab/Enter
                .Resolve
            End With
        Next addr
        .subject = subject
        .Display 'HTMLBody is only populated after this line
        'Remove blank lines at the top of the body
        .htmlBody = Replace(.htmlBody, "<o:p>&nbsp;</o:p>", "")
        'Insert the html at the start of the 'body' tag
        Dim bodyTagEnd As Long: bodyTagEnd = InStr(InStr(1, .htmlBody, "<body"), .htmlBody, ">")
        .htmlBody = Left(.htmlBody, bodyTagEnd) & htmlBody & Right(.htmlBody, Len(.htmlBody) - bodyTagEnd)
    End With
    Set oApp = Nothing
End Sub

用法如下：

CreateMail from:="*@contoso.com", _
    recipients:= Array("john.doe@contoso.com", "Jane Doe", "unknown@example.com"), _
    subject:= "Test Email", _
    htmlBody:= "<p>Good Day All</p><p>Hello <b>World!</b></p>"

结果：

Astronomy stack exchange

Answer 12

通常在Ron de Bruin的RangeToHTML函数的上下文中询问此问题，该函数从PublishObject创建HTML Excel.Range，通过FSO提取，并插入生成的流HTML将导入电子邮件HTMLBody。这样做会删除默认签名（RangeToHTML函数有一个辅助函数GetBoiler，试图插入默认签名。）

不幸的是，通过Outlook无法获得记录不佳的Application.CommandBars方法：

wdDoc.Application.CommandBars.ExecuteMso "PasteExcelTableSourceFormatting"

它将引发运行时6158：

但是我们仍然可以利用可以通过Word.Document方法访问的MailItem.GetInspector，我们可以做类似的事情来复制＆amp;将选择从Excel粘贴到Outlook电子邮件正文，保留您的默认签名（如果有）。

Dim rng as Range
Set rng = Range("A1:F10") 'Modify as needed

With OutMail
    .To = "xxxxx@xxxxx.com"
    .BCC = ""
    .Subject = "Subject"
    .Display
    Dim wdDoc As Object     '## Word.Document
    Dim wdRange As Object   '## Word.Range
    Set wdDoc = OutMail.GetInspector.WordEditor
    Set wdRange = wdDoc.Range(0, 0)
    wdRange.InsertAfter vbCrLf & vbCrLf
    'Copy the range in-place
    rng.Copy
    wdRange.Paste
End With

请注意，在某些情况下，这可能无法完美地保留列宽或在某些情况下保持行高，虽然它也会复制Excel范围内的形状和其他对象，但这也可能会导致一些时髦的对齐问题，但对于简单的表和Excel范围，非常好：

Answer 13

需要添加对Microsoft.Outlook的引用。它位于Visual Basic窗口顶部菜单的Project引用中。

Private Sub sendemail_Click()

  Dim OutlookApp As Outlook.Application
  Dim OutlookMail As Outlook.MailItem

  Set OutlookApp = New Outlook.Application
  Set OutlookMail = OutlookApp.CreateItem(olMailItem)

  With OutlookMail
    .Display
    .To = email
    .Subject = "subject"

    Dim wdDoc As Object     ' Word.Document
    Dim wdRange As Object   ' Word.Range
    Set wdDoc = .GetInspector.WordEditor
    Set wdRange = wdDoc.Range(0, 0) ' Create Range at character position 0 with length of 0 character s.

    ' if you need rtl:
    wdRange.Paragraphs.ReadingOrder = 0 ' 0 is rtl , 1 is ltr

    wdRange.InsertAfter "mytext"
  End With

End Sub

如何在Outlook中添加默认签名

修改

13 个答案: