vb6 winhttp 上传文件

winhttp 上传文件到web服务器

Public Function PostFile(ByVal strurl As String, ByVal strFile As String, ByVal ContentType As String, ByRef strret As String) As Boolean

    Dim aHttpRequest        As WinHttpRequest
    Dim i As Integer
    Dim name As String, boundary As String
    Dim filecontent
    Dim sBody

    
    On Error GoTo errH
   
    ''创建WinHttp.WinHttpRequest
    Set aHttpRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
    

    aHttpRequest.Open "POST", strurl, False
    aHttpRequest.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = &H3300

    '截取文件名称
    i = InStrRev(strFile, "\") + 1
    name = Mid(strFile, i)
    
    
    boundary = "----WebKitFormBoundaryaEHpMn3lywBtjPfE"
    
    filecontent = GetFile(strFile)
    sBody = BuildFormData(filecontent, name, boundary, ContentType)
    
    aHttpRequest.SetRequestHeader "Content-Type", "multipart/form-data; boundary=" & boundary
    aHttpRequest.SetRequestHeader "Content-Length", Len(sBody)
   
    aHttpRequest.Send sBody
    aHttpRequest.WaitForResponse
    strret = aHttpRequest.ResponseText
    Set aHttpRequest = Nothing
    PostFile = True
    Exit Function
errH:
    strret = Err.Description
    PostFile = False
End Function

'读取文件
Public 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

Public Function StringToMB(S)
    Dim i, B
    For i = 1 To Len(S)
      B = B & ChrB(Asc(Mid(S, i, 1)))
    Next
    StringToMB = B
End Function

Public Function BuildFormData(FileContents, ByVal filename As String, ByVal boundary As String, ByVal ContentType As String)
    Dim formdata As Variant
    Dim Pre As String, Po As String    ', 'ContentType
    
    
    'The two parts around file contents In the multipart-form data.
    Pre = "--" + boundary + vbCrLf + MapFields("file", filename, ContentType)
    Po = vbCrLf + "--" + boundary + "--" + vbCrLf
    
    'Build form data using recordset binary field
    Const adLongVarBinary = 205
    Dim RS: Set RS = CreateObject("ADODB.Recordset")
    RS.Fields.Append "b", adLongVarBinary, Len(Pre) + LenB(FileContents) + Len(Po)
    RS.Open
    RS.AddNew
      Dim LenData
      'Convert Pre string value To a binary data
      LenData = Len(Pre)
      RS("b").AppendChunk (StringToMB(Pre) & ChrB(0))
      Pre = RS("b").GetChunk(LenData)
      RS("b") = ""
     
      'Convert Po string value To a binary data
      LenData = Len(Po)
      RS("b").AppendChunk (StringToMB(Po) & ChrB(0))
      Po = RS("b").GetChunk(LenData)
      RS("b") = ""
     
      'Join Pre + FileContents + Po binary data
      RS("b").AppendChunk (Pre)
      RS("b").AppendChunk (FileContents)
      RS("b").AppendChunk (Po)
    RS.Update
    formdata = RS("b")
    RS.Close
    BuildFormData = formdata
End Function

Private Function MapFields(ByVal FieldName As String, ByVal filename As String, ByVal ContentType As String) As String
    Dim MPTemplate 'template For multipart header
    MPTemplate = "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)
    MapFields = Replace(Out, "{ct}", ContentType)
End Function


Private Sub Command1_Click()
    Dim strret As String  '示例
    PostFile "http://www.***.com/index.php", "d:\test.pdf", "application/pdf", strret
    MsgBox strret
End Sub

参考网址  http://www.newxing.com/Tech/Program/Script/709.html