VBAにてラインワークスのコンテンツアップロードの方法

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

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

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

以下、コードです。

vba
1Function CreateNomarlParameter(fct, fctm)
2    s = ""
3        s = s & fct & fctm & vbCrLf
4        s = s & vbCrLf
5    CreateNomarlParameter = s
6End Function
7 
8Function CreateFileParmaterPrefix(fname, fvalue, fct)
9    s = ""
10    s = s & strBoundary & vbCrLf
11    s = s & "Content-Disposition: form-data; name=""" & fname & """; filename=""" & fvalue & """" & vbCrLf
12    s = s & "Content-Type: " & fct & vbCrLf
13    CreateFileParmaterPrefix = s
14End Function
15
16Private Function ChangeStreamType(stream, adType)
17    Dim p As Long
18    p = stream.Position
19    stream.Position = 0
20    stream.Type = adType
21
22    If adType = adTypeText Then
23        stream.Charset = "UTF-8"
24    End If
25
26    stream.Position = p
27
28    Set ChangeStreamType = stream
29End Function
30
31Public Function ChangeChr(strXML) As Byte()
32Dim objSTREAM As Object
33On Error Resume Next
34    Set objSTREAM = CreateObject("ADODB.Stream")
35    With objSTREAM
36        .Open
37        .Type = adTypeText
38        .Charset = "UTF-8"
39        .WriteText strXML
40        .Position = 0
41        .Type = adTypeBinary
42        .Position = 0
43        ChangeChr = .Read()
44    End With
45
46    objSTREAM.Close:    Set objSTREAM = Nothing
47End Function
48
49Public Function KickWebApiOfDATA(ByVal request As String, ByVal url As String, Optional ByVal param As String) As Object
50    Const adTypeBinary = 1
51    Const adTypeText = 2
52    
53    Dim json
54    json = ConvertToJson(param)
55    
56    Dim strBoundary: strBoundary = "--" & DateDiff("s", "1970/1/1 0:00:00", DateAdd("h", -9, Now))
57    Dim endBoundary: endBoundary = vbCrLf & "--" & strBoundary & "--" & vbCrLf
58    
59    Dim StreamB
60    Dim StreamS
61    StreamS = ""
62   
63    Set stream = CreateObject("ADODB.Stream")
64    
65    stream.Open
66    stream.Type = adTypeBinary
67    stream.LoadFromFile param
68    StreamB = stream.Read
69    stream.Close
70
71    stream.Type = adTypeText
72    stream.Charset = "UTF-8"
73    stream.Open
74    
75    ChangeStreamType stream, adTypeText
76    StreamS = "--" & strBoundary
77    StreamS = StreamS & CreateFileParmaterPrefix("resourceName", Dir(param), "application/octet-stream")
78    StreamS = StreamS & CreateNomarlParameter("Content-Transfer-Encoding: ", "binary")
79    stream.WriteText StreamS
80    
81    ChangeStreamType stream, adTypeBinary
82    stream.Write StreamB
83    
84    ChangeStreamType stream, adTypeText
85    stream.WriteText endBoundary
86    
87    ChangeStreamType stream, adTypeBinary
88    stream.Position = 0
89    formdata = stream.Read
90    
91    Dim http As Object
92    
93    Set http = CreateObject("Msxml2.XMLHTTP")
94    
95    With http
96        .Open request, url, False
97        .setRequestHeader "consumerKey", Sheet2.Cells(2, 3)
98        .setRequestHeader "authorization", "Bearer " & Sheet2.Cells(3, 3)
99        .setRequestHeader "x-works-apiid", Sheet2.Cells(6, 3)
100        .setRequestHeader "Cache-Control", "no-cache"
101        .setRequestHeader "Content-Length", stream.Size
102        .setRequestHeader "Content-Type", "multipart/form-data; boundary=""" & strBoundary & """" & vbCrLf
103        .Send formdata
104
105        If .ResponseText <> "" Then
106            Set KickWebApiOfJsonDATA = ParseJson(.ResponseText)
107            Debug.Print .ResponseText
108        End If
109    End With
110    Set http = Nothing
111    stream.Close
112    
113End Function
114
115Sub OnClick_PostDATA()
116    Dim param As String
117    
118    param = "C:\tools\QRtest.png"
119    
120    
121    
122    Debug.Print JsonConverter.ConvertToJson(param, Whitespace:=2)
123
124    Call KickWebApiOfDATA("POST", "http://storage.worksmobile.com/openapi/message/upload.api", param)
125
126End Sub

OnClick_PostDATA()を呼び出してラインワークスのコンテンツアップロードを行おうとしています。
なお、メッセージの送信はできるので

vba
1        .setRequestHeader "consumerKey", Sheet2.Cells(2, 3)
2        .setRequestHeader "authorization", "Bearer " & Sheet2.Cells(3, 3)
3        .setRequestHeader "x-works-apiid", Sheet2.Cells(6, 3)