【Excelだけ】サーバー無しでチャットボットを作る

Private Const END_POINT As String = "https://api.chatwork.com/v2/"

' ここにチャットボットとして使用したいアカウントのAPIトークンを貼り付けてください
Private Const API_TOKEN As String = "xxxxxxxxxxxxxxxxxxxxxxxxxx"

Public Function Api(ByRef method As String, ByRef url As String, ByRef 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", API_TOKEN)
        Call .send(IIf(param <> "", param, Null))

        Api = .responseText
    End With
End Function

Public Function GetContacts() As String
    GetContacts = Api("GET", "contacts", "")
End Function

Public Function GetMessages(ByRef roomId As String, Optional ByRef forces As Boolean = False) As String

    Dim url As String
    url = "rooms/" & roomId & "/messages?force=" & IIf(forces, "1", "0")

    GetMessages = Api("GET", url, "")
End Function

Public Function SendMessage(ByRef roomId As String, ByRef Message As String) As String

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

    param = "body=" & Message

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

Private Const BOT_ACCOUNT As String = "チャットボットとして使いたいアカウント名"

Dim rooms As Object

Public Sub Initialize()
    ' 対象のチャットルームを全て取得
    Set rooms = JsonConverter.ParseJson(Chatwork.GetContacts)

    Call Refresh
End Sub

Public Sub Refresh()
    ' 前回確認時の時刻を保持(Unix Timeを変換)
    Dim lastModified As Double, targetRange As Range
    Set targetRange = ThisWorkbook.Worksheets(1).Range("A1")
    If targetRange.value = "" Then
        targetRange.value = (DateDiff("s", "1970/1/1 9:00", Now) + 32400) / 86400 + 25569
    End If
    lastModified = (CDbl(targetRange.value) - 25569) * 86400 - 32400
    targetRange.value = (DateDiff("s", "1970/1/1 9:00", Now) + 32400) / 86400 + 25569

    ' 全てのチャットルームから、依頼がないか確認します
    Call CheckRequest(lastModified)

    ' 次回実行の予約
    Dim scheduled As Date
    scheduled = DateAdd("s", 300, Time)
    Application.OnTime scheduled, "Batch.Refresh"
End Sub

Private Sub CheckRequest(ByRef lastModified As Double)

    ' イテレータの準備
    Dim room As Object
    Dim messages As Object
    Dim message As Object

    ' ルーム単位でメッセージを受信し、新着情報がないか確認します
    For Each room In rooms

        Set messages = JsonConverter.ParseJson(Chatwork.GetMessages(room("room_id"), True))

        For Each message In messages

            ' 前回更新以降のメッセージでなければ処理しません
            If CLng(message("send_time")) <= lastModified Or message("account")("name") = BOT_ACCOUNT Then
                GoTo MESSAGE_CONTINUE
            End If

            ' 返信します
            Call Chatwork.SendMessage(room("room_id"), Message("body") & "に対するExcelからの返信です")

MESSAGE_CONTINUE:
        Next
    Next
End Sub