スキルアップ・問題解決なら、モーグにおまかせ！

メール本文をPDFにしたものを利用したいため、スクリプトの試作をしています。
ご意見をお聞かせください。
 
 
・Outlookメール本文をそのままのレイアウトでPDF化したい
・メール本文はHTML構文の場合も含むため、現状のスクリプトでは画像が欠落して文字だけPDFに含まれる
・Outlookメール本文を手動でコピーし、Wordに張り付けると問題なく貼り付けられるが、スクリプトで張る方法が不明（リッチテキストのような張り付け方だときれいに出るがスクリプト参考例が見つからない）
・Wordに張り付ける以外の方法でPDF化も検討したが、Outlookの.PrintOutメソッドを使用する場合、引数の割り当てができないのでPDFとして出力する操作を自動化できないと思われる
・ChatGPTに聞くと、WordのRangeにHTMLをそのまま流しこめと言われるが、それをやるとタグが表示されてしまい、レイアウトが崩れる
 

Option Explicit

' フォルダ選択ダイアログ
Function GetFolder() As String
    Dim appWord As Object ' Word.Application
    Dim dlgFile As FileDialog
    Dim wshShell As Object ' WScript.Shell
    
    Set appWord = CreateObject("Word.Application")
    Set dlgFile = appWord.FileDialog(Office.msoFileDialogFolderPicker)
    Set wshShell = CreateObject("WScript.Shell")
    
    ' ダイアログのタイトルを指定します
    dlgFile.Title = "保存先の指定"
    
    ' ダイアログが開かれた際に最初に表示されるフォルダーを指定します。
    dlgFile.InitialFileName = wshShell.SpecialFolders("MyDocuments") & "\"
    If dlgFile.Show = -1 Then
        GetFolder = dlgFile.SelectedItems(1) & "\"
    Else
        GetFolder = ""
    End If
End Function

Sub SaveMailAsPDF()
    Dim olItem As mailItem
    Dim wdApp As Object ' Word.Application
    Dim wdDoc As Object ' Word.Document
    
    Dim savePath As String
    Dim pdfFilePath As String

    ' ポップアップしているメールを取得
    If TypeName(Application.ActiveInspector.CurrentItem) = "MailItem" Then
        Set olItem = Application.ActiveInspector.CurrentItem
    Else
        MsgBox "メールが選択されていません。", vbExclamation
        Exit Sub
    End If
    
    ' 保存先フォルダを選択
    savePath = GetFolder()
    If savePath <> "" Then
        pdfFilePath = savePath & olItem.Subject & ".pdf"
    Else
        MsgBox "フォルダ未選択につき終了", vbExclamation
        Exit Sub
    End If
    
    
    ↓↓↓↓↓↓およそ修正が必要な箇所
    
    ' メールの内容をWordドキュメントとして開く
    Set wdDoc = olItem.GetInspector.WordEditor
    
    ↑↑↑↑↑↑およそ修正が必要な箇所
    
    ' WordドキュメントをPDF形式で保存
    wdDoc.ExportAsFixedFormat OutputFileName:=pdfFilePath, ExportFormat:=17 ' 17はPDF形式の定数
    
    ' オブジェクト解放
    wdDoc.Close False
    wdApp.Quit
    Set wdDoc = Nothing
    Set wdApp = Nothing
    Set olItem = Nothing
    
End Sub

以下はChatGPT製のダメな修正案です。
このようにHTML構文を直接流し込むと画面にそのまま表示されてしまいます。
 

Sub SaveMailAsPDF()
    Dim olItem As MailItem
    Dim wdApp As Object ' Word.Application
    Dim wdDoc As Object ' Word.Document
    Dim htmlBody As String
    Dim savePath As String
    Dim pdfFilePath As String

    ' ポップアップしているメールを取得
    If TypeName(Application.ActiveInspector.CurrentItem) = "MailItem" Then
        Set olItem = Application.ActiveInspector.CurrentItem
    Else
        MsgBox "メールが選択されていません。", vbExclamation
        Exit Sub
    End If

    ' 保存先フォルダを選択
    savePath = GetFolder()
    If savePath <> "" Then
        pdfFilePath = savePath & olItem.Subject & ".pdf"
    Else
        MsgBox "フォルダ未選択につき終了", vbExclamation
        Exit Sub
    End If

    ' Wordアプリケーションを作成
    Set wdApp = CreateObject("Word.Application")
    Set wdDoc = wdApp.Documents.Add

    ' メールのHTML本文を取得
    htmlBody = olItem.HTMLBody

    ' HTML内容をWordに挿入
    wdDoc.Range.InsertBefore htmlBody

    ' WordドキュメントをPDF形式で保存
    wdDoc.ExportAsFixedFormat OutputFileName:=pdfFilePath, ExportFormat:=17 ' 17はPDF形式の定数

    ' オブジェクト解放
    wdDoc.Close False
    wdApp.Quit
    Set wdDoc = Nothing
    Set wdApp = Nothing
    Set olItem = Nothing
End Sub