VB 傳送檔案(Http Post),帶其他引數
阿新 • • 發佈:2019-01-08
除了傳送檔案主體外,還能帶其他的引數。
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