お世話になります。
VBAからHTTPリクエストをmulti-partで送信しようとして、うまくいきません。
受け取り側でファイル(GZIP)を解凍しようとして、形式エラーとなってしまいます。
(JavaのGZIPInputStreamに変換しようとして例外となる)
(マルチパートとしての認識はされていて、バイト配列を取り出すことはできています。)
具体的に以下のような設定で送っています。
EncodeBase64内でBase64にエンコードしている箇所をコメントアウトしているのは、
受け取り側でBase64のデコードがないからです。(ためしにVBA側Base64でエンコードし、、受け取り側(Java)でデコードした際にはうまくGZIPとして認識されました)
いろいろ試したものの、見当がつかず、どのあたりを修正すればよいかご教授願います。
params = params + CreateFileParmaterPrefix("data", Dir(filePath), "application/octet-stream;charset=utf-8", strBoundary, filePath) Set stream = CreateObject("ADODB.Stream") stream.Type = adTypeText stream.Charset = "UTF-8" stream.Open ChangeStreamType stream, adTypeText stream.WriteText params ChangeStreamType stream, adTypeBinary stream.Position = 0 formdata = stream.Read stream.Close Set req = CreateHttpRequest req.Open "POST", Range(urlCell).Value, False Call req.setRequestHeader("Content-Type", "multipart/form-data; boundary=" & strBoundary) Call req.send(formdata)
Function CreateFileParmaterPrefix(fname, fvalue, fct, strBoundary, filePath)
Dim s As String
s = ""
s = s + "--" + strBoundary + vbCrLf
s = s + "Content-Disposition: form-data; name=""" + fname + """; filename=""" + fvalue + """" + vbCrLf
s = s + "Content-Type: " + fct + vbCrLf
s = s + "Content-Transfer-Encoding: binary" + vbCrLf
s = s + vbCrLf
s = s + EncodeBase64(filePath) + vbCrLf
CreateFileParmaterPrefix = s
End Function
Function EncodeBase64(ByVal filePath As String) As String
' Dim elm As Object
Dim ret As String
Const adTypeBinary = 1
Const adReadAll = -1
ret = ""
On Error Resume Next
' Set elm = CreateObject("MSXML2.DOMDocument").createElement("base64")
With CreateObject("ADODB.Stream")
.Type = adTypeBinary
.Open
.LoadFromFile filePath
' elm.DataType = "bin.base64"
' elm.nodeTypedValue = .Read(adReadAll)
ret = .Read() 'elm.text
.Close
End With
On Error GoTo 0
EncodeBase64 = ret
End Function
Function CreateHttpRequest() As Object
Dim progIDs As Variant
Dim ret As Object
Dim i As Long
Set ret = Nothing
progIDs = Array("WinHttp.WinHttpRequest.5.1", _
"WinHttp.WinHttpRequest.5", _
"WinHttp.WinHttpRequest", _
"Msxml2.ServerXMLHTTP.6.0", _
"Msxml2.ServerXMLHTTP.5.0", _
"Msxml2.ServerXMLHTTP.4.0", _
"Msxml2.ServerXMLHTTP.3.0", _
"Msxml2.ServerXMLHTTP", _
"Microsoft.ServerXMLHTTP", _
"Msxml2.XMLHTTP.6.0", _
"Msxml2.XMLHTTP.5.0", _
"Msxml2.XMLHTTP.4.0", _
"Msxml2.XMLHTTP.3.0", _
"Msxml2.XMLHTTP", _
"Microsoft.XMLHTTP")
On Error Resume Next
For i = LBound(progIDs) To UBound(progIDs)
Set ret = CreateObject(progIDs(i))
If Not ret Is Nothing Then Exit For
Next
On Error GoTo 0
Set CreateHttpRequest = ret
End Function