Outlook VBA を使って着信メールの件名と本文のフォーマットから問い合わせメールと判断できれば、本文を添付ファイルとして Chatwork へ投稿する

sendToChatworkForOutlook.vba

' 定数値の定義
Const adTypeBinary = 1
Const adTypeText = 2
Const adLongVarBinary = 205
Const CHATWORK_TOKEN = "" ' Chatwork 通知用の API トークン。例）"123456789abcdef"
Const ROOM_NO = "" ' 通知を送信するチャンネルのルーム ID。例）"1234567890"
Const BOUNDARY = "011000010111000001101001" ' ファイルアップデート API のメッセージと添付ファイルのデータを分ける目印（HTTP 準拠）
Const CLOSE_BOUNDARY = vbCrLf & "--" & BOUNDARY & "--" & vbCrLf ' multipart/form-data の終端を表す文字列（HTTP 準拠）

' メール着信を Outlook が検出した場合に実行される Outlook 規定のサブプロシージャ。
' この中で Chatwork に投稿するようにしたい
'
' @param String EntryIDCollection 着信メールの情報
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Dim myNameSpace
    Dim objId
    Set myNameSpace = GetNamespace("MAPI") ' MAPI は Outlook のメールを操作するためのオブジェクトを取得する
    Set objId = myNameSpace.GetItemFromID(EntryIDCollection) ' 着信メールのデータを取得する

    ' メールの件名に "【お問い合わせ】" が含まれている場合、
    ' そのメールは問い合わせメールとして Chatwork に投稿しようとする
    ' それ以外の件名のメールはここでは処理しない
    If InStr(objId.Subject, "【お問い合わせ】") > 0 Then
        ''' 本文を抽出する '''
        ' メール本文の改行文字を変換して、1行の文字列として処理しやすくする
        inquiryBody = Replace(objId.Body, vbCrLf, "\n")
        ' "メッセージ本文: "は含める
        inquiryBody = Right(inquiryBody, Len(inquiryBody) - InStr(1, inquiryBody, "メッセージ本文: ") + 1)

        ' メール本文から問い合わせの本文が抽出できなかったときは意図しないフォーマットのメールなので
        ' 偶然メールの件名が一致した可能性を考慮して投稿せずに処理をやめる
        If inquiryBody = "" Then Exit Sub

        ''' 問い合わせの題名を取得する '''
        ' メール本文の改行文字を変換して、1行の文字列として処理しやすくする
        title = Replace(objId.Body, vbCrLf, "\n")
        ' "題名: "は含める
        title = Right(title, Len(title) - InStr(1, title, "題名: ") + 1)
        ' "題名: "の次に来る最初の改行文字までを抽出する
        title = Left(title, InStr(1, title, "\n") - 1)

        ' メール本文から問い合わせの題名が抽出できなかったときは意図しないフォーマットのメールなので
        ' 偶然メールの件名が一致した可能性を考慮して投稿せずに処理をやめる
        If title = "" Then Exit Sub

        ' Chatwork に投稿する
        If sendToChatwork(inquiryBody, title) = True Then
            ' 投稿に成功したら当該メールは既読にする
            ' 投稿に失敗したらここには来ないので未読のままになる
            objId.UnRead = False
        End If
    End If
End Sub

' 問い合わせメールを着信した時、Chatwork へ問い合わせメールの本文を
' 添付ファイルにして投稿するファンクション
'
' @param  String  inquiryBody 問い合わせ内容の本文だけ
' @param  String  title       問い合わせ内容の題名だけ
' @return Boolean             Chatwork API の戻り値に "file_id" という文字列が含まれていれば True
'                             ただし、投稿に成功したかどうかはわからない
Function sendToChatwork(ByVal inquiryBody As String, ByVal title As String)
    ' Chatwork API でチャットワークに投稿する文章を作る
    notificationBody = "問い合わせメールを受信しました。" & vbCrLf

    ' 問い合わせの内容全文をそのまま Chatwork に流すとすぐ画面外へ行ってしまうので、
    ' 本文は抽出して添付ファイルとして送信する
    ' 本文の抽出はこのファンクションの呼び出し元で処理済みで、引数の inquiryBody に入っている
    ' ファイル名を日本語にすると面倒なので、ここでは英数字のみの"inquiryBody_{年月日_時分秒}.txt"とする
    inquiryFileNmae = "inquiryBody_" & Format(Now, "yyyymmdd_hhmmss") & ".txt"

    ' 添付ファイルのバイナリデータ部のヘッダ
    ' VBA はバイナリデータを Shift_JIS のストリームとして処理しないとデータが破壊されるようなので
    ' メールに使われる UTF-8 の文字列はバイナリデータに変換してから Shift_JIS のストリームに混ぜて送信する
    ' これは VBA が半角文字を Shift_JIS としてしか送信できないようなのと、Chatwork API が UTF-8 以外の
    ' 文字コードの日本語を受け取ると文字化けするので苦肉の策
    params = ""
    params = params + "--" + BOUNDARY + vbCrLf
    params = params + "Content-Disposition: form-data; name=""file"";"
    ' ファイル名はここで指定しないと添付ファイルとして送信できない。日本語ファイル名をつけるときはこのままでは送れないので注意。
    params = params + "filename=""" + inquiryFileNmae + """" + vbCrLf
    params = params + "Content-Type: application/octet-stream" + vbCrLf + vbCrLf

    ' Chatwork に直に表示されるメッセージ部のヘッダ
    params2 = ""
    params2 = params2 + vbCrLf + "--" + BOUNDARY + vbCrLf
    params2 = params2 + "Content-Disposition: form-data; name=""message""" + vbCrLf + vbCrLf

    ''' 送信データの作成 '''
    Dim stream
    Set stream = CreateObject("ADODB.Stream")
    With stream
        ' Shift_JIS のストリームを用意する
        .Type = adTypeText
        .Charset = "Shift_JIS"
        .Open

        ' 添付ファイルのヘッダを Shift_JIS の文字列で書き込み
        ' ファイル名に日本語が入る場合はファイル名だけを UTF-8 のバイナリデータにして書き込むこと
        ChangeStreamType stream, adTypeText
        .WriteText params

        ' 添付ファイルのバイナリデータを書き込み
        ChangeStreamType stream, adTypeBinary
        ' UTF-8 の文字列を Shift_JIS のバイナリデータに変換する自作関数。定義はこのプロシージャの下にある
        .Write UTF8StrToSJISBin(Replace(inquiryBody, "\n", vbCrLf))

        ' メッセージのヘッダを Shift_JIS の文字列で書き込み
        ChangeStreamType stream, adTypeText
        .WriteText params2

        ' データの終端を表すバウンダリーを Shift_JIS の文字列で書き込み
        .WriteText CLOSE_BOUNDARY

        ' ストリームに書き込んだデータを先頭から全てバイナリデータとして読み込み、送信データとする
        ChangeStreamType stream, adTypeBinary
        .Position = 0 ' ストリームの処理開始位置を先頭に戻す
        formData = stream.Read ' 送信データをストリームから読み込んでバイト配列変数に格納する
        .Close
    End With

    ''' Chatwork API に送信する '''
    With CreateObject("WinHttp.WinHttpRequest.5.1")
        ' Chatwork API のファイルアップロード用エンドポイント
        .Open "POST", "https://api.chatwork.com/v2/rooms/" & ROOM_NO & "/files", False
        ' ファイル添付投稿用の Content-Type を指定する。Chatwork API の仕様による
        .setRequestHeader "Content-Type", "multipart/form-data; boundary=" & BOUNDARY
        ' Chatwork API の認証用トークンをリクエストヘッダにつける
        .setRequestHeader "X-Chatworktoken", CHATWORK_TOKEN
        .Send formData    ' データの送信

        ' Chatwork API からの戻り値を取得する
        response = .ResponseText
    End With

    ' Chatwork API の戻り値に "file_id" という文字列が含まれているかどうかで
    ' Chatwork API の実行に成功したかどうかを判定する
    ' ただし、アップロードに成功したことはわかるが投稿に成功したかどうかはわからない
    sendToChatwork = False
    If InStr(response, "file_id") > 0 Then
        ' ファイルのアップロードに成功したらこのプロシージャは True を返す
        ' 失敗したら上であらかじめセットしている False が返る
        sendToChatwork = True
    End If
End Function

' ストリームに書き込むデータの種類を途中でバイナリとテキストで切り替えてもデータが壊れないようにする
' 拾いものなので詳細不明
'
' @param ADODB.Stream stream データストリームオブジェクト
' @param Integer type 1:adTypeBinary, 2:adTypeText
Function ChangeStreamType(ByRef stream, ByVal types As Integer)
    pos = stream.Position ' 現在の書き込み位置の終端を記憶
    stream.Position = 0   ' 先頭に戻さないと Type を変更できない
    stream.Type = types   ' データストリームの書き込みデータ種類を変更
    stream.Position = pos ' 書き込み位置を元に戻し、続きに書き込めるようにする
    Set ChangeStreamType = stream
End Function

' UTF-8 エンコードの文字列をバイト配列に変換するファンクション
'
' @param  String str UTF-8 エンコードの文字列
' @return Byte()     UTF-8 エンコードの文字列の先頭から BOM を外したバイト配列
Function UTF8StrToSJISBin(ByVal str As String)
    With CreateObject("ADODB.Stream")
        .Type = adTypeText       ' ストリームの書き込みデータ種類をテキストにする
        .Charset = "UTF-8"       ' ストリームの文字コードを UTF-8 にする
        .Open                    ' ストリームを開く
        .WriteText str           ' データストリームに UTF-8 エンコードの文字列を書き込む
        .Position = 0            ' 先頭に戻さないと Type を変更できない
        .Type = adTypeBinary     ' データストリームの書き込みデータ種類をバイナリにする
        .Position = 3            ' VBA が使う UTF-8 文字列の先頭にある BOM の 3バイト分を捨てる
        UTF8StrToSJISBin = .Read ' データストリームからバイナリデータを読み込み、バイト配列として返す
        .Close
    End With
End Function