Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10 Home : Excel 2016)
VBAでCSVファイルをウェブAPIのURLにPOSTしたい
投稿日時: 17/09/27 16:44:49
投稿者: lucid

curl -X POST -F “file=@C:\sample.csv” http://xx.xxx.xxx.xxx/filematerials/upload
というコマンドでファイルをアップロードできるウェブAPIに対して、VBAからファイルをPOSTしてアップロードしたいと考えています。
調べた結果、MSXML2.XMLHTTPを使えばPOSTできるらしいという情報を得て下記のコードを書いたのですがどうにも動きません。どのように書けばurlに対してファイルをPOSTできるのでしょうか。
よろしくお願いいたします。
 

    Dim xmlHttp As Object
    Dim url As String
    Dim strParam As String
    Dim strRes As String
    
    Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
    url = "http://xx.xxx.xxx.xxx/filematerials/upload"
    strParam = "file=C:\sample.csv"
    
    With xmlHttp
        .Open "POST", url, False
        .setrequestheader "Content-Type", "multipart/form-data"
        .send (strParam)
        strRes = .ResponseText
    End With
    
    If Trim(strRes) <> "" Then MsgBox strRes
    Set xmlHttp = Nothing

回答
投稿日時: 17/09/27 22:22:30
投稿者: simple

ファイルのアップロードということでしょうから、
例えば
http://stargate.undo.jp/archives/2309
などが参考になりませんか?

投稿日時: 17/09/28 09:49:25
投稿者: lucid

ご回答いただきありがとうございます。
http://stargate.undo.jp/archives/2309
のコードを利用して下記PHPにPOSTしてみたのですが、$_POSTも$_FILESも戻り値が空のようでした。確認の仕方が間違っているかもしれませんが、うまく動かすことができませんでした。
 

<?php
var_dump($_POST);
var_dump($_FILES);

回答
投稿日時: 17/09/29 07:13:04
投稿者: kumatti
投稿者のウェブサイトに移動

VBAでは送信データを自前で構築しなくてはいけないので、VBのWebClientとかの方が簡単に済むのではと思います。
#過去ログからshiraさんのコードを参考にされて下さい。

' 参照設定:Microsoft ActiveX Data Objects 2.x Library (2.5以上)
'      Microsoft CDO for Windows 2000 Library
'      (または環境によっては)
            Microsoft CDO For Exchange 2000 Library

-------- クラスモジュール「clsMultiPartHelper」--------
Option Explicit

Public Charset As String    ' 手抜き
Private m_bp As CDO.IBodyPart
Private m_Boundary As String

Private Sub Class_Initialize()
    Charset = "Shift_JIS"   ' 既定で使用する文字セット
    Set m_bp = New CDO.Message
    Set m_bp = m_bp.AddBodyPart
    m_bp.ContentMediaType = "multipart/form-data"
End Sub

Private Sub Class_Terminate()
    Set m_bp = Nothing
End Sub

' 文字列値をパラメータに追加 (第2引数には日本語等も指定可)
Public Sub AddParam(ByVal Name As String, ByVal Value As String)

    Dim stm As ADODB.Stream
    Dim lngBOMSize As Long

    'If Len(Name) = 0 Then Err.Raise 5
    With m_bp.AddBodyPart
        .ContentMediaType = cdoTextPlain
        .Charset = Charset
        .ContentTransferEncoding = cdoBinary
        With .Fields
            .Item(cdoContentDisposition).Value = _
                    "form-data; name=""" & Name & """"
            .Update
        End With
        Set stm = .GetEncodedContentStream
    End With

  If 0 Then
    ' Unicode系(UTF-8等)を使わないならこちらでもOK
    stm.Charset = Charset
    stm.WriteText Value
  Else
    ' Unicode系でBOMが挿入されるのを抑止
    stm.Type = adTypeBinary
    With New ADODB.Stream
        .Open
        .Charset = Charset
        .WriteText ""
        lngBOMSize = .Size
        .WriteText Value
        .Position = 0
        .Type = adTypeBinary
        .Position = lngBOMSize
        .CopyTo stm
    End With
  End If
    stm.Flush
    stm.Close
    m_Boundary = ""

End Sub

' ファイルをパラメータに追加
' (必要であれば第3引数に送信用の代替ファイル名を指定)
Public Sub AddFile(ByVal Name As String,ByVal FileName As String, _
Optional ByVal AltFileName As String)

    Dim strContentType As String

    'If Len(Name) = 0 Then Err.Raise 5
    ' メディアタイプの簡易な取得
    With New CDO.Message
        strContentType = .AddAttachment(FileName).ContentMediaType
    End With

    If Len(AltFileName) = 0 Then
        AltFileName = FileName
    End If
    With m_bp.AddBodyPart
        .ContentTransferEncoding = cdoBinary
        With .Fields
            .Item(cdoContentType).Value = strContentType
            .Item(cdoContentDisposition).Value = _
                    "form-data" & _
                    "; name=""" & Name & """" & _
                    "; filename=""" & AltFileName & """"
            .Update
        End With

        If Len(FileName) > 0 Then
            With .GetEncodedContentStream
                .Type = adTypeBinary    ' 念のため
                .LoadFromFile FileName
                .Flush
                .Close
            End With
        End If
    End With
    m_Boundary = ""

End Sub

' データの作成
Public Function GetData() As ADODB.Stream

    Dim stm As ADODB.Stream
    Dim lngPos As Long

    ' 先頭の境界以降をコピー
    Set stm = New ADODB.Stream
    stm.Type = adTypeBinary
    stm.Open
    With m_bp.GetStream
        .Type = adTypeText
        Do
            lngPos = .Position
            ' ↓手抜き判定 (境界用文字列全体で比較することも可能)
        Loop Until .ReadText(adReadLine) Like "--?*" Or .EOS
        .Position = 0
        .Type = adTypeBinary
        .Position = lngPos
        .CopyTo stm
        .Close
    End With

    stm.Position = 0
    Set GetData = stm
    m_Boundary = m_bp.GetFieldParameter(cdoContentType, "boundary")

End Function

' GetDataの後での呼び出し用
Public Property Get ContentType() As String
    If Len(m_Boundary) > 0 Then
        'ContentType = m_bp.Fields(cdoContentType).Value
        ContentType = "multipart/form-data" & _
                      "; boundary=""" & m_Boundary & """"
    Else
        ContentType = m_bp.ContentMediaType
    End If
End Property

-------- 任意のモジュールからの使用例 --------

Sub 呼び出し例1()

    Dim stm As ADODB.Stream
    Dim strContentType As String
    Dim strURL As String
    strURL = "http:// 略"

    ' 送信するパラメータの作成
    With New clsMultiPartHelper
        .Charset = "Shift_JIS"
        .AddParam "param1", "値"
        .AddParam "param2", ""
        .AddFile "imgfile", "C:\path\xxxx.jpg"
        Set stm = .GetData
        strContentType = .ContentType
    End With

    ' ↓送信する内容をファイル化して確認したければ
    'stm.SaveToFile "C:\path\temp1.bin", adSaveCreateOverWrite

    ' 送信
    With CreateObject("MSXML2.XMLHTTP")
        .Open "POST", strURL, False
        .setRequestHeader "Content-Type", strContentType
        .send CVar(stm) ' 新しいADO環境の場合
                        ' (事前バインディングならCVarは不要)
        '.send stm.Read ' IStreamをサポートしない古いStreamの場合

        ' 以下略
    End With
    stm.Close

End Sub

--------

投稿日時: 17/10/02 17:19:44
投稿者: lucid

kumattiさん、ご回答いただきありがとうございました。

.AddFile "imgfile", "C:\path\xxxx.jpg"

の箇所を
.AddFile "file", "C:\path\xxxx.csv"

に変え、無事動作させることができました。
とても困っていたので本当に助かりました。ありがとうございました。