添付された Excel ファイルの内容を受信の際に本文に追記するマクロ

メッセージで以下のようなご質問をいただきました。

---

弊社では、あるシステムから定期的に Excel ファイルを添付したメッセージが送信されてきます。このメッセージの添付ファイルを毎回開くのが手間なのですが、受信時に本文へ Excel のデータを自動的に埋め込むことはできないでしょうか?

---

Excel には HTML 形式で保存する機能がありますので、受信時に添付された Excel ファイルを HTML 形式で保存し、その HTML データを本文に追記することでご要望の動作が可能となるでしょう。

マクロは以下の通りです。

' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    ImportExcelSheet EntryIDCollection
End Sub
'
Sub ImportExcelSheet(EntryIDCollection)
    Const REPORT_SUBJECT = "Daily Report *" ' マクロを実行する必要があるメッセージの件名を指定します。
    Dim objItem 'As MailItem
    Set objItem = Session.GetItemFromID(EntryIDCollection)
    ' 通常のメッセージでなければ無視
    If objItem.MessageClass <> "IPM.Note" Then
        Exit Sub
    End If
    ' 条件に合致するかどうかと添付ファイルがあるかのチェック
    If objItem.Subject Like REPORT_SUBJECT And _
        objItem.Attachments.Count = 1 Then
        Dim objAttach As Attachment
        Set objAttach = objItem.Attachments(1)
        ' 添付ファイルが Excel かどうかのチェック
        If objAttach.FileName Like "*.xls" Or objAttach.FileName Like "*.xls?" Then
            Dim objFSO 'As FileSystemObject
            Dim objShell 'As WshShell
            Dim strFileName As String
            Dim objWookbook 'As excel.Workbook
            Dim stmCss 'As TextStream
            Dim stmHtml 'As TextStream
            ' 一時フォルダに格納するためのファイル名を作成
            Set objShell = CreateObject("WScript.Shell")
            strFileName = objShell.ExpandEnvironmentStrings("%temp%\" & objAttach.FileName)
            Set objShell = Nothing
            ' 同名のファイルがすでに存在する場合は削除
            Set objFSO = CreateObject("Scripting.FileSystemObject")
            If objFSO.FileExists(strFileName) Then
                objFSO.DeleteFile strFileName, True
            End If
            If objFSO.FileExists(strFileName & ".htm") Then
                objFSO.DeleteFile strFileName & ".htm", True
            End If
            ' 添付ファイルを保存
            objAttach.SaveAsFile strFileName
            Set objAttach = Nothing
            ' 保存したファイルを開く
            Set objWookbook = GetObject(strFileName)
            ' 最初のワークシートを HTML 形式で保存
            objWookbook.Worksheets(1).SaveAs strFileName & ".htm", 44 ' 44 = xlHtml
            objWookbook.Close
            Set objWorkbook = Nothing
            ' CSS と HTML ファイルを読み込み
            Set stmCss = objFSO.OpenTextFile(strFileName & ".files\stylesheet.css")
            Set stmHtml = objFSO.OpenTextFile(strFileName & ".files\sheet001.htm")
            ' HTML 本文の最後に HTML として保存した Excel ファイルを追加
            objItem.HTMLBody = objItem.HTMLBody & Replace(stmHtml.ReadAll, _
                "<link rel=Stylesheet href=stylesheet.css>", _
                "<style>" & vbCrLf & stmCss.ReadAll & vbCrLf & "</style>" & vbCrLf)
            objItem.Save
            Set objItem = Nothing
            stmCss.Close
            stmHtml.Close
            Set stmCss = Nothing
            Set stmHtml = Nothing
            Set objFSO = Nothing
        End If
    End If
End Sub

マクロの登録方法やメニューへの追加について