Pre-Office 2016 document emailing macro

EmailDocument.vba

Sub EmailDocument()
    On Error Resume Next

    If Len(ActiveDocument.Path) = 0 Then
        ActiveDocument.Save
    End If

    Dim RanOutlook As Boolean
    
    Dim Outlook As Outlook.Application
    Set Outlook = GetObject(, "Outlook.Application")
    If Err <> 0 Then
        Set Outlook = CreateObject("Outlook.Application")
        RanOutlook = True
    End If

    Dim DocumentName As String
    DocumentName = Left(ActiveDocument.Name, InStr(ActiveDocument.Name, ".") - 1)

    Dim Body As String
    Body = "<span>Please find " & DocumentName & " attached.<p/>Regards,</span>"

    Dim SignatureFile As String
    SignatureFile = Environ("appdata") & "\Microsoft\Signatures\Signature.htm"

    Dim Signature As String
    If Dir(SignatureFile) <> "" Then
        Dim fso As Object
        Set fso = CreateObject("Scripting.FileSystemObject")
        Dim ts As Object
        Set ts = fso.GetFile(SignatureFile).OpenAsTextStream(1, -2)
        Signature = ts.readall
        ts.Close
    Else
        Signature = ""
    End If

    Dim MailItem As Outlook.MailItem
    Set MailItem = Outlook.CreateItem(olMailItem)
    With MailItem
        .Subject = StatementName
        .HTMLBody = Body & "" & Signature
        .Attachments.Add Source:=ActiveDocument.FullName, Type:=olByValue
        .Display
    End With

    If RanOutlook Then
        Outlook.Quit
    End If

    Set MailItem = Nothing
    Set Outlook = Nothing
End Sub