■WinInetを使ってVBAでPOSTする

Option Explicit

Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Private Const INTERNET_OPEN_TYPE_DIRECT = 1
Private Const INTERNET_OPEN_TYPE_PROXY = 3
Private Const INTERNET_SERVICE_HTTP = 3
Private Const INTERNET_DEFAULT_HTTP_PORT = 80
Private Const INTERNET_FLAG_RELOAD = &H80000000

Private Declare Function InternetOpenA Lib "wininet.dll" (ByVal sCallerName As String, ByVal dwAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal dwFlags As Long) As Long
Private Declare Function InternetConnectA Lib "wininet.dll" (ByVal hInternetSession As Long, ByVal sServerName As String, ByVal nProxyPort As Integer, ByVal sUserName As String, ByVal sPassword As String, ByVal dwService As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare Function InternetReadFile Lib "wininet.dll" (ByVal hFile As Long, ByRef sBuffer As Byte, ByVal lNumberBytesToRead As Long, ByRef lNumberOfBytesRead As Long) As Long
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInternetHandle As Long) As Long
Private Declare Function HttpOpenRequestA Lib "wininet.dll" (ByVal hConnect As Long, ByVal sVerb As String, ByVal sObjectName As String, ByVal sVersion As String, ByVal sReferer As String, ByVal sAcceptTypes As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare Function HttpSendRequestA Lib "wininet.dll" (ByVal hRequest As Long, ByVal sHeaders As String, ByVal dwHeadersLength As Long, ByVal lpOptional As String, ByVal dwOptionalLength As Long) As Long

Private Function submitPost(ByRef host, ByRef url_path, ByRef sendString) As Variant

  Dim dataArray() As Byte, dataPosition, dataSize

 'WinInet初期化
  Dim hInternet
  hInternet = InternetOpenA(vbNullString, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
  If hInternet = 0 Then
    submitPost = dataArray
    Exit Function
  End If

 'サーバ接続
  Dim hConnect
  hConnect = InternetConnectA(hInternet, host, INTERNET_DEFAULT_HTTP_PORT, vbNullString, vbNullString, INTERNET_SERVICE_HTTP, 0, 0)
  If hConnect = 0 Then
    InternetCloseHandle hInternet
    submitPost = dataArray
    Exit Function
  End If

 'リクエストを初期化
  Dim tmpURL As String * 255
  tmpURL = url_path
  Dim hRequest
  hRequest = HttpOpenRequestA(hConnect, "POST", tmpURL, "HTTP/1.1", vbNullString, 0, INTERNET_FLAG_RELOAD, 0)
  If hRequest = 0 Then
    InternetCloseHandle hConnect
    InternetCloseHandle hInternet
    submitPost = dataArray
    Exit Function
  End If

 'リクエストを送信
  Const strHeader = "Content-Type: application/x-www-form-urlencoded"
  HttpSendRequestA hRequest, strHeader, Len(strHeader), sendString, Len(sendString)

 'データ取得
  Dim readResult, tmpArray(1023) As Byte, tmpPosition, tmpSize
  dataPosition = 0
  dataSize = 0
  Do
    tmpSize = 0
    Erase tmpArray
    readResult = InternetReadFile(hRequest, tmpArray(0), 1024, tmpSize)
    If Not readResult = 1 Or tmpSize = 0 Then
      Exit Do
    End If

    dataSize = dataSize + tmpSize
    ReDim Preserve dataArray(dataSize - 1)
    For tmpPosition = 0 To tmpSize - 1 Step 1
      dataArray(dataPosition) = tmpArray(tmpPosition)
      dataPosition = dataPosition + 1
    Next
  Loop

 'クローズ処理
  InternetCloseHandle hRequest
  InternetCloseHandle hConnect
  InternetCloseHandle hInternet

  submitPost = dataArray

End Function

Public Function downloadFilePost(ByRef targetURL, ByVal sendArray, ByRef savePath) As Boolean

 'URLの分解
  Dim startE, endE, host, url_path
  startE = InStr(1, targetURL, "//") + 2
  endE = InStr(startE, targetURL, "/")
  endE = IIf(startE > endE, Len(targetURL) + 1, endE)
  host = Mid(targetURL, startE, endE - startE)
  url_path = Mid(targetURL, endE)

 'ポストデータのエンコード
  Dim jscript
  With CreateObject("ScriptControl")
    .Language = "JScript"
    Set jscript = .CodeObject
  End With
  Dim ix, sendBuffer
  For ix = 0 To UBound(sendArray) Step 1
    sendBuffer = Split(sendArray(ix), "=")
    sendArray(ix) = sendBuffer(0) & "=" & jscript.encodeURIComponent(sendBuffer(1))
  Next
  Set jscript = Nothing

  Dim data
  data = submitPost(host, url_path, Join(sendArray, "&"))

  If LenB(data) <= 0 Then
    downloadFilePost = False
    Exit Function
  End If

 'バイナリで書き込み
  With CreateObject("ADODB.Stream")
    .Type = 1
    .Open
    .Write data
    .SaveToFile savePath, 2
    .Close
  End With

  downloadFilePost = True

End Function

Permalink | 記事への反応(1) | 22:27

ツイートシェア