虚拟主机教程

Class XMLUpload
    Private xmlHttp
    Private objTemp
    Private adTypeBinary, adTypeText
    Private strCharset, strBoundary
 
    Private Sub Class_Initialize()
        adTypeBinary = 1
        adTypeText = 2
        Set xmlHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
        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 "User-Agent", "Mozilla/4.0 (compatible; MSIE 8.0; Windows NT 6.1; Trident/4.0; SLCC2; .NET CLR 2.0.50727; .NET CLR 3.5.30729; .NET CLR 3.0.30729)"
        'xmlHttp.setRequestHeader "Content-Length", objTemp.size
        xmlHttp.SetRequestHeader "Accept","image/jpeg, application/x-ms-application, image/gif, application/xaml+xml, image/pjpeg, application/x-ms-xbap, */*"
        If login_host<>"" then xmlHttp.SetRequestHeader "Host",login_host
        If phpCookie<>"" Then xmlHttp.SetRequestHeader "Cookie", phpCookie
	xmlHttp.send objTemp
        PageText = xmlHttp.responseText
        PageBody = xmlHttp.responseBody
    End Function
 
End Class