VBS模拟POST上传文件

改写自CSDN上的一个ASP中模拟form上传文件，即（multipart/form-data）的表单的程序。原程序有些地方写错了，还一大堆人复制粘贴，真受不了。

'XML Upload Class
Class XMLUpload
    Private xmlHttp
    Private objTemp
    Private adTypeBinary, adTypeText
    Private strCharset, strBoundary

    Private Sub Class_Initialize()
        adTypeBinary = 1
        adTypeText = 2
        Set xmlHttp = CreateObject("Msxml2.XMLHTTP")
        Set objTemp = CreateObject("ADODB.Stream")
        objTemp.Type = adTypeBinary
        objTemp.Open
        strCharset = "utf-8"
        strBoundary = GetBoundary()
    End Sub

    Private Sub Class_Terminate()
        objTemp.Close
        Set objTemp = Nothing
        Set xmlHttp = Nothing
    End Sub

    '指定字符集的字符串转字节数组
    Public Function StringToBytes(ByVal strData, ByVal strCharset)
        Dim objFile
        Set objFile = 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

    '获取文件内容的字节数组
    Private Function GetFileBinary(ByVal strPath)
        Dim objFile
        Set objFile = CreateObject("ADODB.Stream")
        objFile.Type = adTypeBinary
        objFile.Open
        objFile.LoadFromFile strPath
        GetFileBinary = objFile.Read(-1)
        objFile.Close
        Set objFile = Nothing
    End Function

    '获取自定义的表单数据分界线
    Private Function GetBoundary()
        Dim ret(12)
        Dim table
        Dim i
        table = "abcdefghijklmnopqrstuvwxzy0123456789"
        Randomize
        For i = 0 To UBound(ret)
            ret(i) = Mid(table, Int(Rnd() * Len(table) + 1), 1)
        Next
        GetBoundary = "---------------------------" & Join(ret, Empty)
    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, ByVal strFilePath)
        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)
        objTemp.Write GetFileBinary(strFilePath)
    End Sub

    '设置multipart/form-data结束标记
    Private Sub AddEnd()
        Dim tmp
        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; boundary=" & strBoundary
        'xmlHttp.setRequestHeader "Content-Length", objTemp.size
        xmlHttp.Send objTemp
        Upload = xmlHttp.responseText
    End Function
End Class

Dim UploadData
Set UploadData = New XMLUpload
UploadData.Charset = "utf-8"
UploadData.AddForm "content", "Hello world" '文本域的名称和内容
UploadData.AddFile "file", "test.jpg", "image/jpg", "test.jpg"
WScript.Echo UploadData.Upload("http://example.com/takeupload.php")
Set UploadData = Nothing

随机文章:

1. OpenWrt配置he.net的6in4隧道访问IPv6
2. VBS深入CreateObject函数
3. 在WSH中使用jQuery
4. VBS中没有vbHide常量
5. VBS中InStrRev函数的陷阱

这篇文章发布于 2010年12月25日，星期六，23:04，归类于 程序设计。 您可以跟踪这篇文章的评论通过 RSS 2.0 feed。 您可以留下评论，或者从您的站点trackback。