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,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

（编辑：李大同）

【声明】本站内容均来自网络，其相关言论仅代表作者个人观点，不代表本站立场。若无意侵犯到您的权利，请及时与联系站长删除相关内容!