基于HTTP协议用WinSock实现任意文件下载

HTTP协议是文本格式通讯，下载文件是二进制数据，怎样处理好两种格式，而不受VB独断专行的Unicode转换影响，本代码提供了一个示例。
Option Explicit
Private strURL As String
Private mstrFileName As String, mlngFileNum As Long
Private mlngFileLen As Long, mlngCurByte As Long
Private mblnOnlyLen As Boolean, mblnPutStart As Boolean
Private Sub Form_Load()
Text1.Text = ""
Text2.Text = ""
Label1.Caption = "文件总字节:0"
Label2.Caption = "已下载字节:0"
Command1.Caption = "开始下载"
Command2.Caption = "取得长度"
End Sub
Private Sub Command1_Click()
mblnOnlyLen = False
DownFile
End Sub
Private Sub Command2_Click()
If Command2.Caption = "取消" Then
Command2.Caption = "取得长度"
CloseAll
Else
mblnOnlyLen = True
Label1.Caption = "文件总字节:0"
DownFile
End If
End Sub
Private Sub DownFile()
Dim Server As String, Port As Long
Dim i As Long, j As Long, s As String
strURL = Text1.Text '准备下载的文件URL
If strURL = "" Then MsgBox "请输入URL！"
j = InStr(1, strURL, "http://", vbTextCompare)
If j > 0 Then
j = j + 7
Else
j = 1
End If
i = InStr(j, strURL, "/")
If i > 0 Then
Server = Mid(strURL, j, i - j)
Else
MsgBox "无效的URL！"
Exit Sub
End If
i = InStr(1, Server, ":")
If i > 0 Then
Port = Val(Mid(Server, i + 1))
Server = Left(Server, i - 1)
strURL = Replace(strURL, ":" & Port, "", , 1)
Else
Port = 80
End If
mstrFileName = Text2.Text '下载文件在本存放的位置与文件名
If mstrFileName = "" Then
mstrFileName = App.Path & "/" & Mid$(strURL, InStrRev(strURL, "/") + 1)
Else
i = InStrRev(mstrFileName, "/")
If i > 0 Then
s = Left$(mstrFileName, i - 1)
If Dir(s, vbDirectory) = "" Then
MsgBox "请输入文件存放路径！"
End If
Else
mstrFileName = App.Path & "/" & mstrFileName
End If
End If
mblnPutStart = False
Label2.Caption = "已下载字节:0"
Command1.Enabled = False
Command2.Caption = "取消"
With Winsock1
If .State <> sckClosed Then .Close
.Protocol = sckTCPProtocol
.RemoteHost = Server
.RemotePort = Port
.Connect
End With
End Sub
Private Sub Form_Unload(Cancel As Integer)
CloseAll
End Sub
Private Sub Winsock1_Connect()
Dim s As String
s = "GET " & strURL & " HTTP/1.0" + vbCrLf
s = s & "Accept: */*" & vbCrLf
s = s & "Pragma: no-cache" & vbCrLf
s = s & "Cache-Control: no-cache" & vbCrLf
s = s & "Connection: close" & vbCrLf & vbCrLf
s = s & vbCrLf
Winsock1.SendData s
End Sub
Private Sub CloseAll()
If Winsock1.State <> sckClosed Then Winsock1.Close
Close #mlngFileNum
Command1.Enabled = True
Command2.Caption = "取得长度"
End Sub
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Dim RevData() As Byte
Dim a() As Byte, b() As String, c() As String
Dim s As String, i As Long, k As Long
On Error GoTo fail
If mblnPutStart = False Then
Winsock1.PeekData RevData, vbArray Or vbByte
k = InStrB(1, RevData, ChrB(13) & ChrB(10) & ChrB(13) & ChrB(10))
If k > 0 Then
Winsock1.GetData RevData, vbArray Or vbByte
a = LeftB(RevData, k - 1)
RevData = MidB(RevData, k + 4)
s = StrConv(a, vbUnicode)
b = Split(s, vbCrLf)
If InStr(1, b(0), "200 OK", vbTextCompare) = 0 Then GoTo fail
For i = 1 To UBound(b)
c = Split(b(i), ": ")
Select Case c(0)
Case "Content-Length"
mlngFileLen = CLng(c(1))
Label1.Caption = "文件总字节:" & mlngFileLen
If mblnOnlyLen Then
CloseAll
Exit Sub
End If
End Select
Next
mblnPutStart = True
mlngCurByte = UBound(RevData) + 1
mlngFileNum = FreeFile
If Dir(mstrFileName) <> "" Then Kill mstrFileName
Open mstrFileName For Binary As #mlngFileNum
Else
Exit Sub
End If
Else
Winsock1.GetData RevData, vbArray Or vbByte
mlngCurByte = mlngCurByte + bytesTotal
End If
Put #mlngFileNum, , RevData
Label2.Caption = "已下载字节:" & mlngCurByte
If mlngCurByte = mlngFileLen Then
CloseAll
MsgBox "下载成功！"
End If
Exit Sub
fail:
CloseAll
MsgBox "网络传输错误，文件下载失败！"
End Sub