[轉]ASP模拟POST提交请求上传文件

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))

% >