Here are a couple of VB6 functions that can be used to upload a zip file through an http post request.
Using ready-made Microsoft.XMLHTTP or WinHttp.WinHttpRequest.5.1
First the easy one, using XMLHTTP to do the actual work
Private Function pvPostFile(sUrl As String, sFileName As String, Optional ByVal bAsync As Boolean) As String
Const STR_BOUNDARY As String = "3fbd04f5-b1ed-4060-99b9-fca7ff59c113"
Dim nFile As Integer
Dim baBuffer() As Byte
Dim sPostData As String
'--- read file
nFile = FreeFile
Open sFileName For Binary Access Read As nFile
If LOF(nFile) > 0 Then
ReDim baBuffer(0 To LOF(nFile) - 1) As Byte
Get nFile, , baBuffer
sPostData = StrConv(baBuffer, vbUnicode)
End If
Close nFile
'--- prepare body
sPostData = "--" & STR_BOUNDARY & vbCrLf & _
"Content-Disposition: form-data; name=""uploadfile""; filename=""" & Mid$(sFileName, InStrRev(sFileName, "\") + 1) & """" & vbCrLf & _
"Content-Type: application/octet-stream" & vbCrLf & vbCrLf & _
sPostData & vbCrLf & _
"--" & STR_BOUNDARY & "--"
'--- post
With CreateObject("Microsoft.XMLHTTP")
.Open "POST", sUrl, bAsync
.SetRequestHeader "Content-Type", "multipart/form-data; boundary=" & STR_BOUNDARY
.Send pvToByteArray(sPostData)
If Not bAsync Then
pvPostFile = .ResponseText
End If
End With
End Function
Private Function pvToByteArray(sText As String) As Byte()
pvToByteArray = StrConv(sText, vbFromUnicode)
End Function
The biggest benefit of using XMLHTTP is the async option. MSXML spawns a worker thread that sends the request even if the last reference to the object is set to nothing.
Instead of Microsoft.XMLHTTP one can use WinHttp.WinHttpRequest.5.1 but setting the last object reference to nothing cancels the async request. Edit: Not true! It turned out Microsoft.XMLHTTP seems to get corrupted more often in the wild due to bad installers. We are now using WinHttp.WinHttpRequest.5.1 exclusively for our uploads.
Another caveat is the pvToByteArray function. It turns out send method can not handle “byref” byte arrays, so for instance passing baBuffer will fail, as VB6 sets up VT_BYREF bit of the type of the variant parameter.
Using wininet.dll API
Here is the hard-core API version. Biggest drawback is that it’s syncronous by nature.
Private Const INTERNET_AUTODIAL_FORCE_ONLINE As Long = 1
Private Const INTERNET_OPEN_TYPE_PRECONFIG As Long = 0
Private Const INTERNET_DEFAULT_HTTP_PORT As Long = 80
Private Const INTERNET_SERVICE_HTTP As Long = 3
Private Const INTERNET_FLAG_RELOAD As Long = &H80000000
Private Const HTTP_ADDREQ_FLAG_REPLACE As Long = &H80000000
Private Const HTTP_ADDREQ_FLAG_ADD As Long = &H20000000
Private Declare Function InternetAutodial Lib "wininet.dll" (ByVal dwFlags As Long, ByVal dwReserved As Long) As Long
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Private Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" (ByVal hInternetSession As Long, ByVal sServerName As String, ByVal nServerPort As Integer, ByVal sUsername As String, ByVal sPassword As String, ByVal lService As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function HttpOpenRequest Lib "wininet.dll" Alias "HttpOpenRequestA" (ByVal hHttpSession As Long, ByVal sVerb As String, ByVal sObjectName As String, ByVal sVersion As String, ByVal sReferer As String, ByVal something As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function HttpAddRequestHeaders Lib "wininet.dll" Alias "HttpAddRequestHeadersA" (ByVal hHttpRequest As Long, ByVal sHeaders As String, ByVal lHeadersLength As Long, ByVal lModifiers As Long) As Long
Private Declare Function HttpSendRequest Lib "wininet.dll" Alias "HttpSendRequestA" (ByVal hHttpRequest As Long, ByVal sHeaders As String, ByVal lHeadersLength As Long, ByVal sOptional As String, ByVal lOptionalLength As Long) As Long
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Long
Private Function pvPostFile(sUrl As String, sFileName As String) As Boolean
Const STR_APP_NAME As String = "Uploader"
Dim hOpen As Long
Dim hConnection As Long
Dim hRequest As Long
Dim sHeader As String
Dim sBoundary As String
Dim nFile As Integer
Dim baData() As Byte
Dim sPostData As String
Dim sHttpServer As String
Dim lHttpPort As Long
Dim sUploadPage As String
'--- read file
nFile = FreeFile
Open sFileName For Binary Access Read As nFile
If LOF(nFile) > 0 Then
ReDim baData(0 To LOF(nFile) - 1) As Byte
Get nFile, , baData
sPostData = StrConv(baData, vbUnicode)
End If
Close nFile
'--- parse url
sHttpServer = sUrl
If InStr(sHttpServer, "://") > 0 Then
sHttpServer = Mid$(sHttpServer, InStr(sHttpServer, "://") + 3)
End If
If InStr(sHttpServer, "/") > 0 Then
sUploadPage = Mid$(sHttpServer, InStr(sHttpServer, "/"))
sHttpServer = Left$(sHttpServer, InStr(sHttpServer, "/") - 1)
End If
If InStr(sHttpServer, ":") > 0 Then
On Error Resume Next
lHttpPort = CLng(Mid$(sHttpServer, InStr(sHttpServer, ":") + 1))
On Error GoTo 0
sHttpServer = Left$(sHttpServer, InStr(sHttpServer, ":") - 1)
End If
'--- prepare request
If InternetAutodial(INTERNET_AUTODIAL_FORCE_ONLINE, 0) = 0 Then
GoTo QH
End If
hOpen = InternetOpen(STR_APP_NAME, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
If hOpen = 0 Then
GoTo QH
End If
hConnection = InternetConnect(hOpen, sHttpServer, IIf(lHttpPort <> 0, lHttpPort, INTERNET_DEFAULT_HTTP_PORT), vbNullString, vbNullString, INTERNET_SERVICE_HTTP, 0, 0)
If hConnection = 0 Then
GoTo QH
End If
hRequest = HttpOpenRequest(hConnection, "POST", sUploadPage, "HTTP/1.0", vbNullString, 0, INTERNET_FLAG_RELOAD, 0)
If hRequest = 0 Then
GoTo QH
End If
'--- prepare headers
sBoundary = "3fbd04f5-b1ed-4060-99b9-fca7ff59c113"
sHeader = "Content-Type: multipart/form-data; boundary=" & sBoundary & vbCrLf
If HttpAddRequestHeaders(hRequest, sHeader, Len(sHeader), HTTP_ADDREQ_FLAG_REPLACE Or HTTP_ADDREQ_FLAG_ADD) = 0 Then
GoTo QH
End If
'--- post data
sPostData = "--" & sBoundary & vbCrLf & _
"Content-Disposition: multipart/form-data; name=""uploadfile""; filename=""" & Mid$(sFileName, InStrRev(sFileName, "\") + 1) & """" & vbCrLf & _
"Content-Type: application/octet-stream" & vbCrLf & vbCrLf & _
sPostData & vbCrLf & _
"--" & sBoundary & "--"
If HttpSendRequest(hRequest, vbNullString, 0, sPostData, Len(sPostData)) = 0 Then
GoTo QH
End If
'--- success
pvPostFile = True
QH:
If hRequest <> 0 Then
Call InternetCloseHandle(hRequest)
End If
If hConnection <> 0 Then
Call InternetCloseHandle(hConnection)
End If
If hOpen <> 0 Then
Call InternetCloseHandle(hOpen)
End If
End Function
It’s not hard adding authentication to send request but I don’t need it so never implemented it. The binary nature ot the upload is set by Content-Type being application/octet-stream.
Note that you cannot use Content-Transfer-Encoding with http, it’s reserved for e-mail only, i.e. no base64 encoding is necessary. Binary file is sent directly in the http stream. Note: feel free to change the boundary (use uuidgen.exe to generate a guid or anything unique).
The server-side script
Here is a simple upload_errors.php script that can be used as a target of the post request
<?php
$base_dir = dirname( __FILE__ ) . '/../ErrorsUpload/' . $_GET["id"];
if(!is_dir($base_dir))
mkdir($base_dir, 0777);
move_uploaded_file($_FILES["uploadfile"]["tmp_name"], $base_dir . '/' . $_FILES["uploadfile"]["name"]);
?>
Basicly it expects an id param in the url and an uploadfile param in the body. Id is used to create a sub-directory in an off-site (publicly not visible) directory ErrorsUpload where the uploaded zip file is stored.
Here as the caller code I’m using that accesses the above upload_errors.php
Private Sub Command1_Click()
pvPostFile "http://{{your_server_here}}/upload_errors.php?id={A0AD2346-9849-4EF0-9A93-ACFE17910734}", "C:\TEMP\Errors_2011_07_11.zip"
End Sub
I’m preparing a zip file with the errors that are logged at the client site, then I’m using the client id in the url, posting the zip file.
Edit: JScript implementation
Turns out byte-array to string handling is not so straight-forward in JScript. Here is a sample implementation of postFile function extensively using ADODB.Stream to handle conversions:
function readBinaryFile(fileName) {
var stream = WScript.CreateObject("ADODB.Stream");
stream.Type = 1;
stream.Open();
stream.LoadFromFile(fileName);
return stream.Read();
}
function toArray(str) {
var stream = WScript.CreateObject("ADODB.Stream");
stream.Type = 2;
stream.Charset = "_autodetect";
stream.Open()
stream.WriteText(str);
stream.Position = 0;
stream.Type = 1;
return stream.Read();
}
function postFile(url, fileName, async) {
var STR_BOUNDARY = "3fbd04f5-b1ed-4060-99b9-fca7ff59c113";
// prepare post data
var stream = WScript.CreateObject("ADODB.Stream");
stream.Type = 1;
stream.Open()
stream.Write(toArray("--" + STR_BOUNDARY + "\r\n" +
"Content-Disposition: form-data; name=\"uploadfile\"; filename=\"" + fileName.substr(fileName.lastIndexOf("\\") + 1, fileName.length) + "\"\r\n" +
"Content-Type: application/octet-stream\r\n\r\n"));
stream.Write(readBinaryFile(fileName));
stream.Write(toArray("\r\n--" + STR_BOUNDARY + "--"));
stream.Position = 0;
// post request
var xhr = WScript.CreateObject("Microsoft.XMLHTTP");
xhr.Open("POST", url, async);
xhr.SetRequestHeader("Content-Type", "multipart/form-data; boundary=" + STR_BOUNDARY);
xhr.Send(stream.Read());
if (async) WScript.Sleep(1);
}
IT blog 