用VB下载文件

Option Explicit

Dim sRestTime    As Long
Dim dblDownloadSpeed     As Long
Dim FileHeaderLen As Long
Dim StartPos As Long
Dim FileSizeByte As Long
Dim SaveFileName As String
Dim StartTime As Variant
Dim FileSize As Long
Dim FileSizeHaveDown As Long
Dim pst As Long
Dim blnHead As Boolean

Private Sub Command1_Click()
      On Error Resume Next
      Dim strURL As String
      Dim strCommand As String
      Dim Host As String
      Dim strPath As String
      Dim lngFirstSeparator As Long
    
      strURL = Text1.Text
    
      If InStr(1, strURL, "http://", vbTextCompare) = 0 Then
          strURL = "http://" + strURL
      End If
      lngFirstSeparator = InStr(8, strURL, "/", vbTextCompare)
      Host = Mid(strURL, 8, lngFirstSeparator - 8)
      strPath = Right(strURL, Len(strURL) - lngFirstSeparator + 1)
      'Print strPath
      'Print Host
      SaveFileName = Text3.Text
    
      StartTime = Time()
      With Winsck
          .RemoteHost = Host    '远端主机地址
          .RemotePort = 80
          .Connect
          '等待服务器连接相应
          Do While .State <> sckConnected
              DoEvents: DoEvents: DoEvents: DoEvents
              '20秒超时
              If DateDiff("s", StartTime, Time()) > 20 Then
                  Print "连接超时"
                  .Close
                  Exit Sub
              End If
          Loop
          '发送下载文件请求
          '此处使用HTTP/1.0协议
        
'GET /down/WindowHider.rar HTTP/1.1
'Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, application/x-shockwave-flash, application/vnd.ms-excel, application/vnd.ms-powerpoint, application/msword, */*
'Accept -Language: zh -cn
'Accept -Encoding: gzip , deflate
'User-Agent: Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; Maxthon)
'Host: sxbctv.onlinedown.net
'Connection: Keep -Alive
'Cookie: Flag = UUIISPoweredByUUSoft

          strCommand = "GET " + strPath + " HTTP/1.1" + vbCrLf '***
          strCommand = strCommand + "Accept: */*" + vbCrLf        '这句可以不要
          strCommand = strCommand + "Accept: text/html" + vbCrLf '这句可以不要
          'strCommand = strCommand + "Accept -Language: zh -cn" + vbCrLf
          'strCommand = strCommand + "User-Agent: Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; Maxthon)" + vbCrLf
          strCommand = strCommand + "Referer: " + strURL + ".html" + vbCrLf 'http://nj.onlinedown.net/soft/0000.htm" + vbCrLf
          'strCommand = strCommand + "" + vbCrLf
          'strCommand = strCommand + "" + vbCrLf
          'strCommand = strCommand + vbCrLf
          strCommand = strCommand & "Host: " & Host & vbCrLf
'          If Dir(SaveFileName) <> "" Then '是否已经存在下载文件
'              Dim confirm
'              confirm = MsgBox("已经存在文件，是否断点续传?", vbYesNo + vbQuestion, "提示")
'              If confirm = vbYes Then
'                  DownPosition = ""
'                  If Not oFileCtrl.ReadKeyFromIni("Update", "DownSize", App.Path + "Update.ini", DownPosition) Then
'                  '读取上次下载的字节数
'                      MsgBox "读取大小错误", vbInformation, "提示"
'                  End If
'                  '发送断点续传请求
'                  strCommand = strCommand & "Range: bytes=" & CLng(DownPosition) & "-" & vbCrLf
'              Else
'                  Kill SaveFileName '删除原文件
'              End If
'          End If
          strCommand = strCommand & "Connection: Keep-Alive" & vbCrLf
          strCommand = strCommand & vbCrLf
          .SendData strCommand
      End With
      If Err Then
          lblProcessResult.Caption = lblProcessResult.Caption & vbCrLf & vbCrLf & "下载文件出错：" & Err.Description
          lblProcessResult.Refresh
      End If

End Sub

Private Sub Text1_Change()
      Dim lenURL As Long, strURL As String
      strURL = Text1.Text

      lenURL = Len(strURL)
      Dim i As Long, lngFileNameStart As Long
      For i = lenURL To 1 Step -1
          If Mid(strURL, i, 1) = "/" Then
              lngFileNameStart = i + 1
              Exit For
          End If
      Next i
    
      If lngFileNameStart <> 0 Then Text3.Text = Mid(strURL, lngFileNameStart, lenURL - lngFileNameStart + 1)

End Sub

'--------------------------------------------------------------------------------
'     Name:Winsck_DataArrival
'     Author:Reker 2004/3/20
'     Desc:略
'     Params:略
'     Return:None
'     History:None
'--------------------------------------------------------------------------------
Private Sub Winsck_DataArrival(ByVal bytesTotal As Long)
      On Error Resume Next
      'DoEvents
      Dim ByteData() As Byte
      Dim ReceiveData As Variant
      Winsck.GetData ByteData(), vbByte
      ReceiveData = ReceiveData & StrConv(ByteData(), vbUnicode)
      If InStr(1, ReceiveData, "Content-Length:") > 0 Then    '仅第一次计算,FileSize=0
          Text2.SelStart = 65535
          Text2.SelText = ReceiveData
          blnHead = True
          Dim pos1 As Long, pos2 As Long
          pos1 = InStr(1, ReceiveData, "Content-Length:")
          pos2 = InStr(pos1 + 16, ReceiveData, vbCrLf)
          If pos2 > pos1 Then
              FileSizeByte = Mid(ReceiveData, pos1 + 16, pos2 - pos1 - 16) '计算文件的长度
              StartTime = Timer() '保存开始下载的时间
              'ProgssBar.Max = FileSizeByte '设置进度条
              FileSize = FormatNumber(FileSizeByte / 1024, 2) '以KB表示
              Print "本次下载的文件共" + CStr(FileSize) + "KB..."
          End If
      Else
          blnHead = False
      End If
      '从服务器响应返回的数据查找下载文件的起始位置
      'If FileHeaderLen = 0 Then
          Dim i As Long
          For i = 0 To UBound(ByteData()) - 3
              If ByteData(i) = 13 And ByteData(i + 1) = 10 And ByteData(i + 2) = 13 And ByteData(i + 3) = 10 Then
                  StartPos = i + 4 '将文件头的长度保存下来
                  FileHeaderLen = StartPos
                  pst = FileHeaderLen
                  Exit For
              End If
              'DoEvents
          Next i
      'End If
      FileSizeHaveDown = bytesTotal + FileSizeHaveDown - FileHeaderLen
      '已下载文件长度，需减去响应的文件头长度
      dblDownloadSpeed = FormatNumber(FormatNumber(FileSizeHaveDown / 1024, 2) / (FormatNumber((Timer() - StartTime), 4)), 2)    '计算下载速率 KB/S
      If dblDownloadSpeed <> 0 Then    '计算剩余下载的时间
          sRestTime = CLng((FileSize - (FileSizeHaveDown) / 1024) / dblDownloadSpeed) '此过程略，可以删除此段代码
          labRestTime.Caption = "剩余时间：o" + sRestTime
          labRestTime.Refresh
      End If
      labDownloadSpeed.Caption = CStr(dblDownloadSpeed) + " kb/s"
      labDownloadSpeed.Refresh
      'ProgssBar.Value = FileSizeHaveDown
      '写数据
      Dim Fnum    As Long
      Fnum = FreeFile()
      Open SaveFileName For Binary As #Fnum 'Lock Write As #Fnum
'      If LOF(Fnum) > 0 Then
'          Seek #Fnum, LOF(Fnum) + 1
'      End If
      If blnHead = True Then
          For i = pst To UBound(ByteData())
              Put #Fnum, i - pst + 1, ByteData(i)
          Next i
          pst = UBound(ByteData()) - pst + 1
      Else
          Put #Fnum, pst + 1, ByteData()
          pst = UBound(ByteData()) + pst + 1
      End If
      Close #Fnum
    
      If Err Then
          lblProcessResult.Caption = lblProcessResult.Caption & vbCrLf & vbCrLf & "下载文件出错：" & Err.Description
          lblProcessResult.Refresh
      End If
End Sub