Chatwork to Execl [03]

' ===============================
' Chatwork 全件取得 Ver 1.0
' API_TOKEN, ROOM_ID をシート1から取得
' 古いタブは残す仕様
' ===============================
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
    Dim token As String
    Dim roomId As String

    ' === API_TOKEN, ROOM_ID をシート1から取得 ===
    With ThisWorkbook.Sheets(1)
        token = Trim(.Range("A1").Value)   ' A1 に API_TOKEN
        roomId = Trim(.Range("A2").Value)  ' A2 に ROOM_ID
    End With

    If token = "" Or roomId = "" Then
        MsgBox "シート1の A1(API_TOKEN)、A2(ROOM_ID) に値を入力してください。", vbExclamation
        Exit Sub
    End If

    ' シート名（取得日時でユニーク化）
    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/" & roomId & "/messages?force=1&count=100"

    ' HTTPリクエスト
    Set Http = CreateObject("MSXML2.XMLHTTP")
    Http.Open "GET", API_URL, False
    Http.setRequestHeader "X-ChatWorkToken", 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