[ExcelVBA]Chatworkの指定したルームにメッセージを一斉送信する方法

Sub ボタン1_Click()
  'チェックされたルームに同一メッセージを送信する
  Dim API_TOKEN As String
  Dim ROOM_ID As String
  Dim BODY_STR As String
  Dim MROW As Long
  
  API_TOKEN = Worksheets("SEND").Range("G5").Value
  If API_TOKEN <> "" Then
    BODY_STR = Worksheets("SEND").Range("A1").Value
    If BODY_STR <> "" Then
      MROW = 6
      Do Until Worksheets("SEND").Cells(MROW, 3).Value = ""
        If Worksheets("SEND").Cells(MROW, 1).Value <> "" Then
          ROOM_ID = Worksheets("SEND").Cells(MROW, 3).Value
          Call CHATWORK_SEND_MSG(API_TOKEN, ROOM_ID, BODY_STR)
        End If
        MROW = MROW + 1
      Loop
    Else
      MsgBox "送信本文が空白なので処理をキャンセルします"
    End If
  Else
    MsgBox "APIトークンが空白なので処理をキャンセルします"
  End If
End Sub
Sub ボタン2_Click()
  Worksheets("SEND").Range("A1").Value = ""
End Sub
Sub ボタン3_Click()
  'ルーム名とルームIDを取得する
  Dim API_TOKEN As String
  Dim httpReq As XMLHTTP60
  Set httpReq = New XMLHTTP60
  Dim STR_RES As String
  Dim STR_LEFT, STR_RIGHT As String
  Dim ROOMROW As Long
  Dim ROOMID, ROOMNAME, ROOMNAME_STR As String
  Dim STR_V As Variant
  
  ROOMROW = 6
  Do Until Worksheets("SEND").Cells(ROOMROW, 3).Value = ""
    Worksheets("SEND").Range("A" & ROOMROW & ":C" & ROOMROW).Clear
    ROOMROW = ROOMROW + 1
  Loop
  
  API_TOKEN = Worksheets("SEND").Range("G5").Value
  If API_TOKEN <> "" Then
    With httpReq
      .Open "GET", "https://api.chatwork.com/v2/rooms"
      .setRequestHeader "X-ChatWorkToken", API_TOKEN
      .Send
    
      'レスポンス待機
      Do While .readyState < 4
        DoEvents
      Loop
      
      If .Status = "200" Then
        STR_RES = .responseText
        
        ROOMROW = 6
        'ROOMIDとROOM名を抜き出す
        Do Until InStr(STR_RES, "room_id") = 0
          ROOMID = ""
          ROOMNAME = ""
          STR_LEFT = Left(STR_RES, InStr(STR_RES, "}")) 'ROOMの情報を１個取り出し
          STR_RIGHT = Mid(STR_RES, InStr(STR_RES, "}") + 2, Len(STR_RES) - InStr(STR_RES, "}") - 1) '残りの情報を格納
          ROOMID = Mid(STR_LEFT, InStr(STR_LEFT, ":") + 1, InStr(STR_LEFT, ",") - InStr(STR_LEFT, ":") - 1) 'ROOMIDを抜き出す
          STR_LEFT = Mid(STR_LEFT, InStr(STR_LEFT, ",") + 1, Len(STR_LEFT) - InStr(STR_LEFT, ",") - 1)
          ROOMNAME_STR = Mid(STR_LEFT, InStr(STR_LEFT, ":") + 1, InStr(STR_LEFT, ",") - InStr(STR_LEFT, ":") - 1) 'ROOM名の文字列を抜き出す
          ROOMNAME_STR = Replace(ROOMNAME_STR, """", "") 'ダブルクォーテーション除去
          If InStr(ROOMNAME_STR, "\u") > 1 Then '先頭のエスケープシーケンスじゃない文字列対応
            ROOMNAME = Left(ROOMNAME_STR, InStr(ROOMNAME_STR, "\u") - 1)
            ROOMNAME_STR = Mid(ROOMNAME_STR, InStr(ROOMNAME_STR, "\u"), Len(ROOMNAME_STR) - InStr(ROOMNAME_STR, "\u") + 1)
          End If
          STR_V = Split(ROOMNAME_STR, "\u") 'UNICODEエスケープシーケンスを通常の文字列に変換
          For N = 1 To UBound(STR_V)
            If Len(STR_V(N)) = 4 Then
              ROOMNAME = ROOMNAME & ChrW(Val("&H" & STR_V(N)))
            Else 'エスケープシーケンスと通常の文字が混在している場合の処理
              ROOMNAME = ROOMNAME & ChrW(Val("&H" & Left(STR_V(N), 4))) & Mid(STR_V(N), 5, Len(STR_V(N)) - 4)
            End If
          Next
        
          Worksheets("SEND").Cells(ROOMROW, 2).Value = ROOMNAME
          Worksheets("SEND").Cells(ROOMROW, 3).Value = ROOMID
        
          ROOMROW = ROOMROW + 1
          STR_RES = STR_RIGHT
        Loop
        Worksheets("SEND").Range("A6:C" & ROOMROW - 1).HorizontalAlignment = xlCenter
        Worksheets("SEND").Range("A6:C" & ROOMROW - 1).VerticalAlignment = xlCenter
        Worksheets("SEND").Range("A6:C" & ROOMROW - 1).ShrinkToFit = True
        Worksheets("SEND").Range("A6:C" & ROOMROW - 1).Borders.LineStyle = True
        MsgBox "取得完了"
      Else
        MsgBox "データ取得エラー"
      End If
    
    End With
  Else
    MsgBox "APIトークンが空白です。処理をキャンセルします"
  End If
  
  Set httpReq = Nothing
  
End Sub

Sub CHATWORK_SEND_MSG(ByVal API_TOKEN As String, ByVal ROOM_ID As String, ByVal MSG_BODY As String)
  Dim httpReq As XMLHTTP60
  Set httpReq = New XMLHTTP60
  
  With httpReq
    .Open "POST", "https://api.chatwork.com/v2/rooms/" & ROOM_ID & "/messages"
    .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    .setRequestHeader "X-ChatWorkToken", API_TOKEN
    .Send "body=" + MSG_BODY
    
    If .Status <> "200" Then
      MsgBox "送信エラー:" & .Status
    End If
  End With

  Set httpReq = Nothing

End Sub