[VBScript]GET/POST(疑似REST)を、Basic認証付きで複数のパラメータ/ファイルをセットして実行するクラス

vbsでPOST/GETとかファイルのアップロード/ダウンロードを実装したかったのでメモ

素直にcurlコマンドを使えばよいが、runコマンドでvbs中に実行結果を取得したいときに
一度ファイルにリダイレクトして読み込まなければならないからスマートではないし、
ファイル書き出しにラグがあるから途中で読み込むと正しくない結果を取得することになる。

スマートな書き方が難しく、色々な人が試行錯誤しているのを調べてわかったが、
主に参考にさせていただいたのは以下のページ
VBScript で webclient.UploadFile もどきを作ってみた
ローカルにある画像をtumblrにPOSTするスクリプトを書いた

基本的には上記ページのコードをそのまま流用しているが、使い勝手を自分用に合わせたクラスとした。
・POST/GETをRESTのClientっぽく呼べるようにする
・渡すパラメータは複数可能とする
・POSTではファイルも複数渡せる
・BASIC認証のページに対応

以下ソースコード

Class RestClient
 Private TYPE_BINARY
 Private TYPE_TEXT
 Private CHARSET
 Private BOUNDARY_DETECTOR
 Private BOUNDARYSTR
 Private BOUNDARY
 Private END_BOUNDARY

 Private Sub Class_Initialize
  TYPE_BINARY = 1
  TYPE_TEXT = 2
  BOUNDARY_DETECTOR = "--"
  ChangeBoundary
  CHARSET = "UTF-8"
 End Sub

 Function REQ_POST(address, basicDic, paramDic, fileDic)
  Set REQ_POST = Request("POST", address, basicDic, paramDic, fileDic)
 End Function
 
 
 Function REQ_GET(address, basicDic, paramDic)
  Set REQ_GET = Request("GET", address, basicDic, paramDic, Nothing)
 End Function
 
 Private Function Request(method, address, basicDic, paramDic, fileDic)
  Dim xmlHttp: Set xmlHttp = CreateObject("Msxml2.XmlHttp")
  Dim id: id = ""
  Dim password: password = ""
  Dim key : key = ""
  If Not basicDic Is Nothing Then
   If basicDic.Count = 1 Then
    For Each key In basicDic
     id = key
     password = basicDic.Item(key)
    Next
   End If
  End If
  ChangeBoundary
  Select Case method
   Case "POST"
    With xmlHttp
     If id <> "" Then
      .Open method, address, False, id, password
     Else
      .Open method, address, False
     End If
     .setRequestHeader "Content-Type", "multipart/form-data; boundary=" + BOUNDARYSTR
     .send MakeFormData(paramDic, fileDic)
    End With
   Case "GET"
    Dim reqAddress: reqAddress = address
    If Not paramDic Is Nothing And Not IsEmpty(paramDic) Then
     Dim paramPairs: paramPairs = ""
     For Each key In paramDic
      paramPairs = paramPairs & "&" & key & "=" & paramDic.Item(key)
     Next
     reqAddress = reqAddress & "?" & Mid(paramPairs, 2)
    End If
    With xmlHttp
     If id <> "" Then
      .Open method, reqAddress, False, id, password
     Else
      .Open method, reqAddress, False
     End If
     .send
    End With
   Case Else
    Set xmlHttp = Nothing
  End Select
  Set Request = xmlHttp
 End Function
 
 
 Private Sub ChangeBoundary
  BOUNDARYSTR = MakeBoundary(30)
  BOUNDARY = BOUNDARY_DETECTOR & BOUNDARYSTR
  END_BOUNDARY = BOUNDARY & BOUNDARY_DETECTOR & vbCrLf
 End Sub
 
 Private Function MakeBoundary(digit)
  Dim hexStr: hexStr = ""
  Dim i: i = 0
  For i = 0 To digit - 1
   Randomize
   hexStr = hexStr & Hex(Int(65535 * Rnd()) Mod 16)
  Next
  MakeBoundary = "-----------------------------" & LCase(hexStr)
 End Function
 
 Private Function MakeFormData(paramDic, fileDic)
  Dim formData: formData = ""
  Dim stream: Set stream = CreateObject("Adodb.Stream")
  With stream
   .Open
   AddBegin stream
   If Not paramDic Is Nothing Then
    AddParameters stream, paramDic
   End If
   If Not fileDic Is Nothing Then
    AddFiles stream, fileDic
   End If
   AddEnd stream
   formData = ReadStream(stream)
   .Close
  End With
  MakeFormData = formData
  Set stream = Nothing
 End Function
 
 Private Sub AddBegin(stream)
  With stream
  .Type = TYPE_TEXT
  .Charset = CHARSET
  .WriteText "--"
  End With
 End Sub

 Private Sub AddParameters(stream, paramDic)
  Dim key : key = ""
  ResetPosition stream, TYPE_TEXT
  For Each key In paramDic
   stream.WriteText MakeParameter(key, paramDic.Item(key))
  Next
 End Sub
 
 Private Sub ResetPosition(stream, streamType)
  Dim currentPosition: currentPosition = stream.Position
  With stream
   .Position = 0
   .Type = streamType
   .Position = currentPosition
  End With
 End Sub
 
 Private Function MakeParameter(key, value)
  Dim parameter: parameter = ""
  If key <> "" Then
   parameter = BOUNDARY & vbCrLf & "Content-Disposition: form-data; name=""" & key  & """" & _
   vbCrLf & vbCrLf & value & vbCrLf
  End If
  MakeParameter = parameter
 End Function

 Private Sub AddFiles(stream, fileDic)
  Dim key : key = ""
  Dim fsObj: Set fsObj = CreateObject("Scripting.FileSystemObject")
  With stream
   For Each key In fileDic
    ResetPosition stream, TYPE_TEXT
    .WriteText MakeFileHeader(key, fsObj.getFileName(fileDic.Item(key)))
    ResetPosition stream, TYPE_BINARY
    .Write MakeFileStream(fileDic.Item(key))
    ResetPosition stream, TYPE_TEXT
    .WriteText vbCrLf
   Next
  End With
  Set fsObj = Nothing
 End Sub
 
 Private Function MakeFileHeader(key, filename)
  Dim header: header = ""
  If key <> "" Then
   header = BOUNDARY & vbCrLf & "Content-Disposition: form-data; name=""" & key & """; filename=""" & filename & """" & vbCrLf & _
   "Content-Type: application/octet-stream" & vbCrLf & vbCrLf
  End If
  MakeFileHeader = header
 End Function
 
 Private Function MakeFileStream(filePath)
  Dim fileContents: fileContents = ""
  Dim fileStream: Set fileStream = CreateObject("Adodb.Stream")
  With fileStream
   .Type = TYPE_BINARY
   .Open
   .LoadFromFile filePath
   fileContents = fileStream.Read
   .Close
  End With
  MakeFileStream = fileContents
  Set fileStream = Nothing
 End Function
 
 Private Sub AddEnd(stream)
  ResetPosition stream, TYPE_TEXT
  stream.WriteText END_BOUNDARY
 End Sub
 
 Private Function ReadStream(stream)
  ResetPosition stream, TYPE_BINARY
  stream.Position = 0
  ReadStream = stream.Read
 End Function
 
 Private Sub Class_Terminate
 End Sub
End Class

使い方は以下のような感じ。

'ベーシック認証/渡すパラメータ/渡すファイルのパラメータの連想配列を宣言
Dim basicDic: Set basicDic = CreateObject("Scripting.Dictionary")
Dim getParamDic: Set getParamDic = CreateObject("Scripting.Dictionary")
Dim postParamDic: Set postParamDic = CreateObject("Scripting.Dictionary")
Dim postFileDic: Set postFileDic = CreateObject("Scripting.Dictionary")

'RestClientクラス自体の記述は省略
Dim client: Set client = new RestClient

'リクエストを送るURL
Const url = "http://test.test/"

'BASIC認証の情報を追加(2つ以上追加すると無効)
basicDic.Add "myusername", "mypassword"


'GETの例
'パラメータの組み合わせを2つ追加
getParamDic.Add "getParamKey1", "getParamValue1"
getParamDic.Add "getParamKey2", "getParamValue2"

'GET実行
Dim getResult: Set getResult = client.REQ_GET(url, basicDic, getParamDic)
'結果表示
Wscript.Echo getResult.responseText


'POSTの例
'パラメータの組み合わせを２つ追加し、ファイルも2つ追加
postParamDic.Add "postParamKey1", "postParamValue1"
postParamDic.Add "postParamKey2", "postParamValue2"
postFileDic.Add "postFileKey1", "C:\temp\test1.txt"
postFileDic.Add "postFileKey2", "C:\temp\test2.txt"

'POST実行
Dim postResult: Set postResult = client.REQ_POST(url, Nothing, postParamDic, postFileDic)
'結果表示
Wscript.Echo postResult.responseText

Set getResult = Nothing
Set client = Nothing
Set postFileDic = Nothing
Set postParamDic = Nothing
Set getParamDic = Nothing
Set basicDic = Nothing

Wscript.Quit

BASIC認証が必要ないURLの場合は、REQ_POST/REQ_GETの第二引数にNothingを指定する
その他パラメータやファイルも必要がなければ同様に第三、四引数にNothingを指定する

上記実装例をリクエストの生データそのまま返すURLに送ったときの結果
GET


POST

GET/POSTのswitch文で似たようなMsxml2.XmlHttpを
重複して書いているので、美しくないが良い方法が思いつかなかった。
ちなみに、GETでファイルをダウンロードする場合はREQ_GETの取得後以下のようにすれば良い。

Dim adodbStream: Set adodbStream = CreateObject("Adodb.Stream")
 With adodbStream
  .Open
  .Type = 1
  .Write getResult.responseBody
  .SaveToFile "C:\temp\save.txt", 2
  .Close
End With

とりあえず呼び出し側を極力スマートに書けるようにしたので一旦ここまで。

以上。

タグ：VBS VBScript multipart/form-data REST