download.ctl

guan yu pai ke xi tong de ruan jian

VERSION 5.00
Object = "{48E59290-9880-11CF-9754-00AA00C00908}#1.0#0"; "MSINET.OCX"
Begin VB.UserControl DownLoad 
   Alignable       =   -1  'True
   AutoRedraw      =   -1  'True
   CanGetFocus     =   0   'False
   ClientHeight    =   3735
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4095
   InvisibleAtRuntime=   -1  'True
   MaskColor       =   &H000000FF&
   Picture         =   "DownLoad.ctx":0000
   ScaleHeight     =   3890.625
   ScaleMode       =   0  'User
   ScaleWidth      =   4136.359
   Begin InetCtlsObjects.Inet I1 
      Left            =   1200
      Top             =   360
      _ExtentX        =   1005
      _ExtentY        =   1005
      _Version        =   393216
   End
End
Attribute VB_Name = "DownLoad"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "PropPageWizardRun" ,"Yes"
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hkey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hkey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hkey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Private Const LOGON_REG_VER = "Software\Helper\Apply"
Private Const REG_SZ = 1
Private Const REG_BINARY = 3


Private Declare Function InternetGetConnectedState Lib "wininet" (lpdwFlags As Long, ByVal dwReserved As Long) As Boolean

Dim a_Resume As Boolean
Dim c_Cancel As Boolean '取消状态。
Dim c_Pause As Boolean '暂停状态。
Dim m_URL As String
Dim m_FileSize As Long
Dim m_CHUNK As Long
Dim m_FileExists As Boolean
Dim m_Percent As Long
Dim m_Status As String
Dim m_BYTES As Long
Dim m_SaveLocation As String
Dim m_KeepType As Boolean
Dim m_OnlineCheck As Boolean
Dim m_PromptOverwrite As Boolean
Dim m_Connected As Boolean
Dim m_Resume As Boolean
Dim m_ROLLBACK As Long
Dim m_InDL As Boolean
Dim m_UserName As String
Dim m_Password As String
Dim t_OldTime As Single
Dim t_Time As Single
Dim r_RateTransfer As Single
Dim m_LastModified '文件最后修改时间。
Const INTERNET_CONNECTION_MODEM = 1 '表示调制解调器连接。
Const INTERNET_CONNECTION_LAN = 2 '表示局域网连接。
Const INTERNET_CONNECTION_PROXY = 4 '表示代理服务器连接。

Const d_URL = "http://www.growchina.cn" '默认文件路径。
Const d_CHUNK = 1024 '默认块大小。
Const d_SaveLocation = "C:\File1.tmp" '默认文件保存路径。
Const d_KeepType = False '是否要求扩展名相同。
Const d_OnlineCheck = False '是否要求连上网络。
Const d_PromptOverwrite = False '覆盖现有文件时是否提示。

'error codes
'1 Unknown error
'2 File doesn't exist
'3 Server timed out
'4 canceled
'5 No Connection To Internet
'401 Unauthorized Access
'403 Access Denied
'以下定义事件。
Event DLComplete() '下载结束时产生。
Event DLError(Number As Long, Description As String) '发生错误时产生。
Event RecievedBytes(lnumBYTES As Long) '定时发生以获取已下载字节数。
Event Percent(lPercent As Long) '定时发生以获取下载进度百分比。
Event StatusChange(lpStatus As String) '有消息输出时发生。
Event Rate(lpRate As String) '定时发生以获取连接速度。
Event TimeLeft(lpTime As String) '定时发生以获取剩余时间。
Event ConnectionState(strState As String) '网络连接时产生。
Public Property Get GetFile_LastModified() As String
    GetFile_LastModified = m_LastModified
End Property

Public Property Get InDL() As Boolean
    '获取接收状态。
    InDL = m_InDL
End Property

Public Property Get AResume() As Boolean
    '获取重新开始状态。
    AResume = a_Resume
End Property

Public Property Get CPause() As Boolean
    '获取暂停状态。
    CPause = c_Pause
End Property

Public Property Get CCancel() As Boolean
    '获取取消状态。
    CCancel = c_Cancel
End Property

Public Property Get ROLLBACK() As Long
    ROLLBACK = m_ROLLBACK
End Property

Public Property Let ROLLBACK(ByVal lnumBYTES As Long)
    m_ROLLBACK = ROLLBACK
    PropertyChanged "ROLLBACK"
End Property

Public Property Get ResumeSupported() As Boolean
    ResumeSupported = a_Resume
End Property

Public Property Get Connected() As Boolean
    Connected = m_Connected
End Property

Public Property Get PromptOverwrite() As Boolean
Attribute PromptOverwrite.VB_ProcData.VB_Invoke_Property = "DownLoad_Properties"
    PromptOverwrite = m_PromptOverwrite
End Property

Public Property Let PromptOverwrite(ByVal DoPrompt As Boolean)
    m_PromptOverwrite = DoPrompt
    PropertyChanged "PromptOverwrite"
End Property

Public Property Get OnlineCheck() As Boolean
    OnlineCheck = m_OnlineCheck
End Property

Public Property Let OnlineCheck(ByVal DoCheck As Boolean)
    m_OnlineCheck = DoCheck
    PropertyChanged "OnlineCheck"
End Property

Public Property Get KeepType() As Boolean
    KeepType = m_KeepType
End Property

Public Property Let KeepType(ByVal IsKeep As Boolean)
    m_KeepType = IsKeep
    PropertyChanged "KeepType"
End Property

Public Property Get FileExists() As Boolean
    FileExists = m_FileExists
End Property

Public Property Get FileSize() As Long
    FileSize = m_FileSize
End Property

Public Property Get Url() As String
Attribute Url.VB_ProcData.VB_Invoke_Property = "DownLoad_Properties"
    '获取文件URL。
    Url = m_URL
End Property

Public Property Get CHUNK() As Long
Attribute CHUNK.VB_ProcData.VB_Invoke_Property = "DownLoad_Properties"
    '获取块大小。
    CHUNK = m_CHUNK
End Property

Public Property Get SaveLocation() As String
Attribute SaveLocation.VB_ProcData.VB_Invoke_Property = "DownLoad_Properties"
    '获取文件路径。
    SaveLocation = m_SaveLocation
End Property

Public Property Let SaveLocation(ByVal New_Location As String)
    m_SaveLocation = New_Location
    PropertyChanged "SaveLocation"
End Property

Public Property Let CHUNK(ByVal New_CHUNK As Long)
    m_CHUNK = New_CHUNK
    PropertyChanged "CHUNK"
End Property

Public Property Let Url(ByVal New_Url As String)
    m_URL = New_Url
    PropertyChanged "Url"
End Property

Private Sub UserControl_InitProperties()
    m_URL = d_URL '默认文件URL地址。
    m_CHUNK = d_CHUNK '默认块大小。
    m_SaveLocation = d_SaveLocation '默认保存文件路径。
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    m_URL = PropBag.ReadProperty("URL", d_URL)
    m_CHUNK = PropBag.ReadProperty("CHUNK", d_CHUNK)
    m_SaveLocation = PropBag.ReadProperty("SaveLocation", d_SaveLocation)
    m_KeepType = PropBag.ReadProperty("KeepType", d_KeepType)
    m_OnlineCheck = PropBag.ReadProperty("OnlineCheck", d_OnlineCheck)
    m_PromptOverwrite = PropBag.ReadProperty("PromptOverwrite", d_PromptOverwrite)
End Sub

Private Sub UserControl_Resize()
    UserControl.Height = 480
    UserControl.Width = 480
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    Call PropBag.WriteProperty("URL", m_URL, d_URL)
    Call PropBag.WriteProperty("CHUNK", m_CHUNK, d_CHUNK)
    Call PropBag.WriteProperty("SaveLocation", m_SaveLocation, d_SaveLocation)
    Call PropBag.WriteProperty("KeepType", m_KeepType, d_KeepType)
    Call PropBag.WriteProperty("OnlineCheck", m_OnlineCheck, d_OnlineCheck)
    Call PropBag.WriteProperty("PromptOverwrite", m_PromptOverwrite, d_PromptOverwrite)
End Sub

Sub DownLoad()
'On Error GoTo DLE
    Dim lpHeader As String
    Dim lpdestination As String
    Dim lpdestination2 As String
    Dim strreturn As String
    Dim CHUNK As Long
    Dim bData() As Byte
    Dim intfile As Integer
    Dim lBR As Long
    If c_Cancel = True Then Exit Sub '如果下载被取消。
    If m_OnlineCheck = True Then '如果要求连网。
        If m_Connected = False Then '连接状态是断开的。
            RaiseEvent DLError(5, "Not Find LAN!")
            I1.Cancel
            Exit Sub
        End If
    End If

    I1.Url = m_URL
    CHUNK = m_CHUNK
    lpdestination = m_SaveLocation
    intfile = FreeFile() '获取可用的文件编号。

    If m_KeepType = True Then '是否要求扩展名相同。
        lpdestination = KeepSave(m_URL, m_SaveLocation)
    End If

    If m_PromptOverwrite = True Then '是否覆盖现有文件。
        If Len(Dir(lpdestination)) > 0 Then
            strreturn = MsgBox("要覆盖现有文件: " & lpdestination & " ?", vbInformation + vbYesNo, "文件已经存在...")
            If strreturn = vbYes Then
                    Kill lpdestination
            Else
404:            lpdestination2 = InputBox("请输入一个新的文件名。" & vbCrLf & "如: C:\File2.txt", "文件更名...", lpdestination)