excel VBAを使用してOutlookで画像からなる署名を追加する

Question

画像に署名を追加しない以外は、動作するコードがあります。ここの画像は、会社のロゴとソーシャルネットワーキングのアイコンです。

このコードはExcel VBAで記述されていますが、目的はOutlook電子メールの画像として範囲をコピーしてコピーすることです。

Dim Rng      As Range 
Dim outlookApp    As Object 
Dim outMail     As Object 

Dim wordDoc     As Word.Document 
Dim LastRow     As Long 
Dim CcAddress    As String 
Dim ToAddress    As String 
Dim i      As Long 
Dim EndRow     As String 

Dim Signature    As String 

'// Added Microsoft word reference 

Sub Excel_Image_Paste_Testing() 

    On Error GoTo Err_Desc 

    '\\ Define Endrow 
    EndRow = Range("A65000").End(xlUp).Row 

    '\\ Range for copy paste as image 
    Set Rng = Range("A22:G" & EndRow) 
    Rng.Copy 

    '\\ Open a new mail item 
    Set outlookApp = CreateObject("Outlook.Application") 
    Set outMail = outlookApp.CreateItem(0) 

    '\\ Display message to capture signature 
    outMail.Display 

    '\\ This doesnt store images because its defined as string 
    'Problem lies here 
    Signature = outMail.htmlBody 

    '\\ Get its Word editor 
    Set wordDoc = outMail.GetInspector.WordEditor 
    outMail.Display 

    '\\ To paste as picture 
    wordDoc.Range.PasteAndFormat wdChartPicture 

    '\\ TO and CC Address 
    CcAddress = "xyz@gmail.com" 
    ToAddress = "abc@gmail.com" 

    '\\ Format email 
    With outMail 
     .htmlBody = .htmlBody & Signature 
     .Display 
     .To = ToAddress 
     .CC = CcAddress 
     .BCC = "" 
     .Subject = "Email Subject here" 
     .readreceiptrequested = True 
    End With 

    '\\ Reset selections 
    Application.CutCopyMode = False 
    Range("B1").Select 

    Exit Sub 
Err_Desc: 
    MsgBox Err.Description 

End Sub 

このファイルは多くの人に配布される予定であるため、独自のデフォルト署名が付いていることに注意してください。だから、私はデフォルトの.htm署名名を知りません。

（「のAppData \ローミング\マイクロソフト\署名」）

人々はまた、多くの署名を持っているかもしれませんが、私の目標は、彼らのデフォルトの署名をキャプチャすることです。

Error signature picture after running the code

エラー上記のリンク上の1対下図のように私の署名がされている必要があります。このコードで

Answer 1

我々は、ユーザーが問題の画像が別のフォルダに格納されているので、我々は直接このファイルのHTML本体を使用できないことですAppData\Roaming\Microsoft\Signatures

から.Htmファイルを選択できます以下に示すようにfilename_filesという名前です。

ものHtmlBodyで述べパスは不完全です。ここでは以下の画像に

を参照してください。HTML本文内のパスを修正します、私が書いた迅速な機能

'~~> 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 & "_files" 
    '~~> Full Path of Folder 
    FullPath = Left(r, InStrRev(r, "\")) & foldername 

    '~~> Replace incomplete path with full Path 
    FixHtmlBody = Replace(MyData, foldername, FullPath) 
End Function 

ここでは完全な手順です。私はコードをコメントしました。まだ問題がある場合は教えてください。

Sub Sample() 
    Dim oOutApp As Object, oOutMail As Object 
    Dim strbody As String, FixedHtmlBody As String 
    Dim Ret 

    '~~> Ask user to select the htm file 
    Ret = Application.GetOpenFilename("Html Files (*.htm), *.htm") 

    If Ret = False Then Exit Sub 

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

    Set oOutApp = CreateObject("Outlook.Application") 
    Set oOutMail = oOutApp.CreateItem(0) 

    strbody = "<H3><B>Dear Blah Blah</B></H3>" & _ 
       "More Blah Blah<br>" & _ 
       "<br><br><B>Thank you</B>" & FixedHtmlBody 

    On Error Resume Next 
    With oOutMail 
     .To = "Email@email.com" '<~~ Change as applicable 
     .CC = "" 
     .BCC = "" 
     .Subject = "Example on how to insert image in signature" 
     .HTMLBody = .HTMLBody & "<br>" & strbody 
     .Display 
    End With 
    On Error GoTo 0 

    Set oOutMail = Nothing 
    Set oOutApp = Nothing 
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 & "_files" 

    '~~> 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, 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 

アクションで