2011九月6
VB实现自动上传文件网页ActiveX控件(模拟form提交)
网页中实现自动上传本地文件,而不需要用户选择,这种应用场景很多,例如业务系统中需要使用的二代身份证扫描器、一体机(扫描仪)、摄像头拍照等。
首先介绍一个国外网站:http://www.planet-source-code.com/ 里面有许多可用的源代码供参考,搜索 upload file 找到 vb6 file uploader (类似的代码比较多,这个是比较好的一个)。
VB通过模拟HTTP POST过程把文件提交至服务器。
Dim WinHttpReq As WinHttp.WinHttpRequest Const HTTPREQUEST_SETCREDENTIALS_FOR_SERVER = 0 Const HTTPREQUEST_SETCREDENTIALS_FOR_PROXY = 1 Const BOUNDARY = "Xu02=$" Const HEADER = "--Xu02=$" Const FOOTER = "--Xu02=$--" Function UploadFiles(DirPath As String, strFileName As Variant, strFileForm As Variant, strURL As String, _ Optional postName As Variant, Optional postVar As Variant, Optional strUserName As String, _ Optional strPassword As String) As String Dim fName As String Dim strFile As String Dim strBody As String Dim aPostBody() As Byte Dim nFile As Integer Dim p As Integer Set WinHttpReq = New WinHttpRequest ' Turn error trapping on On Error GoTo SaveErrHandler ' Assemble an HTTP request. WinHttpReq.Open "POST", strURL, False If strUserName <> "" And strPassword <> "" Then ' Set the user name and password, for server request authentication WinHttpReq.SetCredentials strUserName, strPassword, _ HTTPREQUEST_SETCREDENTIALS_FOR_SERVER End If '-------------------------- Becareful not to mingle too much here ----------------------------------- ' Set the header WinHttpReq.SetRequestHeader "Content-Type", "multipart/form-data; boundary=" & BOUNDARY ' Assemble the body ' Starting tag strBody = HEADER For i = 0 To UBound(strFileName) ' Grap the name fName = strFileName(i) ' Grap the file strFile = GetFile(DirPath & "\" & fName) strBody = strBody & vbCrLf & "Content-Disposition: form-data; name=""" & strFileForm(i) & _ """; filename=""" & fName & """ " & vbCrLf & "Content-type: file" & _ vbCrLf & vbCrLf & strFile & vbCrLf If i < UBound(strFileName) Then ' This is boundary tag between two files strBody = strBody & "--Xu02=$" End If strFile = "" Next i 'Posted Variable For p = 0 To UBound(postName) strBody = strBody & HEADER & vbCrLf strBody = strBody & "Content-Disposition: form-data; name=""" & postName(p) & """" & vbCrLf & vbCrLf strBody = strBody & postVar(p) & vbCrLf 'Debug.Print "-----------------------------------------------------------------------------------------------------" 'Debug.Print "Content-Disposition: form-data; name=""" & postName(p) & """" & vbCrLf & vbCrLf & postVar(p) & vbCrLf 'Debug.Print "-----------------------------------------------------------------------------------------------------" Next p ' Ending tag strBody = strBody & FOOTER ' Because of binary zeros, post body has to convert to byte array aPostBody = StrConv(strBody, vbFromUnicode) ' Send the HTTP Request. WinHttpReq.Send aPostBody ' Display the status code and response headers. 'debug.print WinHttpReq.GetAllResponseHeaders & " " & WinHttpReq.ResponseText UploadFiles = WinHttpReq.ResponseText Debug.Print "[UploadScript::UploadFiles]" & vbCrLf & WinHttpReq.ResponseText Set WinHttpReq = Nothing Exit Function SaveErrHandler: Debug.Print "[UploadScript::UploadFiles]" & vbCrLf & Err.Description UploadFiles = WinHttpReq.ResponseText Set WinHttpReq = Nothing End Function Function GetFile(strFileName As String) As String Dim strFile As String ' Grap the file nFile = FreeFile Open strFileName For Binary As #nFile strFile = String(LOF(nFile), " ") Get #nFile, , strFile Close #nFile GetFile = strFile End Function '----------------------------------------------------------- Private Sub Command1_Click() Dim pst As New clsUploadEngine 'file path (make sure put "\" after folder name) filepath = App.Path & "\sample\" 'filename array filearr = Array("scenery1.jpg", "scenery2.jpg", "scenery3.jpg") 'form file post name (equivalent to <input type="file" name="filename"> fileform = Array("fileA", "fileB", "fileC") 'url to post file/information uploadurl = "http://127.0.0.1:8080/savefile.jsp" 'post parameter & posted variable (optional) 'if no post parameter, just put dummy post, if not error will occur postparam = Array("id", "uname", "passwd", "op") postVar = Array("1", "root", "", "tdrupload") pst.UploadFiles CStr(filepath), filearr, fileform, CStr(uploadurl), postparam, postVar End Sub
在此基础上,做成ActiveX控件即可。但问题是这个源码上传到服务器的文本文件虽然看起来正常但文件结尾会有空编码、图片损坏。囧。
后来发现 WebNoteEditor 可以实现粘贴QQ截图,自动把文件上传到服务器,于是联系作者。作者是个好人哈,分享了一些经验甚至代码。目前在作者的帮助下,已实现的网页控件的文件自动上传功能,可传多个文件、多表单项。
下面要解决如何在线安装的问题了……