Option Explicit
Sub 出力1()
On Error GoTo Ending
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim i, MsgSt, obj, DSHT, DKyo, token
Set obj = CreateObject("Scripting.Dictionary") '社名とトークン記入欄
obj.Add "テストG1", "★ここにトークンを貼り付ける★"
obj.Add "テストG2", "★ここにトークンを貼り付ける★"
obj.Add "テストG3", "★ここにトークンを貼り付ける★"
Set DSHT = ThisWorkbook.Sheets("送信先リスト")
Set DKyo = DSHT.ListObjects("グループリスト").ListColumns("グループ名").DataBodyRange
MsgSt = DSHT.Range("b2")
If InStr(MsgSt, "%") >= 1 Then
MsgSt = Replace(MsgSt, "%", "・")
End If
If InStr(MsgSt, "&") >= 1 Then
MsgSt = Replace(MsgSt, "&", "・")
End If
For Each i In DKyo
If i.Offset(0, 1) = "●" Then
token = obj(i.Value)
Call Line送信(MsgSt, token)
End If
Next i
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
Ending:
MsgBox "エラー発生・メッセージ送信しておりません"
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub Line送信(Sndmsg, token As Variant)
Dim MS, objHTTP As Object, LineStr As Variant
LineStr = "message=" & Sndmsg
Set objHTTP = CreateObject("MSXML2.XMLHTTP")
objHTTP.Open "POST", "https://notify-api.line.me/api/notify", False
objHTTP.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
objHTTP.setRequestHeader "Authorization", "Bearer " & token
objHTTP.send LineStr
End Sub
Option Explicit
Sub 出力1()
On Error GoTo Ending
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim i, MsgSt, obj, DSHT, DKyo, token
Set obj = CreateObject("Scripting.Dictionary") '社名とトークン記入欄
obj.Add "テストG1", "★ここにトークンを貼り付ける★"
obj.Add "テストG2", "★ここにトークンを貼り付ける★"
obj.Add "テストG3", "★ここにトークンを貼り付ける★"
Set DSHT = ThisWorkbook.Sheets("送信先リスト")
Set DKyo = DSHT.ListObjects("グループリスト").ListColumns("グループ名").DataBodyRange
MsgSt = DSHT.Range("b2")
If InStr(MsgSt, "%") >= 1 Then
MsgSt = Replace(MsgSt, "%", "・")
End If
If InStr(MsgSt, "&") >= 1 Then
MsgSt = Replace(MsgSt, "&", "・")
End If
For Each i In DKyo
If i.Offset(0, 1) = "●" Then
token = obj(i.Value)
Call Line送信(MsgSt, token)
End If
Next i
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
Ending:
MsgBox "エラー発生・メッセージ送信しておりません"
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub Line送信(Sndmsg, token As Variant)
Dim MS, objHTTP As Object, LineStr As Variant
LineStr = "message=" & Sndmsg
Set objHTTP = CreateObject("MSXML2.XMLHTTP")
objHTTP.Open "POST", "https://notify-api.line.me/api/notify", False
objHTTP.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
objHTTP.setRequestHeader "Authorization", "Bearer " & token
objHTTP.send LineStr
End Sub