'*********************************************************************************** '***本程序可以自由传播,本人不对您使用本软件及代码造成的任何后果承担任何责任** '***利用此代码挣钱了也无需告诉我****** '***作者:龙小龙 QQ:31519488,部分代码来源于网络*** '***感谢中国农业人才网www.5ajob.com 大力支持*** '***中国农业人才网,让伯乐与千里马不再是偶遇*** '*********************************************************************************** ''' VB文件上传类,可以同时传多个文件 文字内容,也可以从网页上抓图片再上传 Public c_strDestURL As String Public c_strFileName As String Public c_strFieldName As String Public c_strBoundary As String Public c_strContentType As String ' text/plain or image/pjpeg and so on "application/upload" text/plain Public c_param As Dictionary '格式key->字段名 value->类型|属性|内容 '字段名 类型|属性|内容 '类型 目前有txt = 0 '文本pic = 1 '图片File = 2 '文件 URL = 3 '网址 '属性是类型下的属性 比如pic 下的属性就是文件格式pic jpg png等 'With c_param '.add "pic", "url|pic|http://www.xx.com/1.jpg" '.add "pic1", "pic|jpg|C:\Documents and Settings\Administrator\桌面\1.jpg" '.add "status", "txt|raw|大家好y" '.add "txtfile", "file|txt|C:\Documents and Settings\Administrator\桌面\1.txt" 'End With Public c_strResponseText As String Public c_boolPrepared As Boolean Public c_strErrMsg As String Private Type Field s_FieldName As String '字段名 s_FieldValue As String '字段值 s_FieldType As String '字段类型 s_FieldPro As String '字段属性 s_FieldCon As String '字段内容 End Type 'Private Enum FieldType 'txt = 0 '文本 'pic = 1 '图片 'File = 2 '文件 'URL = 3 '网址 'End Enum Public Sub Class_Initialize() c_strDestURL = "" c_strFileName = "" c_strContentType = "application/upload" c_strFieldName = "file" c_strBoundary = "---------------------------" & LCase(c10ton(Right("0" & Day(Date), 2) & Right("0" & Hour(Time), 2) & Right("0" & Minute(Time), 2) & Right("0" & Second(Time), 2), 16)) c_boolPrepared = False End Sub Public Sub Class_Terminate() End Sub ''' 公共调用函数,文件上传 Public Function vbsUpload() Call CheckRequirements If c_boolPrepared Then UploadFile c_strDestURL, c_param Else ' c_strErrMsg End If End Function ''' 检查程序工作环境 Private Function CheckRequirements() On Error Resume Next CreateObject ("MSXML2.XMLHTTP") If Not Err = 0 Then c_strErrMsg = c_strErrMsg & vbCrLf & Err.Descriptiof Else c_boolPrepared = True End If End Function ''' 文件上传 Private Function UploadFile(ByVal DestURL As String, ByVal param As Dictionary) Boundary = c_strBoundary bFormData = BuildFormData(Boundary, param) ' Debug.Print rsBinarytoString(bFormData) WinHTTPPostRequest DestURL, bFormData, Boundary End Function ''' WinHTTPPostRequest Private Function WinHTTPPostRequest(URL, FormData, Boundary) Dim xmlhttp Set xmlhttp = CreateObject("MSXML2.XMLHTTP") On Error Resume Next xmlhttp.open "POST", URL, False xmlhttp.setRequestHeader "Content-Type", "multipart/form-data; boundary=" + Boundary xmlhttp.send FormData c_strResponseText = xmlhttp.responseText ' 服务端返回信息 Set xmlhttp = Nothing End Function '''组合上传数据包 multipart/form-data document Header + Content Private Function BuildFormData(ByVal Boundary As String, ByVal param As Dictionary) Dim FileContents() As Byte, FormData() As Byte Dim Pre As String Dim Po As String ' Boundary = c_strBoundary Const adlongvarbinary = 205 Dim rs: Set rs = CreateObject("ADODB.Recordset") rs.Fields.Append "b", adlongvarbinary, 100 rs.open rs.AddNew Pre = "--" '+ Boundary + vbCrLf ' Debug.Print Pre; FormData = SaveStringToByteArry(Pre) rs("b").AppendChunk (FormData) Dim i As Integer, t As Integer Dim tempstr As String, FieldVaue As String For i = 0 To param.Count - 1 two = IIf(t > 0, vbCrLf & "--", "") '如果有1个以上的字段,中间的就要多2个--,很关键,否则只能传成功1个文件. Dim sField As Field, aFieldVaue With sField .s_FieldName = param.Keys(i) .s_FieldValue = param.Items(i) If InStr(.s_FieldValue, "|") = 0 Then .s_FieldValue = "txt|raw|" & .s_FieldValue End If aFieldVaue = Split(.s_FieldValue, "|") .s_FieldType = aFieldVaue(0) .s_FieldPro = aFieldVaue(1) .s_FieldCon = aFieldVaue(2) ' MsgBox .s_FieldName Select Case LCase(.s_FieldType) Case "txt" ' Select Case LCase(.s_FieldPro) ' Case "raw" ' .s_FieldCon = UTF8Encode(.s_FieldCon) ' Case Else ' End Select tempstr = txtFields(.s_FieldName, two & Boundary) FormData = SaveStringToByteArry(tempstr) '二进制头 rs("b").AppendChunk (FormData) FormData = stream_StringtoBinary(.s_FieldCon, "UTF-8") rs("b").AppendChunk (FormData) tempstr = vbCrLf '后面有个回车 FormData = SaveStringToByteArry(tempstr) '二进制头 rs("b").AppendChunk (FormData) Case "pic", "file" FileContents = GetFile(.s_FieldCon) ' 二进制文件内容 Select Case LCase(.s_FieldPro) Case "gif" ContentType = "image/gif" Case "jpg" ContentType = "image/pjpeg" Case "png" ContentType = "image/x-png" Case "txt" ContentType = "application/upload" Case Else ContentType = "image/unknow" End Select tempstr = mpFields(.s_FieldName, .s_FieldCon, ContentType, two & Boundary) FormData = SaveStringToByteArry(tempstr) '二进制文件头 rs("b").AppendChunk (FormData) rs("b").AppendChunk (FileContents) '二进制文件本身 Case "url" '抓取网页上的图片 If SaveRemoteFile2Bin(.s_FieldCon, FileContents) = True Then ContentType = "image/unknow" tempstr = mpFields(.s_FieldName, .s_FieldCon, ContentType, two & Boundary) FormData = SaveStringToByteArry(tempstr) '二进制文件头 rs("b").AppendChunk (FormData) rs("b").AppendChunk (FileContents) '二进制文件本身 End If End Select End With t = t + 1 Next Po = vbCrLf + "--" + Boundary + "--" + vbCrLf ' FormData = SaveStringToByteArry(Po) rs("b").AppendChunk (FormData) rs.Update BuildFormData = rs("b") rs.Close End Function 'Converts OLE string To multibyte string Private Function StringToMB(ByVal sCon As String) Dim i, tempstr For i = 1 To Len(sCon) tempstr = tempstr & ChrB(Asc(Mid(sCon, i, 1))) Next StringToMB = tempstr End Function ''' 组织HTTP头 Private Function mpFields(ByVal FieldName As String, ByVal FileName As String, ByVal ContentType As String, ByVal Boundary As String) Dim MPTemplate 'template For multipart header MPTemplate = "{boundary}" + vbCrLf + "Content-Disposition: form-data; name=""{field}"";" + _ " filename=""{file}""" + vbCrLf + _ "Content-Type: {ct}" + vbCrLf + vbCrLf Dim Out Out = Replace(MPTemplate, "{field}", FieldName) Out = Replace(Out, "{file}", FileName) Out = Replace(Out, "{boundary}", Boundary) mpFields = Replace(Out, "{ct}", ContentType) End Function Private Function txtFields(ByVal FieldName As String, ByVal Boundary As String) txtContentTemplate = "{boundary}" + vbCrLf + "Content-Disposition: form-data; name=""{0}""" + vbCrLf + vbCrLf Dim Out Out = Replace(txtContentTemplate, "{0}", FieldName) Out = Replace(Out, "{boundary}", Boundary) txtFields = Out End Function ''' 二进制载入文件内容 Private Function GetFile(ByVal FileName As String) Dim Stream: Set Stream = CreateObject("ADODB.Stream") Stream.Type = 1 'Binary Stream.open Stream.LoadFromFile FileName GetFile = Stream.Read Stream.Close End Function Function SaveRemoteFile2Bin(ByVal RemoteFileUrl As String, ByRef RemoteFileCon() As Byte) As Boolean ' 保存远程文件 On Error Resume Next Dim ARetrieval, GetRemoteData Set Retrieval = CreateObject("MSXML2.XMLHTTP") With Retrieval .open "Get", RemoteFileUrl, False, "", "" .send RemoteFileCon = .responseBody SaveRemoteFile2Bin = True End With If Err.Number <> 0 Then Err.Clear SaveRemoteFile2Bin = False Exit Function End If Set Retrieval = Nothing End Function