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