vb6 winhttp 上传文件

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