I’ve been doing some work with Outlook recently and seeing postings to read signature files that have hard codes file names

sSig = CreateObject("Scripting.FileSystemObject").GetFile(Environ("appdata") & "\Microsoft\Signatures\MySignatureFile.htm").OpenAsTextStream(1, -2).ReadAll

Now this is great and all, but that means you need to know the name of the file and update it for each user, update it should they ever create a new one … a nightmare to manage!

So I set out to find a better way!

The Nightmare That Is Outlook

I’m not going to go on and on about it, but needless to say, Microsoft sure did not make thing easy for us developers and documentation about certain aspects appears, at least to me, to be non-existent. So it took some serious investigative work to figure out which registry keys were involved, … I so wish that Microsoft would standardize and cleanup their object models and gives us some desperately needed methods and properties, but if they haven’t by now I doubt I’ll ever see it since now all their energies are on the cloud!

The fact that even with the object available to me, I still have to go through the registry to get information is just mind blowing in 2020!

Moving on now.

The Solution

The solution requires a few procedures:

• Determine the version of Outlook the user has so we can look things up in the registry
• Lookup values in the registry
• Encode string as proper HTML
• Read the signature

Long story short, this is what I came up with. The nice thing here is that I convert the relative paths used by Outlook into absolute paths so the signature HTML could be used by any e-mail client (Outlook, CDO, …).

'---------------------------------------------------------------------------------------
' Procedure : Outlook_GetSignature
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Finds and returns the signature (HTML) for a given account.
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
'             (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Late Binding version  -> None required
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sAccount      : Optional, e-mail account to get the signature of, if not specified
'                   the default account signature will be retrieved
'
' Usage:
' ~~~~~~
' sSig = Outlook_GetSignature
' sSig = Outlook_GetSignature("john.doe@hotmail.com")
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2020-12-08              Initial Release
'---------------------------------------------------------------------------------------
Function Outlook_GetSignature(Optional sAccount As String)
    Dim SignatueFileName      As String
    Dim SignatueFileName_Encoded As String
    Dim SignaturePath         As String
    Dim SignaturePath_Encoded As String
    Dim SignatueFile          As String
    Dim Signature             As String
    Dim SignatureFilePaths    As String
    Dim SignatureFilePaths_Encoded As String

    On Error GoTo Error_Handler

    If sAccount = "" Then
        SignatueFileName = Outlook_GetSignatureFileName
    Else
        SignatueFileName = Outlook_GetSignatureFileName(sAccount)
    End If

    'Get the path of the signature files
    SignaturePath = Environ("appdata") & "\Microsoft\Signatures\"
    'Get the path and filename of the signature file
    SignatueFile = SignaturePath & SignatueFileName & ".htm"
    'Read the actual signature file into memory
    Signature = CreateObject("Scripting.FileSystemObject").GetFile(SignatueFile).OpenAsTextStream(1, -2).ReadAll
    'Convert relative paths in signature to absolute ones
    SignatueFileName_Encoded = encodeURI(SignatueFileName)
    SignatureFilePaths_Encoded = SignatueFileName_Encoded & "_files/"
    SignaturePath_Encoded = Replace(SignaturePath, "\", "/")
    SignaturePath_Encoded = encodeURI(SignaturePath_Encoded)
    SignaturePath_Encoded = Replace(SignaturePath_Encoded, "%3A", ":")
    SignaturePath_Encoded = Replace(SignaturePath_Encoded, "%2F", "/")
    SignaturePath_Encoded = Replace(SignaturePath_Encoded, "%5C", "\")
    Signature = Replace(Signature, SignatureFilePaths_Encoded, "file://" & SignaturePath_Encoded & SignatureFilePaths_Encoded)
    'Return the final result
    Outlook_GetSignature = Signature

Error_Handler_Exit:
    On Error Resume Next
    Exit Function

Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: Outlook_GetSignature" & vbCrLf & _
           "Error Description: " & Err.Description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
           , vbOKOnly + vbCritical, "An Error has Occured!"
End Function

'---------------------------------------------------------------------------------------
' Procedure : Outlook_GetSignatureFileName
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Finds and returns the name of the signature file for a given account.
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
'             (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Late Binding version  -> None required
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sAccount      : Optional, e-mail account to get the signature of, if not specified
'                   the default account signature will be retrieved
' bDisplayError : Optional, whether or not to display error to the user
'
' Usage:
' ~~~~~~
' sSig = Outlook_GetSignatureFileName
'   -> main
' sSig = Outlook_GetSignatureFileName("john.doe@hotmail.com")
'   -> JohnDoe
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2020-12-08              Initial Release
' 2         2020-12-16              Minor tweak in the numbers were formatted in the
'                                   the various loops
'---------------------------------------------------------------------------------------
Function Outlook_GetSignatureFileName(Optional ByVal sAccount As String, _
                                      Optional bDisplayError As Boolean = False) As String
    Dim oWshShell             As Object
    Dim aValues               As Variant
    Dim i                     As Long
    Dim j                     As Long
    Dim sValue                As String
    Dim sOutlookVersion        As String
    Dim sAccountNo            As String

    On Error GoTo Error_Handler

    sOutlookVersion = GetAppVersion("OUTLOOK.EXE")

    Set oWshShell = CreateObject("WScript.Shell")

    'Determine the default account
    If sAccount = "" Then
        aValues = oWshShell.RegRead("HKCU\Software\Microsoft\Office\" & _
                                    sOutlookVersion & _
                                    "\Outlook\Profiles\Outlook\9375CFF0413111d3B88A00104B2A6676\" & _
                                    "{ED475418-B0D6-11D2-8C3B-00104B2A6676}")
        sAccountNo = aValues(0)    'Default Account No used for new e-mails
    Else
        On Error Resume Next
        For j = 0 To 99    'crude way to handle this
            aValues = oWshShell.RegRead("HKCU\Software\Microsoft\Office\" & _
                                        sOutlookVersion & _
                                        "\Outlook\Profiles\Outlook\9375CFF0413111d3B88A00104B2A6676\" & _
                                        Format(j, "00000000") & "\" & "Email")
            If IsEmpty(aValues) = False Then
                sValue = ""
                For i = LBound(aValues) To UBound(aValues) Step 2
                    If aValues(i) <> 0 Then
                        sValue = sValue & Chr(aValues(i))
                    End If
                Next
                If sAccount = sValue Then
                    sAccountNo = j
                    Exit For
                End If
            End If
            DoEvents
        Next j
        On Error GoTo Error_Handler
    End If

    'Retrieve the signature file name for the account
    aValues = oWshShell.RegRead("HKCU\Software\Microsoft\Office\" & _
                                sOutlookVersion & _
                                "\Outlook\Profiles\Outlook\9375CFF0413111d3B88A00104B2A6676\" & _
                                Format(sAccountNo, "00000000") & "\" & "New Signature")
    sValue = ""
    For i = LBound(aValues) To UBound(aValues) Step 2
        If aValues(i) <> 0 Then
            sValue = sValue & Chr(aValues(i))
        End If
    Next

    Outlook_GetSignatureFileName = sValue

Error_Handler_Exit:
    On Error Resume Next
    If Not oWshShell Is Nothing Then Set oWshShell = Nothing
    Exit Function

Error_Handler:
    If Err.Number = -2147024894 Then    '***Registry Doesn't Exist
        If bDisplayError = True Then MsgBox "The requested registry key does not exist."
    Else
        MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
               "Error Number: " & Err.Number & vbCrLf & _
               "Error Source: Outlook_GetSignatureFileName" & vbCrLf & _
               "Error Description: " & Err.Description & _
               Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
               , vbOKOnly + vbCritical, "An Error has Occured!"
    End If
    Resume Error_Handler_Exit
End Function

'---------------------------------------------------------------------------------------
' Procedure : GetAppVersion
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Return the version of the specified application
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
'             (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Late Binding version  -> None required
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sAppExe       : the EXE filename of the application to lookup
'
' Usage:
' ~~~~~~
' Call GetAppVersion("outlook.exe")
'   -> 15.0
' Call GetAppVersion("msaccess.exe")
'   -> 16.0
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2020-12-08              Initial Release
'---------------------------------------------------------------------------------------
Public Function GetAppVersion(ByVal sAppExe As String) As String
    Dim oRegistry             As Object
    Dim oWMI                  As Object
    Dim oItems                As Object
    Dim oItem                 As Object
    Dim sKey                  As String
    Dim sValue                As String
    Dim sAppVersion           As String
    Const HKEY_LOCAL_MACHINE = &H80000002

    On Error GoTo Error_Handler

    Set oRegistry = GetObject("winmgmts:{impersonationLevel=impersonate}//./root/default:StdRegProv")
    Set oWMI = GetObject("winmgmts:\\.\root\cimv2")
    sKey = "Software\Microsoft\Windows\CurrentVersion\App Paths"
    oRegistry.GetStringValue HKEY_LOCAL_MACHINE, sKey & "\" & sAppExe, "", sValue
    Set oItems = oWMI.ExecQuery _
                 ("Select * from CIM_Datafile Where Name = '" & Replace(sValue, "\", "\\") & "'")
    For Each oItem In oItems
        GetAppVersion = Split(oItem.Version, ".")(0) & "." & Split(oItem.Version, ".")(1)
    Next

Error_Handler_Exit:
    On Error Resume Next
    If Not oItem Is Nothing Then Set oItem = Nothing
    If Not oItems Is Nothing Then Set oItems = Nothing
    If Not oWMI Is Nothing Then Set oWMI = Nothing
    If Not oRegistry Is Nothing Then Set oRegistry = Nothing
    Exit Function

Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: GetAppVersion" & vbCrLf & _
           "Error Description: " & Err.Description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
           , vbOKOnly + vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function

Public Function encodeURI(ByVal sURI As String) As String
    Dim oScriptControl        As Object

    On Error GoTo Error_Handler

    Set oScriptControl = CreateObject("ScriptControl")
    oScriptControl.Language = "JScript"
    encodeURI = oScriptControl.Run("encodeURIComponent", sURI)

Error_Handler_Exit:
    On Error Resume Next
    If Not oScriptControl Is Nothing Then Set oScriptControl = Nothing
    Exit Function

Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: encodeURI" & vbCrLf & _
           "Error Description: " & Err.Description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
           , vbOKOnly + vbCritical, "An Error has Occured!"
End Function

and now with this code, with 1 line, we can retrieve the html of any signature.

For the default e-mail account you would simply do:

sSig = Outlook_GetSignature("john.doe@hotmail.com")