200512258782

'##############################################################################'**'**   文件 frmDownLoad.frm 的内容'**'##############################################################################VERSION 5.00Begin VB.Form frmDownLoad    BorderStyle     =   1  'Fixed Single   Caption         =   "Form1"   ClientHeight    =   2880   ClientLeft      =   45   ClientTop       =   330   ClientWidth     =   6375   BeginProperty Font       Name            =   "宋体"      Size            =   9      Charset         =   0      Weight          =   400      Underline       =   0   'False      Italic          =   0   'False      Strikethrough   =   0   'False   EndProperty   LinkTopic       =   "文件下载"   MaxButton       =   0   'False   ScaleHeight     =   2880   ScaleWidth      =   6375   StartUpPosition =   2  'CenterScreen   Begin VB.CommandButton cmdStop       Caption         =   "停止"      Enabled         =   0   'False      Height          =   480      Left            =   1860      TabIndex        =   6      Top             =   2160      Width           =   1365   End   Begin VB.CommandButton cmdStart       Caption         =   "开始"      Height          =   480      Left            =   165      TabIndex        =   5      Top             =   2160      Width           =   1365   End   Begin VB.TextBox txtFile       Height          =   330      Left            =   750      TabIndex        =   3      Top             =   705      Width           =   5445   End   Begin VB.TextBox txtURL       Height          =   330      Left            =   750      TabIndex        =   1      Top             =   285      Width           =   5445   End   Begin VB.Label lblCount       BackStyle       =   0  'Transparent      Caption         =   "下载"      Height          =   180      Left            =   180      TabIndex        =   4      Top             =   1245      Width           =   5130   End   Begin VB.Label Label1       AutoSize        =   -1  'True      Caption         =   "文件:"      Height          =   180      Left            =   195      TabIndex        =   2      Top             =   780      Width           =   450   End   Begin VB.Label lblURL       AutoSize        =   -1  'True      Caption         =   "URL:"      Height          =   180      Left            =   195      TabIndex        =   0      Top             =   360      Width           =   360   EndEndAttribute VB_Name = "frmDownLoad"Attribute VB_GlobalNameSpace = FalseAttribute VB_Creatable = FalseAttribute VB_PredeclaredId = TrueAttribute VB_Exposed = FalseOption ExplicitPrivate Declare Function StrFormatByteSize Lib "shlwapi" Alias _"StrFormatByteSizeA" (ByVal dw As Long, ByVal pszBuf As String, ByRef _cchBuf As Long) As StringPrivate Declare Function InternetOpen Lib "wininet.dll" _  Alias "InternetOpenA" (ByVal sAgent As String, _  ByVal lAccessType As Long, ByVal sProxyName As String, _  ByVal sProxyBypass As String, ByVal lFlags As Long) As LongPrivate Declare Function InternetOpenUrl Lib "wininet.dll" _   Alias "InternetOpenUrlA" (ByVal hOpen As Long, _   ByVal surl As String, ByVal sHeaders As String, _   ByVal lLength As Long, ByVal lFlags As Long, _   ByVal lContext As Long) As LongPrivate Declare Function HttpOpenRequest Lib "wininet.dll" _   Alias "HttpOpenRequestA" _   (ByVal hInternetSession As Long, _    ByVal lpszVerb As String, _    ByVal lpszObjectName As String, _    ByVal lpszVersion As String, _    ByVal lpszReferer As String, _    ByVal lpszAcceptTypes As Long, _    ByVal dwFlags As Long, _    ByVal dwContext As Long) As Long      Private Declare Function InternetConnect Lib "wininet.dll" _         Alias "InternetConnectA" _         (ByVal hInternetSession As Long, _          ByVal lpszServerName As String, _          ByVal nProxyPort As Integer, _          ByVal lpszUsername As String, _          ByVal lpszPassword As String, _          ByVal dwService As Long, _          ByVal dwFlags As Long, _          ByVal dwContext As Long) As LongPrivate Declare Function HttpSendRequest Lib "wininet.dll" _   Alias "HttpSendRequestA" _   (ByVal hHttpRequest As Long, _    ByVal sHeaders As String, _    ByVal lHeadersLength As Long, _    ByVal sOptional As String, _    ByVal lOptionalLength As Long) As BooleanPrivate Declare Function InternetReadFile Lib "wininet.dll" _   (ByVal hFile As Long, ByRef sBuffer As Byte, _   ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) _   As IntegerPrivate Declare Function InternetCloseHandle Lib "wininet.dll" _        (ByVal hInet As Long) As Integer        Private Declare Function GetLastError Lib "kernel32" () As Long        ' Adds one or more HTTP request headers to the HTTP request handle.'Public Declare Function HttpAddRequestHeaders Lib "wininet.dll" Alias "HttpAddRequestHeadersA" _'(ByVal hHttpRequest As Long, ByVal sHeaders As String, ByVal lHeadersLength As Long, _'ByVal lModifiers As Long) As IntegerPrivate bolStop As Boolean   ' 然后，我们可以得到包含了一份详细说明的URL文本文件，它显示在下面的函数中：Public Function DownloadFile(ByVal surl As String, ByVal strFile As String) As Long    Dim s As String    Dim hOpen As Long    Dim hOpenUrl As Long    Dim bDoLoop As Boolean    Dim bRet As Boolean    Dim intFH As Integer        Dim sReadBuffer() As Byte    Dim lNumberOfBytesRead As Long    Dim lCount As Long    Dim myCount As New clsCount    Const INTERNET_OPEN_TYPE_PRECONFIG = 0    Const INTERNET_OPEN_TYPE_DIRECT = 1    Const INTERNET_OPEN_TYPE_PROXY = 3    Const scUserAgent = "VB OpenUrl"    Const INTERNET_FLAG_RELOAD = &H80000000        lblCount.Caption = "正在连接服务器..."    lblCount.Refresh    hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)    hOpenUrl = InternetOpenUrl(hOpen, surl, vbNullString, 0, INTERNET_FLAG_RELOAD, 0)    lCount = 0        If hOpen <> 0 And hOpenUrl <> 0 Then        intFH = FreeFile        If Dir(strFile) <> "" Then            VBA.FileSystem.Kill strFile        End If        Open strFile For Binary As #intFH        myCount.Clear        Do While True            ReDim sReadBuffer(2048)            bRet = InternetReadFile(hOpenUrl, sReadBuffer(0), 2048, lNumberOfBytesRead)            If lNumberOfBytesRead > 0 And bRet = True Then                'if lnumberofbytesread<>2048 then                ReDim Preserve sReadBuffer(0 To lNumberOfBytesRead - 1)                Put #intFH, , sReadBuffer''                buf.AddRange sReadBuffer, 0, lNumberOfBytesRead - 1                lCount = lCount + lNumberOfBytesRead                myCount.Count lNumberOfBytesRead                lblCount.Caption = "已下载 " & VBStrFormatByteSize(lCount) & "  [ " & VBStrFormatByteSize(myCount.Speed) & " /秒 ]"                lblCount.Refresh            Else                Exit Do            End If            bolStop = False            DoEvents            If bolStop = True Then                Exit Do            End If        Loop        Close #intFH        lblCount.Caption = "共下载 " & lCount & " 字节"    Else        lblCount.Caption = "打开URL错误"    End If         If hOpenUrl <> 0 Then InternetCloseHandle (hOpenUrl)    If hOpen <> 0 Then InternetCloseHandle (hOpen)    Set myCount = Nothing    DownloadFile = lCount End FunctionPrivate Sub cmdStart_Click()    txtURL.Enabled = False    txtFile.Enabled = False    cmdStart.Enabled = False    cmdStop.Enabled = True    DownloadFile txtURL.Text, txtFile.Text    cmdStop.Enabled = False    cmdStart.Enabled = True    txtFile.Enabled = True    txtURL.Enabled = True    End SubPrivate Sub cmdStop_Click()    bolStop = TrueEnd SubPrivate Sub SetText(ByVal txt As TextBox)    txt.Text = GetSetting(App.Title, Me.Name, txt.Name)End SubPrivate Sub SaveText(ByVal txt As TextBox)    SaveSetting App.Title, Me.Name, txt.Name, txt.TextEnd SubPrivate Sub Form_Load()    SetText Me.txtFile    SetText Me.txtURLEnd SubPrivate Sub Form_Unload(Cancel As Integer)    SaveText Me.txtFile    SaveText Me.txtURLEnd SubPrivate Function VBStrFormatByteSize(ByVal lngSize As Long) As String    Dim strSize As String * 128    Dim strData As String    Dim lPos        As Long    StrFormatByteSize lngSize, strSize, 128    lPos = InStr(1, strSize, Chr$(0))    strData = Left$(strSize, lPos - 1)    If lngSize > 1024 Then        strData = lngSize & "字节(" & strData & ")"    End If    VBStrFormatByteSize = strDataEnd Function'##############################################################################'**'**   文件 clsCount.cls 的内容'**'##############################################################################VERSION 1.0 CLASSBEGIN  MultiUse = -1  'True  Persistable = 0  'NotPersistable  DataBindingBehavior = 0  'vbNone  DataSourceBehavior  = 0  'vbNone  MTSTransactionMode  = 0  'NotAnMTSObjectENDAttribute VB_Name = "clsCount"Attribute VB_GlobalNameSpace = FalseAttribute VB_Creatable = TrueAttribute VB_PredeclaredId = FalseAttribute VB_Exposed = FalseOption Explicit'******************************************************************************'**'**     用于计算速度的类模块'**'** 该类模块设定一个计数器,由程序不断的累计数据,并根据所花时间计算数据'**'** 编制: 袁永福'** 时间: 2002-4-2'**'******************************************************************************Private Declare Function GetTickCount Lib "kernel32" () As LongPrivate lngCountStart   As LongPrivate lngCountCurrent As LongPrivate lngCountLast    As LongPrivate lngSpeed        As LongPrivate lngTickStart    As LongPrivate lngTickCurrent  As LongPrivate lngTickLast     As Long'Public StopCount        As Boolean'** 获得计数数据 **************************************************************    '** 累计初始值    Public Property Get CountStart() As Long        CountStart = lngCountStart    End Property    '** 累计终止值    Public Property Get CountEnd() As Long        CountEnd = lngCountCurrent    End Property    '** 累计总的速度    Public Property Get TotalSpeed() As Long        If lngTickCurrent = lngTickStart Then            TotalSpeed = 0        Else            TotalSpeed = (lngCountCurrent - lngCountStart) / ((lngTickCurrent - lngTickStart) / 1000)        End If    End Property    '** 累计所花毫秒数    Public Property Get TotalTickCount() As Long        TotalTickCount = lngTickCurrent - lngTickStart    End Property'** 清除所有数据 **************************************************************    Public Sub Clear()        lngCountStart = 0        lngCountCurrent = 0        lngCountLast = 0                lngSpeed = 0                lngTickStart = GetTickCount()        lngTickCurrent = lngTickStart        lngTickLast = lngTickStart                'StopCount = False    End Sub'** 设置累计基数    Public Property Let CountStart(ByVal lStart As Long)        lngCountStart = lStart        lngCountCurrent = lStart    End Property'** 累加数据 **    Public Sub Count(Optional ByVal lCount As Long = 1)        lngCountCurrent = lngCountCurrent + lCount        lngTickCurrent = GetTickCount()    End Sub    '** 获得速度 **    Public Property Get Speed() As Long        'lngTickCurrent = GetTickCount()        If lngTickLast = lngTickCurrent Then            Speed = lngSpeed        Else            Speed = (lngCountCurrent - lngCountLast) / ((lngTickCurrent - lngTickLast) / 1000)            lngSpeed = Speed            lngTickLast = lngTickCurrent            lngCountLast = lngCountCurrent        End If    End Property    '** 数据是否是最新更新的 **    Public Property Get NewSpeed() As Boolean        Dim bolNew As Boolean        If lngTickCurrent > lngTickLast + 1000 Then            bolNew = True        Else            bolNew = False        End If        NewSpeed = bolNew    End Property    '** 本模块