EXCEL VBAでLINEグループへメッセージ+画像送信

はじめに

EXCEL VBAでLINEにメッセージを送信する方法をWEB検索すると色々出てきますが、画像を送る方法があまり見つかりません。見つかっても「curl」を使う方法でcurlのインストールが必要になるので他の人に使ってもらうには少し面倒です。
画像を送りたい場合は、Content-Typeをmultipart/form-dataにしてあげる必要があり、少々やっかいなところではあります。

ダウンロード

EXCEL VBAからLINEグループへメッセージ＋画像送信

1 ファイル 29.32 KB

ダウンロード

※ダウンロード後に任意の場所に解凍してご利用ください。

※解凍後にはじめて起動した際にセキュリティの警告が表示されると思いますので、「コンテンツの有効化」ボタンを押下してご利用ください。

※「セキュリティリスト Microsoft では～～マクロの実行をブロックしています。」が表示される場合は、EXCELを終了してから解凍したファイルを右クリックして [プロパティ] ダイアログの [全般] タブの [ブロック解除] チェックボックスをオンにしてください。

ちょこっと解説

LINEへメッセージを送信するためには、LINEグループのアクセストークンを取得して、LINE Notifyをグループに追加してあげる必要があります。手順については、Python3でメールを受信してLINEグループへ通知の「LINE通知の準備」をご覧ください。

上記の画面から送信実行ボタンを押すと画像とメッセージが送信できるようにしました。
画像は参照ボタンを押すと選択画面が表示されて画像を選択できます。選択できる画像はPNGとJPG（jpeg）のみです。
メッセージはテキストボックスコントロールにしてみました。

LINEグループへの送信は、https://notify-api.line.me/api/notifyに以下の情報をPOSTします。

-------AkiratinTechMemo1706345304
Content-Disposition: form-data; name="message"
Content-Type: text/plain

あきらちんの技術メモ
メッセージ：
悔しいけれど
おまえに夢中
ギャランドゥ
-------AkiratinTechMemo1706345304
Content-Disposition: form-data; name="imageFile"; filename="jaganyan_480x480.png" 
Content-Type: image/png

＜画像バイナリ＞
-------AkiratinTechMemo1706345304--

テキスト情報と画像のバイナリ情報を結合するためにADODB.Streamを利用するところが標準モジュールVBAでのポイントとなります。

送信結果は以下のようになります。

VBA

シート

Option Explicit

'' 画像参照ボタン押下
Private Sub cmdPicture_Click()
    Dim txtImg As String
    
    txtImg = Application.GetOpenFilename(Filefilter:="画像,*.png;*.jpg")
    If txtImg <> "False" Then
        Range("B5").Value = txtImg
    End If
End Sub

'' 添削メッセージ送信ボタン押下
Private Sub cmdSend_Click()
    Dim strData As String
    Dim strImg As String
    Dim strToken As String
    Dim strName As String
    
    ' 名前
    strName = Range("D1").Value
    
    ' トークン
    strToken = Range("B3").Value
    
    ' 画像
    strImg = Range("B5").Value
    
    ' 添削データ
    strData = "" & vbCrLf
    strData = strData & Range("A7").Value & vbCrLf
    strData = strData & txtKanso.Text

    Debug.Print strData
    
    If strToken = "" Then
        MsgBox "トークンが設定されていません。", vbCritical, "エラー"
        Exit Sub
    End If
    If strImg = "" Then
        MsgBox "画像ファイルを設定してください。", vbInformation, "情報"
        Exit Sub
    End If
    
    Call SendLine(strToken, strData, strImg, strName)
End Sub

シート側のVBAはシートに入力された情報を取得して標準モジュールのSendLineを呼び出す内容です。

標準モジュール

Option Explicit

Public Const LINE_SEP As String = "－－－－－－－－－－－－－－"

' LINEグループ送信
Public Sub SendLine(token As String, strMsg As String, strFile As String, strName As String)
    Dim http As Object
    Dim strRes As String
    Dim strBoundary As String
    Dim strm As Object
    Dim strmBin As Object
    Dim strmWkBin As Object
    Dim strImgType As String
    Dim strFileEx As String
    
    Set strm = CreateObject("ADODB.Stream")
    Set strmBin = CreateObject("ADODB.Stream")
    Set strmWkBin = CreateObject("ADODB.Stream")
    
    strBoundary = "-----AkiratinTechMemo" & DateDiff("s", "1970/1/1 0:00:00", DateAdd("h", -9, Now))
    
    Set http = CreateObject("MSXML2.XMLHTTP")
    Call http.Open("POST", "https://notify-api.line.me/api/notify", False)
    Call http.SetRequestHeader("Authorization", "Bearer " & token)
    'http.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    Call http.SetRequestHeader("Content-Type", "multipart/form-data; boundary=" & strBoundary)
    
    ' 拡張子判定
    strFileEx = GetFileExtension(strFile)
    strImgType = "image/" & strFileEx
    
    ' バイナリ変換用ストリーム
    strmWkBin.Open
    strmWkBin.Type = 1
    
    ' バイナリストリーム
    strmBin.Open
    strmBin.Type = 1
    
    ' テキストストリーム
    strm.Open
    'strm.Charset = "shift_jis"
    strm.Charset = "utf-8"
    
    ' メッセージセクション
    strm.WriteText "--" & strBoundary & vbCrLf
    strm.WriteText "Content-Disposition: form-data; name=""message""" & vbCrLf
    strm.WriteText "Content-Type: text/plain" & vbCrLf
    strm.WriteText vbCrLf
    strm.WriteText strName & strMsg & vbCrLf
 
    ' 画像セクション
    strm.WriteText "--" & strBoundary & vbCrLf
    strm.WriteText "Content-Disposition: form-data; name=""imageFile""; filename=""" & GetFileName(strFile) & """ " & vbCrLf
    strm.WriteText "Content-Type: " & strImgType & vbCrLf
    strm.WriteText vbCrLf
    strm.Position = 0
    
    ' テキストをバイナリに変換
    strm.CopyTo strmWkBin
 
    ' セクションを書き込み
    strmWkBin.Position = 0
    strmBin.Write strmWkBin.Read(strmWkBin.Size)
 
    ' 画像を読み込む
    strmWkBin.LoadFromFile (strFile)
 
    ' 画像を書き込み
    strmBin.Write strmWkBin.Read(strmWkBin.Size)
 
    ' バイナリワークをいったん閉じる
    strmWkBin.Close
    strmWkBin.Open
    strmWkBin.Type = 1
 
    ' テキストをいったん閉じる
    strm.Close
    strm.Open
    'strm.Charset = "shift_jis"
    strm.Charset = "utf-8"
 
    ' 終了セクション
    strm.WriteText vbCrLf & "--" & strBoundary & "--" & vbCrLf
    strm.Position = 0
 
    ' テキストをバイナリに変換
    strm.CopyTo strmWkBin
 
    ' 終了セクションを書き込み
    strmWkBin.Position = 0
    strmBin.Write strmWkBin.Read(strmWkBin.Size)
 
    ' 送信データを取得
    Dim nLen As Long
    nLen = strmBin.Size
    strmBin.Position = 0
 
    ' 送信データを保存
    Call strmBin.SaveToFile(ThisWorkbook.Path & "\result.dat", 2)
 
    ' 投稿データの長さセット
    Call http.SetRequestHeader("Content-Length", nLen)
         
    ' *********************************************************
    ' 投稿データ送信
    ' *********************************************************
    strmBin.Position = 0
    Call http.Send(strmBin.Read(nLen))

    ' 送信完了待ち
    Do While http.readyState < 4
        DoEvents
    Loop

    ' 結果情報
    strRes = http.ResponseText
    
    strmWkBin.Close
    strmBin.Close
    strm.Close
    
    Set strmWkBin = Nothing
    Set strmBin = Nothing
    Set strm = Nothing
    Set http = Nothing

    Debug.Print strRes
End Sub

'' ファイル拡張子取得
Public Function GetFileExtension(filePath As String)
  Dim fso As Object
  Dim ExtentionName As String
  
  Set fso = CreateObject("Scripting.FileSystemObject")
  ExtentionName = fso.GetExtensionName(filePath)
  
  GetFileExtension = ExtentionName
  
  Set fso = Nothing
End Function

'' ファイル名取得
Public Function GetFileName(filePath As String)
  Dim fso As Object
  Dim ExtentionName As String
  
  Set fso = CreateObject("Scripting.FileSystemObject")
  ExtentionName = fso.GetFileName(filePath)
  
  GetFileName = ExtentionName
  
  Set fso = Nothing
End Function

終わりに

動いてしまえばなんてこと無いのですが、はまる要素がいろいろあって苦労しました。