LINE WORKS Developers

コミュニティ

LINE WORKSのテクニカルエキスパート及び開発者と
コードのサンプル、リソース、Tip等を共有し問題解決への相談が可能です。

??dev_메인_타이틀_모바일_ja_JP??

トークBot

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

画像

K’

2019.08.29既読 227

参考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

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

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

    2019.08.30

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

    2019.08.30

    0
  • 画像

    LINE WORKS 公式アカウント

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

    2019.08.30

    0