LINE WORKS

参考URL
https://developers.worksmobile.com/jp/document/1005025?lang=ja

VBAでラインワークスのコンテンツアップロードを行いたいのですが

下記エラーが表示されます。
実行時エラー '-2146697208(800c0008)'
指定されたリソースのダウンロードに失敗しました。

以下、コードです。
'
Function CreateNomarlParameter(fct, fctm)
s = ""
s = s & fct & fctm & vbCrLf
s = s & vbCrLf
CreateNomarlParameter = s
End Function

Function CreateFileParmaterPrefix(fname, fvalue, fct)
s = ""
s = s & strBoundary & vbCrLf
s = s & "Content-Disposition: form-data; name=""" & fname & """; filename=""" & fvalue & """" & vbCrLf
s = s & "Content-Type: " & fct & vbCrLf
CreateFileParmaterPrefix = s
End Function

Private Function ChangeStreamType(stream, adType)
Dim p As Long
p = stream.Position
stream.Position = 0
stream.Type = adType

If adType = adTypeText Then
stream.Charset = "UTF-8"
End If

stream.Position = p

Set ChangeStreamType = stream
End Function

Public Function ChangeChr(strXML) As Byte()
Dim objSTREAM As Object
On Error Resume Next
Set objSTREAM = CreateObject("ADODB.Stream")
With objSTREAM
.Open
.Type = adTypeText
.Charset = "UTF-8"
.WriteText strXML
.Position = 0
.Type = adTypeBinary
.Position = 0
ChangeChr = .Read()
End With

objSTREAM.Close: Set objSTREAM = Nothing
End Function

Public Function KickWebApiOfDATA(ByVal request As String, ByVal url As String, Optional ByVal param As String) As Object
Const adTypeBinary = 1
Const adTypeText = 2

Dim json
json = ConvertToJson(param)

Dim strBoundary: strBoundary = "--" & DateDiff("s", "1970/1/1 0:00:00", DateAdd("h", -9, Now))
Dim endBoundary: endBoundary = vbCrLf & "--" & strBoundary & "--" & vbCrLf

Dim StreamB
Dim StreamS
StreamS = ""

Set stream = CreateObject("ADODB.Stream")

stream.Open
stream.Type = adTypeBinary
stream.LoadFromFile param
StreamB = stream.Read
stream.Close

stream.Type = adTypeText
stream.Charset = "UTF-8"
stream.Open

ChangeStreamType stream, adTypeText
StreamS = "--" & strBoundary
StreamS = StreamS & CreateFileParmaterPrefix("resourceName", Dir(param), "application/octet-stream")
StreamS = StreamS & CreateNomarlParameter("Content-Transfer-Encoding: ", "binary")
stream.WriteText StreamS

ChangeStreamType stream, adTypeBinary
stream.Write StreamB

ChangeStreamType stream, adTypeText
stream.WriteText endBoundary

ChangeStreamType stream, adTypeBinary
stream.Position = 0
formdata = stream.Read

Dim http As Object

Set http = CreateObject("Msxml2.XMLHTTP")

With http
.Open request, url, False
.setRequestHeader "consumerKey", Sheet2.Cells(2, 3)
.setRequestHeader "authorization", "Bearer " & Sheet2.Cells(3, 3)
.setRequestHeader "x-works-apiid", Sheet2.Cells(6, 3)
.setRequestHeader "Cache-Control", "no-cache"
.setRequestHeader "Content-Length", stream.Size
.setRequestHeader "Content-Type", "multipart/form-data; boundary=""" & strBoundary & """" & vbCrLf
.Send formdata

If .ResponseText <> "" Then
Set KickWebApiOfJsonDATA = ParseJson(.ResponseText)
Debug.Print .ResponseText
End If
End With
Set http = Nothing
stream.Close

End Function

Sub OnClick_PostDATA()
Dim param As String

param = "C:\tools\QRtest.png"

Debug.Print JsonConverter.ConvertToJson(param, Whitespace:=2)

Call KickWebApiOfDATA("POST", "http://storage.worksmobile.com/openapi/message/upload.api", param)

End Sub
'

OnClick_PostDATA()を呼び出してラインワークスのコンテンツアップロードを行おうとしています。
なお、メッセージの送信はできるので
.setRequestHeader "consumerKey", Sheet2.Cells(2, 3)
.setRequestHeader "authorization", "Bearer " & Sheet2.Cells(3, 3)
.setRequestHeader "x-works-apiid", Sheet2.Cells(6, 3)
に関しては問題ないと思います。