VB 发送文件(Http Post)，带其他参数

除了发送文件主体外，还能带其他的参数。

Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
Private Const CP_UTF8 = 65001

'判断网页编码函数
Public Function IsUTF8(Bytes) As Boolean

Dim i As Long, AscN As Long, Length As Long
Length = UBound(Bytes) + 1
If Length < 3 Then
IsUTF8 = False
Exit Function
ElseIf Bytes(0) = &HEF And Bytes(1) = &HBB And Bytes(2) = &HBF Then
IsUTF8 = True
Exit Function
End If
Do While i <= Length - 1
If Bytes(i) < 128 Then
i = i + 1
AscN = AscN + 1
ElseIf (Bytes(i) And &HE0) = &HC0 And (Bytes(i + 1) And &HC0) = &H80 Then
i = i + 2
ElseIf i + 2 < Length Then
If (Bytes(i) And &HF0) = &HE0 And (Bytes(i + 1) And &HC0) = &H80 And (Bytes(i + 2) And &HC0) = &H80 Then
i = i + 3
Else
IsUTF8 = False
Exit Function
End If
Else
IsUTF8 = False
Exit Function
End If
Loop
If AscN = Length Then
IsUTF8 = False
Else
IsUTF8 = True
End If
End Function

Public Function Utf8ToUnicode(ByRef Utf() As Byte) As String
Dim lRet As Long
Dim lLength As Long
Dim lBufferSize As Long
lLength = UBound(Utf) - LBound(Utf) + 1
If lLength <= 0 Then Exit Function
lBufferSize = lLength * 2
Utf8ToUnicode = String$(lBufferSize, Chr(0))
lRet = MultiByteToWideChar(CP_UTF8, 0, VarPtr(Utf(0)), lLength, StrPtr(Utf8ToUnicode), lBufferSize)
'MsgBox Utf8ToUnicode
'MsgBox lRet
If lRet <> 0 Then
Utf8ToUnicode = Left(Utf8ToUnicode, lRet)
Else
Utf8ToUnicode = ""
End If
End Function

'Test
Public Function GB2312ToUTF8(strIn As String, Optional ByVal ReturnValueType As VbVarType = vbString) As Variant
Dim adoStream As Object

Set adoStream = CreateObject("ADODB.Stream")
adoStream.Charset = "utf-8"
adoStream.Type = 2 'adTypeText
adoStream.Open
adoStream.WriteText strIn
adoStream.Position = 0
adoStream.Type = 1 'adTypeBinary
GB2312ToUTF8 = adoStream.Read()
adoStream.Close

If ReturnValueType = vbString Then GB2312ToUTF8 = Mid(GB2312ToUTF8, 1)

End Function

Private Function pvToByteArray(sText As String) As Byte()
'pvToByteArray = StrConv(sText, vbFromUnicode)
pvToByteArray = GB2312ToUTF8(sText)

End Function

Private Sub pvPostFile(sUrl As String, sFileName As String, sPath As String, Optional ByVal bAsync As Boolean)
Const STR_BOUNDARY As String = "3fbd04f5-b1ed-4060-99b9-fca7ff59c113"
Dim nFile As Integer
Dim baBuffer() As Byte
Dim sPostData As String

'--- read file
nFile = FreeFile
Open sPath For Binary Access Read As nFile
If LOF(nFile) > 0 Then
ReDim baBuffer(0 To LOF(nFile) - 1) As Byte
Get nFile, , baBuffer
'sPostData = StrConv(baBuffer, vbUnicode)
sPostData = Utf8ToUnicode(baBuffer)

End If
Close nFile

Text1.Text = sPostData
MsgBox sPostData

'--- prepare body
sPostData = "--" & STR_BOUNDARY & vbCrLf & _
"Content-Type: application/octet-stream" & vbCrLf & _
"Content-Disposition: form-data; filename=""" & Mid$(sFileName, InStrRev(sFileName, "\") + 1) & """; name=""file""" & vbCrLf & vbCrLf & _
sPostData & _
"--" & STR_BOUNDARY & vbCrLf & _
"Content-Type: text/plain" & vbCrLf & _
"Content-Disposition: form-data; name=""dataFormat""" & vbCrLf & vbCrLf & _
"hk" & vbCrLf & _
"--" & STR_BOUNDARY & "--"

'--- post

With CreateObject("Microsoft.XMLHTTP")
.Open "POST", sUrl, bAsync
.SetRequestHeader "Content-Type", "multipart/form-data; boundary=" & STR_BOUNDARY
.Send pvToByteArray(sPostData)

End With

MsgBox "发送完毕"

End Sub

Private Sub Command1_Click()

Dim envstring As String

pvPostFile "http://localhost/fsly_service/api/hk/receiveXMLResult", "dog.xml", "C:\VB XML工程\dog.xml"
End Sub

Private Sub Command2_Click()
Text1.Text = ""
End Sub