PDA

View Full Version : Not work for upload file when the Window Language format - VBA



stephentkk
04-27-2012, 01:13 AM
Dear All:
The code below can upload file when the language setting is in English,
but if the language change to chinese, the file can be uploaded but all files corrupted and can't be opened.
Anyone know how to solve, thx,



Public Sub UploadRap(URL As String, zipFile As String, strXML As String, iCount As Variant, Rng As Range, FormType As String)

Dim strPost As String
Dim replyTXT As String
Dim objHTTP As MSXML2.ServerXMLHTTP
Dim AuthenticationTicket As String
Dim DestURL As String
DestURL = LINK

Call UploadFile(DestURL, zipFile, iCount, Rng, FormType, "file")

End Sub

Sub UploadFile(ByVal DestURL As String, ByVal FileName As String, iCount As Variant, Rng As Range, FormType As String, _
Optional ByVal FieldName As String = "File")
Dim sFormData As String, D As String
'Boundary of fields.
'Be sure this string is Not In the source file
Const Boundary As String = "---------------------------0123456789012"
'Get source file As a string.
sFormData = GetFile(FileName)

'Build source form with file contents
D = "--" & Boundary & vbCrLf
D = D & "Content-Disposition: form-data; name=""" & FieldName & """;"
D = D & " filename=""" & FileName & """" & vbCrLf
D = D & "Content-Type: application/upload" & vbCrLf & vbCrLf
D = D & sFormData
D = D & vbCrLf & "--" & Boundary & "--" & vbCrLf

'Debug.Print D
'Post the data To the destination URL
Call IEPostStringRequest(DestURL, D, Boundary, iCount, Rng)
End Sub

'sends URL encoded form data To the URL using IE
Sub IEPostStringRequest(ByVal URL As String, ByVal FormData As String, ByVal Boundary As String, iCount As Variant, Rng As Range)
'Create InternetExplorer
'Create InternetExplorer
Dim WebBrowser As InternetExplorer
Dim ResultVal As String
Dim CheckVal As String
Do
On Error Resume Next
Set WebBrowser = CreateObject("InternetExplorer.Application")
Loop Until Err = 0
'You can uncoment Next line To see form results
WebBrowser.Visible = False

'Send the form data To URL As POST request
Dim bFormData() As Byte
ReDim bFormData(Len(FormData) - 1)
bFormData = StrConv(FormData, vbFromUnicode)
WebBrowser.Navigate URL, , , bFormData, "Content-Type: multipart/form-data; boundary=" & Boundary & vbCrLf
Do Until WebBrowser.ReadyState = READYSTATE_COMPLETE
DoEvents
Loop
Do Until CheckVal = "Files Upload:Success"
CheckVal = "Files Upload:" & Left(WebBrowser.Document.body.innerHTML, Len("Success"))
ResultVal = WebBrowser.Document.body.innerHTML
Debug.Print SeverAttachName
If Len(Right(ResultVal, Len(ResultVal) - Len("Success-File Upload-"))) > 0 Then
SeverAttachName = Right(ResultVal, Len(ResultVal) - Len("Success-File Upload-"))
End If
Loop
WebBrowser.Quit
'Rng.Cells(iCount + 1, Rng.Columns.Count + 2) = ResultVal

End Sub
'read binary file As a string value
Function GetFile(ByVal FileName As String) As String
Dim FileContents() As Byte, FileNumber As Integer
ReDim FileContents(FileLen(FileName) - 1)
FileNumber = FreeFile()
Open FileName For Binary As FileNumber
Get FileNumber, , FileContents
Debug.Print FileContents
Close (FileNumber)
GetFile = StrConv(FileContents, vbUnicode)
End Function