'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
