Hello Bob,
Below is a condensed version of the source code.
Posting 'FormDataCv' as the send parameter works fine. Posting
'FormDataXml' as send parameter works fine as well. The problem is
pasting them together. Running the code below will generates a 'data
stream is interrupted unexpectedly' because of the Word file not
getting the completely with boundary and all.
Thanks for your time in advance.
Fnoppie
<%
Dim baseUrl
Dim loginUrl
Dim userName
Dim passWord
Dim account
Dim processUrl
Const WinHttpRequestOption_EnableRedirects = 6
account = "account"
userName = "username"
passWord = "password"
baseUrl = "some/url"
loginUrl = "some/url"
processUrl = "some/url"
Function BinaryToString(Binary)
'Antonin Foller,
http://www.motobit.com
'Optimized version of a simple BinaryToString algorithm.
Dim cl1, cl2, cl3, pl1, pl2, pl3
Dim L
cl1 = 1
cl2 = 1
cl3 = 1
L = LenB(Binary)
Do While cl1<=L
pl3 = pl3 & Chr(AscB(MidB(Binary,cl1,1)))
cl1 = cl1 + 1
cl3 = cl3 + 1
If cl3>300 Then
pl2 = pl2 & pl3
pl3 = ""
cl3 = 1
cl2 = cl2 + 1
If cl2>200 Then
pl1 = pl1 & pl2
pl2 = ""
cl2 = 1
End If
End If
Loop
BinaryToString = pl1 & pl2 & pl3
End Function
'---------------------------------------------------------------------
Function CreateTrxml()
strXml = "<?xml version=""1.0"" encoding=""ISO-8859-1""?>"
strXml = strXml & "<Result user=""1"" xmlns='http://
www.someurl.nl'>"
strXml = strXml & "<Document lang=""dutch""/>"
strXml = strXml & "<DocumentStructure>"
strXml = strXml & "<ItemGroup count=""1"" key=""lastname"">"
strXml = strXml & "<Item index=""0"">"
strXml = strXml & "<Field key=""lastname"">"
strXml = strXml & "<Value>opberg</Value>"
strXml = strXml & "</Field>"
strXml = strXml & "</Item>"
strXml = strXml & "</ItemGroup>"
strXml = strXml & "</DocumentStructure>"
strXml = strXml & "</Result>"
CreateTrxml = strXml
End Function
'---------------------------------------------------------------------------
Sub do_vbsUpload(FileName)
DestURL= processUrl
FieldName = "uplfile"
UploadFile DestURL, FileName, FieldName
End Sub
'Upload file using input type=file
Sub UploadFile(DestURL, FileName, FieldName)
'Boundary of fields.
'Be sure this string is Not In the source file
Const Boundary = "0123456789012"
Dim FileContents, FormData
'Get source file As a binary data.
FileContents = GetFile(FileName)
'Build multipart/form-data document
FormDataCv = BuildFormData(FileContents, Boundary, FileName,
FieldName)
FormDataXml = BuildFormDataXml(CreateTrxml(), Boundary,
"trxml.xml", "trxml")
FormData = FormDataXml + cstr(FormDataCv)
'Post the data To the destination URL
IEPostBinaryRequest DestURL, FormData, Boundary
End Sub
'Build multipart/form-data document with file contents And header
info
Function BuildFormData(FileContents, Boundary, FileName, FieldName)
Dim FormData, Pre, Po
Const ContentType = "application/msword"
'The two parts around file contents In the multipart-form data.
'Pre = "--" + Boundary + vbCrLf + mpFields(FieldName, FileName,
ContentType)
Pre = mpFields(FieldName, FileName, ContentType)
Po = vbCrLf + "--" + Boundary + "--" + vbCrLf
'Build form data using recordset binary field
Const adLongVarBinary = 205
Dim RS: Set RS = CreateObject("ADODB.Recordset")
RS.Fields.Append "b", adLongVarBinary, Len(Pre) + LenB(FileContents)
+ Len(Po)
RS.Open
RS.AddNew
Dim LenData
'Convert Pre string value To a binary data
LenData = Len(Pre)
RS("b").AppendChunk (StringToMB(Pre) & ChrB(0))
Pre = RS("b").GetChunk(LenData)
RS("b") = ""
'Convert Po string value To a binary data
LenData = Len(Po)
RS("b").AppendChunk (StringToMB(Po) & ChrB(0))
Po = RS("b").GetChunk(LenData)
RS("b") = ""
'Join Pre + FileContents + Po binary data
RS("b").AppendChunk (Pre)
RS("b").AppendChunk (FileContents)
RS("b").AppendChunk (Po)
RS.Update
FormData = RS("b")
RS.Close
BuildFormData = FormData
End Function
Function BuildFormDataxml(FileContents, Boundary, FileName,
FieldName)
'response.write filecontents
Dim FormData, Pre, Po
Const ContentType = "text/xml"
'The two parts around file contents In the multipart-form data.
Pre = "--" + Boundary + vbCrLf + mpFields(FieldName, FileName,
ContentType)
Po = vbCrLf + "--" + Boundary + vbCrLf
FormData = Pre & FileContents & Po
BuildFormDataxml = FormData
End Function
'sends multipart/form-data To the URL
Function IEPostBinaryRequest(URL, FormData, Boundary)
set req = Server.CreateObject("WinHttp.WinHttpRequest.5.1")
req.option(WinHttpRequestOption_EnableRedirects) = False
response.write "<p>url: " & URL & "</p>"
req.open "POST", URL, False
req.setRequestHeader "Content-Type", "multipart/form-data;
boundary=" & boundary
req.send FormData
response.write "<h1>req.getAllResponseHeaders: " &
req.getAllResponseHeaders() & "</h1>"
response.write "<h1>status: " & req.status & "</h1>"
response.write "<h1>statustext: " & req.statusText & "</h1>"
response.write req.responseText
End Function
'Information In form field header.
Function mpFields(FieldName, FileName, ContentType)
Dim MPTemplate 'template For multipart header
MPTemplate = "Content-Disposition: form-data; name=""{field}"";" + _
" filename=""{file}""" + vbCrLf + _
"Content-Type: {ct}" + vbCrLf + vbCrLf
Dim Out
Out = Replace(MPTemplate, "{field}", FieldName)
Out = Replace(Out, "{file}", FileName)
mpFields = Replace(Out, "{ct}", ContentType)
End Function
'Makes File Binary
Function GetFile(FileName)
Dim Stream: Set Stream = CreateObject("ADODB.Stream")
Stream.Type = 1 'Binary
Stream.Open
Stream.LoadFromFile FileName
GetFile = Stream.Read
Stream.Close
End Function
'Converts OLE string To multibyte string
Function StringToMB(S)
Dim I, B
For I = 1 To Len(S)
B = B & ChrB(Asc(Mid(S, I, 1)))
Next
StringToMB = B
End Function
do_vbsUpload upl.form("file")
%>