ASP類比POST提交請求上傳檔案

出處：http://www.hiahia.org/post/ASP類比POST提交請求上傳檔案.html

 

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