---

最近在一个项目中需要程序自动更新，因为是远程，所以用到了这方面的东西。
当然如果要使程序自动更新，还要做一些处理，但这应该是主体了。

源程序下载

Option Explicit

Dim mintFile As Integer '文件句柄
Dim mblnBegin As Boolean '记录是否是第一次取得数据
Dim mlngDownSize As Long '已下载的文件大小
Dim mlngTotalSize As Long '文件大小
Dim mblnTimeOut As Boolean '设置是否连接超时

Private Sub Command1_Click()
dlgMain.ShowSave

If dlgMain.FileName <> "" Then
txtSaveAs.Text = dlgMain.FileName
End If

End Sub

Private Sub Command2_Click()
If txtURL.Text = "" Then
MsgBox "请输入文件URL路径！", vbCritical
Exit Sub
ElseIf txtSaveAs.Text = "" Then
MsgBox "请指定保存位置！", vbCritical
Exit Sub
ElseIf Dir(txtSaveAs.Text) <> "" Then
If MsgBox("文件" & txtSaveAs.Text & "已经存在!" & vbCrLf & vbCrLf & "是否替换？", vbQuestion + vbYesNo) = vbNo Then
Exit Sub
End If
End If

DisEnableControl '使相关控件失效

With Winsock1
'初始相关数据
pgbMain.Value = 0
mlngDownSize = 0
mlngTotalSize = 0

If .State <> sckClosed Then .Close
.RemoteHost = URLHost(txtURL.Text) '得到下载地址的服务器地址
.RemotePort = 80 'http端口80

mblnTimeOut = False
Timer1.Interval = 5000 '设置超时为5秒
Timer1.Enabled = True
.Connect
Me.Caption = "正在连接" & .RemoteHost & "…"
Do While .State <> sckConnected And mblnTimeOut = False
DoEvents
Loop
Timer1.Enabled = False
If mblnTimeOut = True Then
MsgBox "连接到" & .RemoteHost & "超时！", vbCritical
EnableControl
Exit Sub
Else
Dim strCommand As String
Dim strWebPage As String

strWebPage = txtURL.Text

'HTTP协议请求
strCommand = "GET " + strWebPage + " HTTP/1.0" + vbCrLf
strCommand = strCommand + "Accept: */*" + vbCrLf
strCommand = strCommand + "Accept: text/html" + vbCrLf
strCommand = strCommand + vbCrLf

mblnBegin = True '设置为第一次取得文件数据状态
Winsock1.SendData strCommand '发送请求
End If
End With



End Sub
Private Function URLHost(ByVal strUrl As String) '取得URL的服务器地址
strUrl = Lcase(strUrl)
If Left(strUrl, 7) <> "http://" Then
URLHost = Left(strUrl, InStr(strUrl, "/") - 1)
Else
URLHost = Mid(strUrl, 8, InStr(8, strUrl, "/") - 8)
End If

End Function

Private Sub Command3_Click()
If MsgBox("确定取消下载？", vbQuestion + vbOKCancel) = vbOK Then
On Error Resume Next
Winsock1.Close
Kill txtSaveAs.Text '删除下载的文件
EnableControl
End If
End Sub

Private Sub Timer1_Timer()
mblnTimeOut = True
Timer1.Enabled = False
End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Dim bytData() As Byte
Dim bytDataHeader() As Byte
Dim strLine As String
Dim intCrLf As Integer
Dim nTempFile As Integer
Dim strTempFile As String

Winsock1.GetData bytData, vbArray + vbByte, bytesTotal '以二进制形式接送数据，这是关键

If mblnBegin = True Then '如果是首次接收文件
mblnBegin = False

'取得得到数据中的第一个空行,因为空行前面的是HTTP头，而非文件内容
intCrLf = InStrB(bytData, ChrB(13) & ChrB(10) & ChrB(13) & ChrB(10))

bytDataHeader = MidB(bytData, 1, intCrLf - 1)

nTempFile = FreeFile
strTempFile = "c: mp85EER69e2534Ee8545sdf8.txt"
Open strTempFile For Binary Access Write As #nTempFile '因为是二进制数据，不好处理，所以将它保存为文本文件再处理，不知道有没有更好的方法？
Put #nTempFile, , bytDataHeader
Close #nTempFile

Open strTempFile For Input As #nTempFile
Line Input #nTempFile, strLine
strLine = Mid(strLine, InStr(strLine, " ") + 1, 3) '其中的第一行前三个字符就是HTTP应答结果，如果是非200，那就是不成功了。
If strLine <> "200" Then
Close #nTempFile
Kill strTempFile '删除临时文件
MsgBox "文件不存在！下载失败！", vbCritical
Winsock1.Close
EnableControl
Exit Sub
End If

Do While Left(strLine, 15) <> "Content-Length:" '直到有一行的开头是Content-Length，因为这一行保存了文件的字节数，通过这可以知道要下载的文件的大小
Line Input #nTempFile, strLine
Loop
Close #nTempFile
Kill strTempFile

mintFile = FreeFile()
Open txtSaveAs.Text For Binary Access Write As #mintFile

mlngTotalSize = Val(Mid(strLine, InStr(strLine, ":") + 1)) + intCrLf + 3 '得到了文件的大小

bytData = MidB(bytData, intCrLf + 4) '这次得到的数据有一部分是文件内容

End If

Put #mintFile, , bytData '写入要保存的文件中

mlngDownSize = mlngDownSize + bytesTotal '改变已下载的文件大小

Me.Caption = "已下载" & Int((mlngDownSize / mlngTotalSize) * 100) & "%" '显示百分点

pgbMain.Value = (mlngDownSize / mlngTotalSize) * 100 '进度条

If mlngDownSize >= mlngTotalSize Then '判断是否已完成下载
Close #mintFile '关闭文件
Winsock1.Close
MsgBox "下载完成！", vbInformation
pgbMain.Value = 0
Me.Caption = "用Winscok下载文件"
EnableControl '生效相关控件
End If
End Sub
Private Sub EnableControl() '生效相关控件
txtURL.Enabled = True
txtSaveAs.Enabled = True
Command2.Enabled = True
Command3.Enabled = False
Command1.Enabled = True
End Sub
Private Sub DisEnableControl() '失效相关控件
txtURL.Enabled = False
txtSaveAs.Enabled = False
Command2.Enabled = False
Command3.Enabled = True
Command1.Enabled = False
End Sub

---