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. VBS中InStrRev函数的陷阱
  2. NETGEAR WNDRMAC路由器刷OpenWrt
  3. iPad mini 2绕过Apple ID激活锁
  4. VB6拾遗:轻量级COM对象
  5. iPad忘记SSH密码怎么办?

8 条评论 发表在“VBS模拟POST上传文件”上

  1. fio说道:

    高手可以加QQ交流吗
    1487960792

  2. prophetk说道:

    addfrom 和 addfile 没看懂
    是上传的固定形式么?

  3. ayanmw说道:

    博主 居然 这么多 vbs的文章…
    不知道博主干什么工作??

  4. g007008说道:

    按照这个方法,上传时出现http Erro 500错误,具体为 stream ended unexpectedly。
    为什么?

  5. 2558447649说道:

    不知道您是否上线,您的脚本很好用,但是只能Wscript.Echo UploadData.Upload(“”)如果返回页面较多看到显示不完全的html。无法实现WriteLine写到文档文件中作为后期字符处理。

  6. ayong说道:

    感谢博主,非常好的代码

  7. 小罗说道:

    感谢Demon兄弟的无私奉献以及严谨务求实的态度,你的代码帮了大忙,万分感谢!

留下回复