通用微博图片上传类

'***********************************************************************************
'***本程序可以自由传播,本人不对您使用本软件及代码造成的任何后果承担任何责任**
'***利用此代码挣钱了也无需告诉我******
'***作者：龙小龙 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