Chatwork to Excel [02]

' ===============================
' Chatwork 全件取得 Ver 1.0
' 古いタブは残す仕様
' ===============================
Sub FetchChatworkMessages()

    Dim Http As Object
    Dim JSON As Object
    Dim Item As Object
    Dim API_URL As String
    Dim ResponseText As String
    Dim i As Long
    Dim ws As Worksheet
    Dim sheetName As String

    ' === Chatwork API 設定 ===
    Const API_TOKEN As String = "YOUR_API_TOKEN"
    Const ROOM_ID As String = "YOUR_ROOM_ID"

    ' シート名（取得日時でユニーク化）
    sheetName = "Chatwork_" & Format(Now, "yyyymmdd_HHMMSS")

    ' 新しいシートを追加（最後尾に追加）
    Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    ws.Name = sheetName

    ' Chatwork API URL 作成（最新100件）
    API_URL = "https://api.chatwork.com/v2/rooms/" & ROOM_ID & "/messages?force=1&count=100"

    ' HTTPリクエスト
    Set Http = CreateObject("MSXML2.XMLHTTP")
    Http.Open "GET", API_URL, False
    Http.setRequestHeader "X-ChatWorkToken", API_TOKEN
    Http.Send

    ResponseText = Http.ResponseText

    ' JSON解析 (JsonConverter 必須)
    Set JSON = JsonConverter.ParseJson(ResponseText)

    ' ヘッダー作成
    ws.Cells(1, 1).Value = "投稿日時"
    ws.Cells(1, 2).Value = "投稿者名"
    ws.Cells(1, 3).Value = "本文"

    ' データ書き込み
    i = 2
    For Each Item In JSON
        ws.Cells(i, 1).Value = DateAdd("s", Item("send_time"), #1/1/1970#)
        ws.Cells(i, 2).Value = Item("account")("name")
        ws.Cells(i, 3).Value = Item("body")
        i = i + 1
    Next Item

    MsgBox "取得完了: " & i - 2 & " 件のメッセージを '" & sheetName & "' に書き込みました。", vbInformation

End Sub