Last active
September 13, 2023 21:20
-
-
Save hidao80/30ee06cf88670f6082f69b4d547351c6 to your computer and use it in GitHub Desktop.
Outlook VBA を使って着信メールの件名と本文のフォーマットから問い合わせメールと判断できれば、本文を添付ファイルとして Chatwork へ投稿する
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| ' 定数値の定義 | |
| 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 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment