这里是使用的winsock模拟http协议实现的上传文件示例，
代码看起来是老外写的，下载自 newxing 网站。
有时间了我封装一个基于 winhttp 实现的，会比这个方便。
看代码：
'Download by http://www.NewXing.com
Option Explicit
Dim blnConnected As Boolean ' flag which indicates whether or not winsock has
' a connection
' this function builds a http request baes on the following parameters:
'
' data = the data from the file to be uploaded
' DestUrl = a URL to containing information on where to send the data
' UploadName = the field upload name usually pass by <input type="file" name="uploadname"
' Filename = the name of the file
' The MIME type of the file
Private Function BuildFileUploadRequest(ByRef strData As String, _
ByRef DestUrl As URL, _
ByVal UploadName As String, _
ByVal FileName As String, _
ByVal MimeType As String) As String
Dim strHttp As String ' holds the entire HTTP request
Dim strBoundary As String 'the boundary between each entity
Dim strBody As String ' holds the body of the HTTP request
Dim lngLength As Long ' the length of the HTTP request
' create a boundary consisting of a random string
strBoundary = RandomAlphaNumString(32)
' create the body of the http request in the form
'
' --boundary
' Content-Disposition: form-data; name="UploadName"; filename="FileName"
' Content-Type: MimeType
'
' file data here
'--boundary--
strBody = "--" & strBoundary & vbCrLf
strBody = strBody & "Content-Disposition: form-data; name=""" & UploadName & """; filename=""" & _
FileName & """" & vbCrLf
strBody = strBody & "Content-Type: " & MimeType & vbCrLf
strBody = strBody & vbCrLf & strData
strBody = strBody & vbCrLf & "--" & strBoundary & "--"
' find the length of the request body - this is required for the
' Content-Length header
lngLength = Len(strBody)
' construct the HTTP request in the form:
'
' POST /path/to/reosurce HTTP/1.0
' Host: host
' Content-Type: multipart-form-data, boundary=boundary
' Content-Length: len(strbody)
'
' HTTP request body
strHttp = "POST " & DestUrl.URI & "?" & DestUrl.Query & " HTTP/1.0" & vbCrLf
strHttp = strHttp & "Host: " & DestUrl.Host & vbCrLf
strHttp = strHttp & "Content-Type: multipart/form-data, boundary=" & strBoundary & vbCrLf
strHttp = strHttp & "Content-Length: " & lngLength & vbCrLf & vbCrLf
strHttp = strHttp & strBody
BuildFileUploadRequest = strHttp
End Function
' this routine does all the work - it gathers the info required for the HTTP request
' and sends it via the winsock control
Private Sub cmdUpload_Click()
Dim strFile As String
Dim strHttp As String
Dim DestUrl As URL
' if a request is allredy being sent
' exit
If blnConnected Then Exit Sub
' check that a file was selected
If txtUploadFile.Text = vbNullString Then
MsgBox "No File Chosen", vbCritical, "ERROR"
Exit Sub
End If
' extract the URL using a helper function
DestUrl = ExtractUrl(txtUrl.Text)
If DestUrl.Host = vbNullString Then
MsgBox "Invalid Host", vbCritical, "ERROR"
Exit Sub
End If
' clear the old response
txtResponse.Text = ""
' read the file contents as a string
' N.B: in HTTP everything is a string, even binary files
strFile = GetFileContents(txtUploadFile.Text)
' build the HTTP request
strHttp = BuildFileUploadRequest(strFile, DestUrl, txtName.Text, file.FileName, txtMIMEType.Text)
' assign the protocol host and port
Winsock1.Protocol = sckTCPProtocol
Winsock1.RemoteHost = DestUrl.Host
If DestUrl.Port <> 0 Then
Winsock1.RemotePort = DestUrl.Port
Else
Winsock1.RemotePort = 80
End If
' make the connection and send the HTTP request
Winsock1.Connect
While Not blnConnected
DoEvents
Wend
txtRequest.Text = strHttp
Winsock1.SendData strHttp
End Sub
' this is executed when winsock sneds us data
' in our case it will be the HTTP response
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Dim strData As String
Winsock1.GetData strData, vbString, bytesTotal
txtResponse.Text = txtResponse.Text & strData
End Sub
' this is executed when winsock generates an error
Private Sub Winsock1_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
MsgBox Description, vbExclamation, "ERROR"
Winsock1.Close
End Sub
' this is executed when we make a connection to winsock and it has been accepted
Private Sub Winsock1_Connect()
blnConnected = True
End Sub
' this is executed when the connection to winsock is closed
Private Sub Winsock1_Close()
Winsock1.Close
blnConnected = False
End Sub
' this function retireves the contents of a file and returns it as a string
' this is also ture for binary files
Private Function GetFileContents(ByVal strPath As String) As String
Dim StrReturn As String
Dim lngLength As Long
lngLength = FileLen(strPath)
StrReturn = String(lngLength, Chr(0))
On Error GoTo ERR_HANDLER
Open strPath For Binary As #1
Get #1, , StrReturn
GetFileContents = StrReturn
Close #1
Exit Function
ERR_HANDLER:
MsgBox Err.Description, vbCritical, "ERROR"
Err.Clear
End Function
' generates a random alphanumeirc string of a given length
Private Function RandomAlphaNumString(ByVal intLen As Integer)
Dim StrReturn As String
Dim X As Integer
Dim c As Byte
Randomize
For X = 1 To intLen
c = Int(Rnd() * 127)
If (c >= Asc("0") And c <= Asc("9")) Or _
(c >= Asc("A") And c <= Asc("Z")) Or _
(c >= Asc("a") And c <= Asc("z")) Then
StrReturn = StrReturn & Chr(c)
Else
X = X - 1
End If
Next X
RandomAlphaNumString = StrReturn
End Function
' the routines below have nothing to do with winsock
' they control the working of the GUI
Private Sub lblFile_Click()
dir.SetFocus
End Sub
Private Sub lblMIMEType_Click()
txtMIMEType.SetFocus
End Sub
Private Sub lblName_Click()
txtName.SetFocus
End Sub
Private Sub lblUrl_Click()
txtUrl.SetFocus
End Sub
Private Sub txtMIMEType_GotFocus()
txtMIMEType.SelStart = 0
txtMIMEType.SelLength = Len(txtMIMEType.Text) + 1
End Sub
Private Sub txtName_GotFocus()
txtName.SelStart = 0
txtName.SelLength = Len(txtName.Text) + 1
End Sub
Private Sub txtUrl_GotFocus()
txtUrl.SelStart = 0
txtUrl.SelLength = Len(txtUrl.Text) + 1
End Sub
Private Sub dir_Change()
file.Path = dir.Path
End Sub
Private Sub file_Click()
txtUploadFile.Text = file.Path & "\" & file.FileName
End Sub
Views: 63
