ASP模拟POST提交请求，可以支持文件上传的multipart/form-da
发送端，构造头部脚本：
<%
Public Const adTypeBinary = 1
Public Const adTypeText = 2
Public Const adLongVarBinary = 205
'字节数组转指定字符集的字符串
Public Function BytesToString(vtData, ByVal strCharset)
Dim objFile
Set objFile = Server.CreateObject("ADODB.Stream")
objFile.Type = adTypeBinary
objFile.Open
If VarType(vtData) = vbString Then
objFile.Write BinaryToBytes(vtData)
Else
objFile.Write vtData
End If
objFile.Position = 0
objFile.Type = adTypeText
objFile.Charset = strCharset
BytesToString = objFile.ReadText(-1)
objFile.Close
Set objFile = Nothing
End Function
'字节字符串转字节数组，即经过MidB/LeftB/RightB/ChrB等处理过的字符串
Public Function BinaryToBytes(vtData)
Dim rs
Dim lSize
lSize = LenB(vtData)
Set rs = Server.CreateObject("ADODB.RecordSet")
rs.Fields.Append "Content", adLongVarBinary, lSize
rs.Open
rs.AddNew
rs("Content").AppendChunk vtData
rs.Update
BinaryToBytes = rs("Content").GetChunk(lSize)
rs.Close
Set rs = Nothing
End Function
'指定字符集的字符串转字节数组
Public Function StringToBytes(ByVal strData, ByVal strCharset)
Dim objFile
Set objFile = Server.CreateObject("ADODB.Stream")
objFile.Type = adTypeText
objFile.Charset = strCharset
objFile.Open
objFile.WriteText strData
objFile.Position = 0
objFile.Type = adTypeBinary
If UCase(strCharset) = "UNICODE" Then
objFile.Position = 2 'delete UNICODE BOM
ElseIf UCase(strCharset) = "UTF-8" Then
objFile.Position = 3 'delete UTF-8 BOM
End If
StringToBytes = objFile.Read(-1)
objFile.Close
Set objFile = Nothing
End Function
'获取文件内容的字节数组
Public Function GetFileBinary(ByVal strPath)
Dim objFile
Set objFile = Server.CreateObject("ADODB.Stream")
objFile.Type = adTypeBinary
objFile.Open
objFile.LoadFromFile strPath
GetFileBinary = objFile.Read(-1)
objFile.Close
Set objFile = Nothing
End Function
'XML Upload Class
Class XMLUploadImpl
Private xmlHttp
Private objTemp
Private strCharset, strBoundary
Private Sub Class_Initialize()
Set xmlHttp = Server.CreateObject("MSXML2.ServerXMLHTTP")
Set objTemp = Server.CreateObject("ADODB.Stream")
objTemp.Type = adTypeBinary
objTemp.Open
strCharset = "GBK"
strBoundary = GetBoundary()
End Sub
Private Sub Class_Terminate()
objTemp.Close
Set objTemp = Nothing
Set xmlHttp = Nothing
End Sub
'获取自定义的表单数据分界线
Private Function GetBoundary()
Dim ret(24)
Dim table
Dim i
table = "ABCDEFGHIJKLMNOPQRSTUVWXZYabcdefghijklmnopqrstuvwxzy0123456789"
Randomize
For i = 0 To UBound(ret)
ret(i) = Mid(table, Int(Rnd() * Len(table) + 1), 1)
Next
GetBoundary = "__NextPart__ " & Join(ret, Empty)
End Function
Public Function Upload(ByVal strURL,ByVal cookiename,ByVal cookiecontent) '改进之后可以输出cookie session登录，哈哈
Call AddEnd
xmlHttp.Open "POST", strURL, False
if cookiename<>"" and cookiecontent<>"" then
xmlHttp.setRequestHeader "Cookie",cookiename&"="&cookiecontent&"; path=/; " '登录的cookie信息，以后可以用用户名 密码来尝试读取登录信息
end if
xmlHttp.setRequestHeader "User-Agent", "User-Agent: Mozilla/4.0 (compatible; OpenOffice.org)" '伪装浏览器
xmlHttp.setRequestHeader "Connection", "Keep-Alive"
xmlHttp.setRequestHeader "Content-Type", "multipart/form-data; boundary="&strBoundary 'PHP的问题就出在这里，没有指定分隔符号，自己不会分析读取，哈哈！搞定
xmlHttp.setRequestHeader "Content-Length", objTemp.size
xmlHttp.Send objTemp
If VarType(xmlHttp.responseBody) = (vbByte Or vbArray) Then
Upload = BytesToString(xmlHttp.responseBody, strCharset)
End If
End Function
Public Function GetResponse()
GetResponse=xmlHttp.getResponseHeader("Set-Cookie") 'getAllResponseHeaders("Set-Cookie") 获取cookie字符串
End Function
'设置上传使用的字符集
Public Property Let Charset(ByVal strValue)
strCharset = strValue
End Property
'添加文本域的名称和值
Public Sub AddForm(ByVal strName, ByVal strValue)
Dim tmp
tmp = "\r\n--$1\r\nContent-Disposition: form-data; name=""$2""\r\n\r\n$3"
tmp = Replace(tmp, "\r\n", vbCrLf)
tmp = Replace(tmp, "$1", strBoundary)
tmp = Replace(tmp, "$2", strName)
tmp = Replace(tmp, "$3", strValue)
objTemp.Write StringToBytes(tmp, strCharset)
End Sub
'设置文件域的名称/文件名称/文件MIME类型/文件路径或文件字节数组
Public Sub AddFile(ByVal strName, ByVal strFileName, ByVal strFileType, vtValue)
Dim tmp
tmp = "\r\n--$1\r\nContent-Disposition: form-data; name=""$2""; filename=""$3""\r\nContent-Type: $4\r\n\r\n"
tmp = Replace(tmp, "\r\n", vbCrLf)
tmp = Replace(tmp, "$1", strBoundary)
tmp = Replace(tmp, "$2", strName)
tmp = Replace(tmp, "$3", strFileName)
tmp = Replace(tmp, "$4", strFileType)
objTemp.Write StringToBytes(tmp, strCharset)
If VarType(vtValue) = (vbByte Or vbArray) Then
objTemp.Write vtValue
Else
objTemp.Write GetFileBinary(vtValue)
End If
End Sub
'设置multipart/form-data结束标记
Private Sub AddEnd()
Dim tmp
'tmp = Replace("\r\n--$1--\r\n", "$1", strBoundary)
tmp = "\r\n--$1--\r\n"
tmp = Replace(tmp, "\r\n", vbCrLf)
tmp = Replace(tmp, "$1", strBoundary)
objTemp.Write StringToBytes(tmp, strCharset)
objTemp.Position = 2
End Sub
'上传到指定的URL，并返回服务器应答
Public Function Upload(ByVal strURL)
Call AddEnd
xmlHttp.Open "POST", strURL, False
xmlHttp.setRequestHeader "Content-Type", "multipart/form-data"
xmlHttp.setRequestHeader "Content-Length", objTemp.size
xmlHttp.Send objTemp
If VarType(xmlHttp.responseBody) = (vbByte Or vbArray) Then
Upload = BytesToString(xmlHttp.responseBody, strCharset)
End If
End Function
End Class
%>
Public Const adTypeBinary = 1
Public Const adTypeText = 2
Public Const adLongVarBinary = 205
'字节数组转指定字符集的字符串
Public Function BytesToString(vtData, ByVal strCharset)
Dim objFile
Set objFile = Server.CreateObject("ADODB.Stream")
objFile.Type = adTypeBinary
objFile.Open
If VarType(vtData) = vbString Then
objFile.Write BinaryToBytes(vtData)
Else
objFile.Write vtData
End If
objFile.Position = 0
objFile.Type = adTypeText
objFile.Charset = strCharset
BytesToString = objFile.ReadText(-1)
objFile.Close
Set objFile = Nothing
End Function
'字节字符串转字节数组，即经过MidB/LeftB/RightB/ChrB等处理过的字符串
Public Function BinaryToBytes(vtData)
Dim rs
Dim lSize
lSize = LenB(vtData)
Set rs = Server.CreateObject("ADODB.RecordSet")
rs.Fields.Append "Content", adLongVarBinary, lSize
rs.Open
rs.AddNew
rs("Content").AppendChunk vtData
rs.Update
BinaryToBytes = rs("Content").GetChunk(lSize)
rs.Close
Set rs = Nothing
End Function
'指定字符集的字符串转字节数组
Public Function StringToBytes(ByVal strData, ByVal strCharset)
Dim objFile
Set objFile = Server.CreateObject("ADODB.Stream")
objFile.Type = adTypeText
objFile.Charset = strCharset
objFile.Open
objFile.WriteText strData
objFile.Position = 0
objFile.Type = adTypeBinary
If UCase(strCharset) = "UNICODE" Then
objFile.Position = 2 'delete UNICODE BOM
ElseIf UCase(strCharset) = "UTF-8" Then
objFile.Position = 3 'delete UTF-8 BOM
End If
StringToBytes = objFile.Read(-1)
objFile.Close
Set objFile = Nothing
End Function
'获取文件内容的字节数组
Public Function GetFileBinary(ByVal strPath)
Dim objFile
Set objFile = Server.CreateObject("ADODB.Stream")
objFile.Type = adTypeBinary
objFile.Open
objFile.LoadFromFile strPath
GetFileBinary = objFile.Read(-1)
objFile.Close
Set objFile = Nothing
End Function
'XML Upload Class
Class XMLUploadImpl
Private xmlHttp
Private objTemp
Private strCharset, strBoundary
Private Sub Class_Initialize()
Set xmlHttp = Server.CreateObject("MSXML2.ServerXMLHTTP")
Set objTemp = Server.CreateObject("ADODB.Stream")
objTemp.Type = adTypeBinary
objTemp.Open
strCharset = "GBK"
strBoundary = GetBoundary()
End Sub
Private Sub Class_Terminate()
objTemp.Close
Set objTemp = Nothing
Set xmlHttp = Nothing
End Sub
'获取自定义的表单数据分界线
Private Function GetBoundary()
Dim ret(24)
Dim table
Dim i
table = "ABCDEFGHIJKLMNOPQRSTUVWXZYabcdefghijklmnopqrstuvwxzy0123456789"
Randomize
For i = 0 To UBound(ret)
ret(i) = Mid(table, Int(Rnd() * Len(table) + 1), 1)
Next
GetBoundary = "__NextPart__ " & Join(ret, Empty)
End Function
Public Function Upload(ByVal strURL,ByVal cookiename,ByVal cookiecontent) '改进之后可以输出cookie session登录，哈哈
Call AddEnd
xmlHttp.Open "POST", strURL, False
if cookiename<>"" and cookiecontent<>"" then
xmlHttp.setRequestHeader "Cookie",cookiename&"="&cookiecontent&"; path=/; " '登录的cookie信息，以后可以用用户名 密码来尝试读取登录信息
end if
xmlHttp.setRequestHeader "User-Agent", "User-Agent: Mozilla/4.0 (compatible; OpenOffice.org)" '伪装浏览器
xmlHttp.setRequestHeader "Connection", "Keep-Alive"
xmlHttp.setRequestHeader "Content-Type", "multipart/form-data; boundary="&strBoundary 'PHP的问题就出在这里，没有指定分隔符号，自己不会分析读取，哈哈！搞定
xmlHttp.setRequestHeader "Content-Length", objTemp.size
xmlHttp.Send objTemp
If VarType(xmlHttp.responseBody) = (vbByte Or vbArray) Then
Upload = BytesToString(xmlHttp.responseBody, strCharset)
End If
End Function
Public Function GetResponse()
GetResponse=xmlHttp.getResponseHeader("Set-Cookie") 'getAllResponseHeaders("Set-Cookie") 获取cookie字符串
End Function
'设置上传使用的字符集
Public Property Let Charset(ByVal strValue)
strCharset = strValue
End Property
'添加文本域的名称和值
Public Sub AddForm(ByVal strName, ByVal strValue)
Dim tmp
tmp = "\r\n--$1\r\nContent-Disposition: form-data; name=""$2""\r\n\r\n$3"
tmp = Replace(tmp, "\r\n", vbCrLf)
tmp = Replace(tmp, "$1", strBoundary)
tmp = Replace(tmp, "$2", strName)
tmp = Replace(tmp, "$3", strValue)
objTemp.Write StringToBytes(tmp, strCharset)
End Sub
'设置文件域的名称/文件名称/文件MIME类型/文件路径或文件字节数组
Public Sub AddFile(ByVal strName, ByVal strFileName, ByVal strFileType, vtValue)
Dim tmp
tmp = "\r\n--$1\r\nContent-Disposition: form-data; name=""$2""; filename=""$3""\r\nContent-Type: $4\r\n\r\n"
tmp = Replace(tmp, "\r\n", vbCrLf)
tmp = Replace(tmp, "$1", strBoundary)
tmp = Replace(tmp, "$2", strName)
tmp = Replace(tmp, "$3", strFileName)
tmp = Replace(tmp, "$4", strFileType)
objTemp.Write StringToBytes(tmp, strCharset)
If VarType(vtValue) = (vbByte Or vbArray) Then
objTemp.Write vtValue
Else
objTemp.Write GetFileBinary(vtValue)
End If
End Sub
'设置multipart/form-data结束标记
Private Sub AddEnd()
Dim tmp
'tmp = Replace("\r\n--$1--\r\n", "$1", strBoundary)
tmp = "\r\n--$1--\r\n"
tmp = Replace(tmp, "\r\n", vbCrLf)
tmp = Replace(tmp, "$1", strBoundary)
objTemp.Write StringToBytes(tmp, strCharset)
objTemp.Position = 2
End Sub
'上传到指定的URL，并返回服务器应答
Public Function Upload(ByVal strURL)
Call AddEnd
xmlHttp.Open "POST", strURL, False
xmlHttp.setRequestHeader "Content-Type", "multipart/form-data"
xmlHttp.setRequestHeader "Content-Length", objTemp.size
xmlHttp.Send objTemp
If VarType(xmlHttp.responseBody) = (vbByte Or vbArray) Then
Upload = BytesToString(xmlHttp.responseBody, strCharset)
End If
End Function
End Class
%>
<%
'在包含该文件后用以下代码调用
'VB code
Dim UploadData
Set UploadData = New XMLUploadImpl
UploadData.Charset = "gb2312"
UploadData.AddForm "Test", "123456" '文本域的名称和内容
'UploadData.AddFile "ImgFile", "F:\test.jpg", "image/jpg", GetFileBinary("F:\test.jpg")'图片或者其它文件
UploadData.AddFile "ImgFile", Server.MapPath("test.jpg"), "image/jpg", GetFileBinary(Server.MapPath("test.jpg"))'图片或者其它文件
Response.Write UploadData.Upload("http://localhost/receive.asp") 'receive.asp为接收页面
Set UploadData = Nothing
%>
'在包含该文件后用以下代码调用
'VB code
Dim UploadData
Set UploadData = New XMLUploadImpl
UploadData.Charset = "gb2312"
UploadData.AddForm "Test", "123456" '文本域的名称和内容
'UploadData.AddFile "ImgFile", "F:\test.jpg", "image/jpg", GetFileBinary("F:\test.jpg")'图片或者其它文件
UploadData.AddFile "ImgFile", Server.MapPath("test.jpg"), "image/jpg", GetFileBinary(Server.MapPath("test.jpg"))'图片或者其它文件
Response.Write UploadData.Upload("http://localhost/receive.asp") 'receive.asp为接收页面
Set UploadData = Nothing
%>
接收端，剥离读取头部字段：
<meta http-equiv="Content-Type" content="text/html; charset=GB2312" />
<%
Sub BuildUploadRequest(RequestBin)
'Get the boundary
PosBeg = 1
PosEnd = InstrB(PosBeg,RequestBin,getByteString(chr(13)))
boundary = MidB(RequestBin,PosBeg,PosEnd-PosBeg)
boundaryPos = InstrB(1,RequestBin,boundary)
'Get all data inside the boundaries
Do until (boundaryPos=InstrB(RequestBin,boundary & getByteString("--")))
'Members variable of objects are put in a dictionary object
Dim UploadControl
Set UploadControl = CreateObject("Scripting.Dictionary")
'Get an object name
Pos = InstrB(BoundaryPos,RequestBin,getByteString("Content-Disposition"))
Pos = InstrB(Pos,RequestBin,getByteString("name="))
PosBeg = Pos+6
PosEnd = InstrB(PosBeg,RequestBin,getByteString(chr(34)))
Name = getString(MidB(RequestBin,PosBeg,PosEnd-PosBeg))
PosFile = InstrB(BoundaryPos,RequestBin,getByteString("filename="))
PosBound = InstrB(PosEnd,RequestBin,boundary)
'Test if object is of file type
If PosFile<>0 AND (PosFile<PosBound) Then
'Get Filename, content-type and content of file
PosBeg = PosFile + 10
PosEnd = InstrB(PosBeg,RequestBin,getByteString(chr(34)))
FileName = getString(MidB(RequestBin,PosBeg,PosEnd-PosBeg))
'Add filename to dictionary object
UploadControl.Add "FileName", FileName
Pos = InstrB(PosEnd,RequestBin,getByteString("Content-Type:"))
PosBeg = Pos+14
PosEnd = InstrB(PosBeg,RequestBin,getByteString(chr(13)))
'Add content-type to dictionary object
ContentType = getString(MidB(RequestBin,PosBeg,PosEnd-PosBeg))
UploadControl.Add "ContentType",ContentType
'Get content of object
PosBeg = PosEnd+4
PosEnd = InstrB(PosBeg,RequestBin,boundary)-2
Value = MidB(RequestBin,PosBeg,PosEnd-PosBeg)
Else
'Get content of object
Pos = InstrB(Pos,RequestBin,getByteString(chr(13)))
PosBeg = Pos+4
PosEnd = InstrB(PosBeg,RequestBin,boundary)-2
Value = getString(MidB(RequestBin,PosBeg,PosEnd-PosBeg))
End If
'Add content to dictionary object
UploadControl.Add "Value" , Value
'Add dictionary object to main dictionary
UploadRequest.Add name, UploadControl
'Loop to next object
BoundaryPos=InstrB(BoundaryPos+LenB(boundary),RequestBin,boundary)
Loop
End Sub
<!--webbot bot="PurpleText" PREVIEW="end of建立上传数据字典的函数" -->
'String to byte string conversion
Function getByteString(StringStr)
For i = 1 to Len(StringStr)
char = Mid(StringStr,i,1)
getByteString = getByteString & chrB(AscB(char))
Next
End Function
'Byte string to string conversion(hoho,this can deal with chinese!!!)
Function getString(str)
strto = ""
for i=1 to lenb(str)
if AscB(MidB(str, i, 1)) > 127 then
strto = strto & chr(Ascb(MidB(str, i, 1))*256+Ascb(MidB(str, i+1, 1)))
i = i + 1
else
strto = strto & Chr(AscB(MidB(str, i, 1)))
end if
next
getString=strto
End Function
Function getStringold(StringBin)
getString =""
For intCount = 1 to LenB(StringBin)
getString = getString & chr(AscB(MidB(StringBin,intCount,1)))
Next
End Function
<!--webbot bot="PurpleText" PREVIEW="开始添加到数据库中去" -->
Response.Buffer = TRUE
Response.Clear
byteCount = Request.TotalBytes
'获得字节数
RequestBin = Request.BinaryRead(byteCount)
Dim UploadRequest
Set UploadRequest = CreateObject("Scripting.Dictionary")
BuildUploadRequest RequestBin
filepath= UploadRequest.Item("ImgFile").Item("FileName") '获取上传文件的完整目录名字
compoundpic = UploadRequest.Item("ImgFile").Item("Value")
response.write(filepath&" size:"&len(compoundpic))
%>
Sub BuildUploadRequest(RequestBin)
'Get the boundary
PosBeg = 1
PosEnd = InstrB(PosBeg,RequestBin,getByteString(chr(13)))
boundary = MidB(RequestBin,PosBeg,PosEnd-PosBeg)
boundaryPos = InstrB(1,RequestBin,boundary)
'Get all data inside the boundaries
Do until (boundaryPos=InstrB(RequestBin,boundary & getByteString("--")))
'Members variable of objects are put in a dictionary object
Dim UploadControl
Set UploadControl = CreateObject("Scripting.Dictionary")
'Get an object name
Pos = InstrB(BoundaryPos,RequestBin,getByteString("Content-Disposition"))
Pos = InstrB(Pos,RequestBin,getByteString("name="))
PosBeg = Pos+6
PosEnd = InstrB(PosBeg,RequestBin,getByteString(chr(34)))
Name = getString(MidB(RequestBin,PosBeg,PosEnd-PosBeg))
PosFile = InstrB(BoundaryPos,RequestBin,getByteString("filename="))
PosBound = InstrB(PosEnd,RequestBin,boundary)
'Test if object is of file type
If PosFile<>0 AND (PosFile<PosBound) Then
'Get Filename, content-type and content of file
PosBeg = PosFile + 10
PosEnd = InstrB(PosBeg,RequestBin,getByteString(chr(34)))
FileName = getString(MidB(RequestBin,PosBeg,PosEnd-PosBeg))
'Add filename to dictionary object
UploadControl.Add "FileName", FileName
Pos = InstrB(PosEnd,RequestBin,getByteString("Content-Type:"))
PosBeg = Pos+14
PosEnd = InstrB(PosBeg,RequestBin,getByteString(chr(13)))
'Add content-type to dictionary object
ContentType = getString(MidB(RequestBin,PosBeg,PosEnd-PosBeg))
UploadControl.Add "ContentType",ContentType
'Get content of object
PosBeg = PosEnd+4
PosEnd = InstrB(PosBeg,RequestBin,boundary)-2
Value = MidB(RequestBin,PosBeg,PosEnd-PosBeg)
Else
'Get content of object
Pos = InstrB(Pos,RequestBin,getByteString(chr(13)))
PosBeg = Pos+4
PosEnd = InstrB(PosBeg,RequestBin,boundary)-2
Value = getString(MidB(RequestBin,PosBeg,PosEnd-PosBeg))
End If
'Add content to dictionary object
UploadControl.Add "Value" , Value
'Add dictionary object to main dictionary
UploadRequest.Add name, UploadControl
'Loop to next object
BoundaryPos=InstrB(BoundaryPos+LenB(boundary),RequestBin,boundary)
Loop
End Sub
<!--webbot bot="PurpleText" PREVIEW="end of建立上传数据字典的函数" -->
'String to byte string conversion
Function getByteString(StringStr)
For i = 1 to Len(StringStr)
char = Mid(StringStr,i,1)
getByteString = getByteString & chrB(AscB(char))
Next
End Function
'Byte string to string conversion(hoho,this can deal with chinese!!!)
Function getString(str)
strto = ""
for i=1 to lenb(str)
if AscB(MidB(str, i, 1)) > 127 then
strto = strto & chr(Ascb(MidB(str, i, 1))*256+Ascb(MidB(str, i+1, 1)))
i = i + 1
else
strto = strto & Chr(AscB(MidB(str, i, 1)))
end if
next
getString=strto
End Function
Function getStringold(StringBin)
getString =""
For intCount = 1 to LenB(StringBin)
getString = getString & chr(AscB(MidB(StringBin,intCount,1)))
Next
End Function
<!--webbot bot="PurpleText" PREVIEW="开始添加到数据库中去" -->
Response.Buffer = TRUE
Response.Clear
byteCount = Request.TotalBytes
'获得字节数
RequestBin = Request.BinaryRead(byteCount)
Dim UploadRequest
Set UploadRequest = CreateObject("Scripting.Dictionary")
BuildUploadRequest RequestBin
filepath= UploadRequest.Item("ImgFile").Item("FileName") '获取上传文件的完整目录名字
compoundpic = UploadRequest.Item("ImgFile").Item("Value")
response.write(filepath&" size:"&len(compoundpic))
%>