Bot

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

K’

2019.08.29既読 7349

参考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)
に関しては問題ないと思います。

コメント5

  • 업데이트 된 답글입니다.

    K’ 投稿者

    https://qiita.com/kunihiros/items/9816fa1860613b3b1a3a

    上記URLはNode.jsでのコンテンツアップロードコードですが
    実行してみたところ下記のエラーが発生しました。
    error start
    { Error: read ECONNRESET
       at TCP.onStreamRead (internal/stream_base_commons.js:111:27) errno: 'ECONNRESET', code: 'ECONNRESET', syscall: 'read' }

    2019.08.29

    0
  • 업데이트 된 답글입니다.

    LINE WORKS 公式アカウント

    こちらでは個別のコードに関するコメント、トラブルシューティングは控えさせていただきます。
    ご了承ください。

    2019.08.30

    0
  • 업데이트 된 답글입니다.

    K’ 投稿者

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

    このエラーコードはどういう意味なのでしょうか?

    2019.08.30

    0
  • 업데이트 된 답글입니다.

    K’ 投稿者

    レスポンスが遅いので速くしてほしいです。

    2019.08.30

    0
  • 업데이트 된 답글입니다.

    LINE WORKS 公式アカウント

    Excel のエラーのようですので、エラー内容についてはマイクロソフト社にご確認いただけますでしょうか。
    このコミュニティは技術的な意見交換の場でサポートではないため、ベストエフォートでの対応となってしまいます。
    ご了承ください。

    2019.08.30

    0
前の投稿Office365のカレンダーとLINEWORKSのカレンダーを連携したい
次の投稿トークBot APIのエラーについて
リスト

まだ、解決できませんか?
今すぐ実際に使用しているLINE WORKSユーザーに質問してみましょう。