Chatwork - メッセージの送信

ソースコード

' 送信先URI
Private Const END_POINT As String = "https://api.chatwork.com/v2/"

Private Function GetChatworkApiToken() As String
    GetChatworkApiToken = Environ$("CHATWORK_API_TOKEN")

    If Len(GetChatworkApiToken) = 0 Then
        Err.Raise vbObjectError + 1000, , "環境変数 CHATWORK_API_TOKEN が設定されていません。"
    End If
End Function

Public Function Api( _
        ByVal method As String, _
        ByVal url As String, _
        Optional ByVal param As String = "") As String

    Dim httpRequest As Object
    Set httpRequest = CreateObject("MSXML2.XMLHTTP")

    With httpRequest
        Call .Open(method, END_POINT & url, False)
        If method = "POST" Or method = "PUT" Then
            Call .setRequestHeader("Content-Type", "application/x-www-form-urlencoded")
        End If
        Call .setRequestHeader("X-ChatWorkToken", GetChatworkApiToken())
        Call .send(param)

        If .Status < 200 Or .Status >= 300 Then
            Err.Raise vbObjectError + 1001, , "Chatwork API Error: " & .Status & " - " & .responseText
        End If

        Api = .responseText
    End With
End Function

Public Function SendMessage(ByVal roomId As String, ByVal message As String) As String

    Dim url As String, param As String
    url = "rooms/" & roomId & "/messages"

    param = "body=" & Application.WorksheetFunction.EncodeURL(message)

    SendMessage = Api("POST", url, param)
End Function

解説

API トークンは、Chatwork のサービス連携画面で発行します。上記の例では、発行したトークンを環境変数 CHATWORK_API_TOKEN に設定してから実行します。

後は、上記のファンクションを以下のように呼び出すだけで取得できます。

Call SendMessage("00000", "このメッセージはExcelから送信されました")

“00000”の部分が送信先のグループチャットになります。グループチャットの取得については、以下の記事を参考にしてください。今回使った Api ファンクションを使えば、2 行足すだけで実装することができます。

送信後に取得できる HTTP ヘッダー情報などは、以下を参考にしてください。

Chatwork API ドキュメント - チャットにメッセージを投稿する

グループチャット名からメッセージを送信する

もしこの VBA プログラムを Excel 利用者向けに使用する場合、メッセージの送信のために、ルーム ID を指定しないといけないのは不親切です。

予めコンタクト一覧をリスト化しておくのもいいですが、リアルタイムに取得する場合のため、グループチャット名を指定してメッセージを送信できるファンクションもご紹介しておきます。

※上述した、コンタクト一覧を取得する記事内で紹介しているファンクション及び、JsonConverter を使うことを前提としています

Public Sub SendFromName(ByRef name As String, ByRef message As String)

    Dim records As Object
    Set records = JsonConverter.ParseJson(GetContacts)
    Dim record As Object
    For Each record In records
        If name = record("name") Then
            Call SendMessage(record("room_id"), message)
            Exit For
        End If
    Next
End Sub