Wizzer's Blog

网页中实现自动上传本地文件，而不需要用户选择，这种应用场景很多，例如业务系统中需要使用的二代身份证扫描器、一体机（扫描仪）、摄像头拍照等。

首先介绍一个国外网站：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截图，自动把文件上传到服务器，于是联系作者。作者是个好人哈，分享了一些经验甚至代码。目前在作者的帮助下，已实现的网页控件的文件自动上传功能，可传多个文件、多表单项。

下面要解决如何在线安装的问题了……