ASP模拟POST提交请求,可以支持文件上传的multipart/form-data表单方式。其实就是熟悉HTTP协议,构造请求头部,原理清晰,关键是细节的构造过程,可以举一反三,推广到其他语言中去。这是相当经典的代码,好好搜藏吧,哈哈!
发送端,构造头部脚本:
<% 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 %> 接收端,剥离读取头部字段: <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)) %>