Question

我编写了一个脚本，在其中我将来自appData ...签名文件夹中的htm文件的签名添加到新打开的电子邮件中。

我的问题是-我如何修改此VBA脚本以某种方式添加该签名，以便Outlook知道其签名，并且用户可以通过gui更改该签名。

我认为可能与设置“ _MailAutoSig”书签有关，对吗？

脚本看起来像这样，到目前为止可以使用：

    Dim WithEvents m_objMail As Outlook.MailItem

    Dim LODGIT_SUBJECT_IDENTIFIERS() As String

    Private Sub Application_ItemLoad(ByVal Item As Object)
        'MsgBox "Application_ItemLoad"
        Select Case Item.Class
            Case olMail
                Set m_objMail = Item
        End Select
    End Sub

    Private Sub m_objMail_Open(Cancel As Boolean)

        'string array containing lodgit email subject identifiers (beginning string!!! of email subject)
        LODGIT_SUBJECT_IDENTIFIERS = Split("Angebot von Bödele Alpenhotel,Angebot von,bestätigt Ihre Reservierung,Rechnung Nr.,Stornogutschrift für die Rechnung,Ausstehende Zahlung", ",")

        Dim Application As Object
        Dim oOutApp As Object, oOutMail As Object
        Dim strbody As String, FixedHtmlBody As String
        Dim Ret

        Set Application = CreateObject("Outlook.Application")

        'Change only Mysig.htm to the name of your signature
        ' C:\Users\nicole\AppData\Roaming\Microsoft\Signatures
        Ret = Environ("appdata") & _
                    "\Microsoft\Signatures\AH Andrea kurz.htm"

        If Ret = False Then Exit Sub

        '~~> Use the function to fix image paths in the htm file
        FixedHtmlBody = FixHtmlBody(Ret)

        'CHECK FOR LODGIT IDENTIFIER
        If myInStr(m_objMail.Subject, LODGIT_SUBJECT_IDENTIFIERS()) Then
            Debug.Print "E-Mail as from Lodgit identified"
            Dim str As String
            Dim a As Object
            str = Replace(m_objMail.Body, vbCrLf, "<br>")
            str = Replace(str, vbNewLine, "<br>")


            m_objMail.HTMLBody = "<html><body><span style='font-size:11.0pt;font-family:""Times New Roman"" '>" & str & "</span>" & FixedHtmlBody & "</body></html>"

        End If

    End Sub

    '~~> Function to fix image paths in Signature .htm Files
    Function FixHtmlBody(r As Variant) As String
        Dim FullPath As String, filename As String
        Dim FilenameWithoutExtn As String
        Dim foldername As String
        Dim MyData As String

        '~~> Read the html file as text file in a string variable
        Open r For Binary As #1
        MyData = Space$(LOF(1))
        Get #1, , MyData
        Close #1

        '~~> Get File Name from path
        filename = GetFilenameFromPath(r)
        '~~> Get File Name without extension
        FilenameWithoutExtn = Left(filename, (InStrRev(filename, ".", -1, vbTextCompare) - 1))
        '~~> Get the foldername where the images are stored
        foldername = FilenameWithoutExtn & "-Dateien"

        '~~> Full Path of Folder
        FullPath = Left(r, InStrRev(r, "\")) & foldername

        '~~> To cater for spaces in signature file name
        'FullPath = Replace(FullPath, " ", "%20")

        '~~> Replace incomplete path with full Path
        FixHtmlBody = Replace(MyData, "AH%20Andrea%20kurz-Dateien", FullPath)
        'FixHtmlBody = Replace(MyData, foldername, FullPath)
    End Function

    '~~> Gets File Name from path
    Public Function GetFilenameFromPath(ByVal strPath As String) As String
        If Right$(strPath, 1) <> "\" And Len(strPath) > 0 Then _
        GetFilenameFromPath = GetFilenameFromPath(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1)
    End Function

    'check if str contains on of the elements of a str array
    Public Function myInStr(myString As String, a() As String) As Boolean
        For Each elem In a
            If InStr(1, myString, elem, vbTextCompare) <> 0 Then
                myInStr = True
                Exit Function
            End If
        Next

        myInStr = False
    End Function

Answer 1

Outlook查找“ _MailAutoSig”书签。这需要使用Word对象模型来完成，而不是通过设置HTMLBody属性来完成。大致情况：

wdStory = 6
wdMove = 0

Set objBkm = Nothing
Set objDoc = Inspector.WordEditor

Set objSel = objDoc.Application.Selection

'remember the cursor position
set cursorRange = objDoc.Range
cursorRange.Start = objSel.Start
cursorRange.End = objSel.End

If objDoc.Bookmarks.Exists("_MailAutoSig") Then
   'replace old signature
   Debug.Print "old signature found"
   set objBkm = objDoc.Bookmarks("_MailAutoSig")
   objBkm.Select
   objDoc.Windows(1).Selection.Delete
ElseIf objDoc.Bookmarks.Exists("_MailOriginal") Then
  ' is there the original email? (_MailOriginal)
  set objBkm = objDoc.Bookmarks("_MailOriginal")
  objSel.Start = objBkm.Start-2 'give room for the line break before. It includes the line
  objSel.End = objBkm.Start-2
Else
  'insert at the end of the email
  objSel.EndOf wdStory, wdMove
End If

'start bookmark
set bkmStart = objDoc.Bookmarks.Add("_tempStart", objSel.Range)

'end bookmark
set bkmEnd = objDoc.Bookmarks.Add("_tempEnd", objSel.Range)
bkmEnd.End = bkmEnd.End + 1
bkmEnd.Start = bkmEnd.Start + 1
objSel.Text = " "

set objBkm = objDoc.Bookmarks.Add("_MailAutoSig", bkmStart.Range)

objBkm.Range.insertFile "c:\Users\<user>\AppData\Roaming\Microsoft\Signatures\test.htm", , false, false, false
objBkm.Range.InsertParagraphBefore
objBkm.End = bkmEnd.Start - 1 'since we added 1 above for bkmEnd

objSel.Start = cursorRange.Start
objSel.End = cursorRange.End

bkmStart.Delete
bkmEnd.Delete

Outlook-VBA将签名设置为新的电子邮件...因此可以通过菜单

1 个答案: