bkdlcontrol.ctl

一个比较简单美观的魔域登陆器源码

VERSION 5.00
Begin VB.UserControl bkDLControl 
   BorderStyle     =   1  'Fixed Single
   CanGetFocus     =   0   'False
   ClientHeight    =   450
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4650
   ScaleHeight     =   450
   ScaleWidth      =   4650
   ToolboxBitmap   =   "bkDLControl.ctx":0000
End
Attribute VB_Name = "bkDLControl"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'Property Variables:
Private m_sFileURL As String, m_sSaveFilePath As String, blnDownloading As Boolean, sngPct As Single, _
    m_blnFailRedirect As Boolean, m_sSaveFileName As String, m_blnShowProgress As Boolean, _
    blnSuccess As Boolean, m_lFileSize As Long, m_sConn As String, m_lBytesRead As Long, _
    m_sCache As String, m_sRedirect As String, m_sMIMEType As String, m_blnRenameRedirect As Boolean
    
'Event Declarations:
Event Click() 'MappingInfo=UserControl,UserControl,-1,Click
Attribute Click.VB_Description = "Occurs when the user presses and then releases a mouse button over an object."
Attribute Click.VB_UserMemId = -600
Event DblClick() 'MappingInfo=UserControl,UserControl,-1,DblClick
Attribute DblClick.VB_Description = "Occurs when the user presses and releases a mouse button and then presses and releases it again over an object."
Attribute DblClick.VB_UserMemId = -601
Event MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseDown
Attribute MouseDown.VB_Description = "Occurs when the user presses the mouse button while an object has the focus."
Attribute MouseDown.VB_UserMemId = -605
Event MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseMove
Attribute MouseMove.VB_Description = "Occurs when the user moves the mouse."
Attribute MouseMove.VB_UserMemId = -606
Event MouseUp(Button As Integer, Shift As Integer, x As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseUp
Attribute MouseUp.VB_Description = "Occurs when the user releases the mouse button while an object has the focus."
Attribute MouseUp.VB_UserMemId = -607
'Custom event declarations
Event DLProgress(Percent As Single, BytesRead As Long, TotalBytes As Long)
Event DLCanceled()
Event DLError(E As bkDLError, Error As String)
Event DLComplete(Bytes As Long)
Event DLConnected(ConnAddr As String)
Event DLRedirect(ConnAddr As String)
Event DLCacheFile(FileName As String)
Event DLMIMEType(MIMEType As String)
Event DLFileSize(Bytes As Long)
Event DLBeginDownload()

Public Enum bkDLError
    bkDLEUnavailable = 1
    bkDLERedirect = 2
    bkDLEZeroLength = 3
    bkDLESaveError = 4
    bkDLEUnknown = 99
End Enum
'Private bkDLEUnavailable, bkDLERedirect, bkDLEZeroLength, bkDLESaveError, bkDLEUnknown

'Typical stuff
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,BackColor
Public Property Get BackColor() As OLE_COLOR
Attribute BackColor.VB_Description = "Returns/sets the background color used to display text and graphics in an object."
Attribute BackColor.VB_ProcData.VB_Invoke_Property = ";Appearance"
Attribute BackColor.VB_UserMemId = -501
    BackColor = UserControl.BackColor
End Property

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
    UserControl.BackColor() = New_BackColor
    PropertyChanged "BackColor"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,ForeColor
Public Property Get ForeColor() As OLE_COLOR
Attribute ForeColor.VB_Description = "Returns/sets the foreground color used to display text and graphics in an object."
Attribute ForeColor.VB_ProcData.VB_Invoke_Property = ";Appearance"
    ForeColor = UserControl.ForeColor
End Property

Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
    UserControl.ForeColor() = New_ForeColor
    PropertyChanged "ForeColor"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,Enabled
Public Property Get Enabled() As Boolean
Attribute Enabled.VB_Description = "Returns/sets a value that determines whether an object can respond to user-generated events."
Attribute Enabled.VB_UserMemId = -514
    Enabled = UserControl.Enabled
End Property

Public Property Let Enabled(ByVal New_Enabled As Boolean)
    UserControl.Enabled() = New_Enabled
    PropertyChanged "Enabled"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,Font
Public Property Get Font() As Font
Attribute Font.VB_Description = "Returns a Font object."
Attribute Font.VB_ProcData.VB_Invoke_Property = ";Font"
Attribute Font.VB_UserMemId = -512
    Set Font = UserControl.Font
End Property

Public Property Set Font(ByVal New_Font As Font)
    Set UserControl.Font = New_Font
    PropertyChanged "Font"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,BorderStyle
Public Property Get BorderStyle() As Integer
Attribute BorderStyle.VB_Description = "Returns/sets the border style for an object."
Attribute BorderStyle.VB_ProcData.VB_Invoke_Property = ";Appearance"
Attribute BorderStyle.VB_UserMemId = -504
    BorderStyle = UserControl.BorderStyle
End Property

Public Property Let BorderStyle(ByVal New_BorderStyle As Integer)
    UserControl.BorderStyle() = New_BorderStyle
    PropertyChanged "BorderStyle"
End Property

'A lot of these properties are runtime-only/read-only - they only have value when
'a DL is happening (or just after)
'Bytes read in so far
Public Property Get BytesRead() As Long
Attribute BytesRead.VB_MemberFlags = "400"
    BytesRead = m_lBytesRead
End Property

'Location of Cache file
Public Property Get CacheFile() As String
Attribute CacheFile.VB_MemberFlags = "400"
    CacheFile = m_sCache
End Property
    
'Address of connection (IP String)
Public Property Get ConnectionAddress() As String
Attribute ConnectionAddress.VB_MemberFlags = "400"
    ConnectionAddress = m_sConn
End Property

'MIME type of download
Public Property Get MIMEType() As String
Attribute MIMEType.VB_MemberFlags = "400"
    MIMEType = m_sMIMEType
End Property

'If redirected, this in the address of the new target
Public Property Get RedirectFile() As String
Attribute RedirectFile.VB_MemberFlags = "400"
    RedirectFile = m_sRedirect
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,Refresh
Public Sub Refresh()
Attribute Refresh.VB_Description = "Forces a complete repaint of a object."
Attribute Refresh.VB_UserMemId = -550
    UserControl.Refresh
End Sub

'Download complete, attempt to save the file to disk
Private Sub UserControl_AsyncReadComplete(AsyncProp As AsyncProperty)
    On Error GoTo CompleteError
    Dim bFile() As Byte, FN As Long
    'Internal DL flag
    'Check see if file actuall recieved
    With AsyncProp
        If .BytesRead <> 0 Then
            'write file (in byte array .Value) to disk
            FN = FreeFile
            bFile = .Value
            If m_blnRenameRedirect And m_sRedirect <> vbNullString Then
                SetRedirectName
            End If
            Open m_sSaveFileName For Binary Access Write As #FN
            Put #FN, , bFile
            Close #FN
            blnSuccess = True
            RaiseEvent DLComplete(.BytesRead)
            Kill m_sCache
            blnDownloading = False
        Else
            'Occurs with bad URLs, No internet connection, etc.
            SendError bkDLEZeroLength, "Zero bytes retrieved"
        End If
    End With
    Exit Sub
CompleteError:
    'Typically permissions problem or invalid path
    Debug.Print Err.Number
    SendError bkDLESaveError, Err.Description & " [" & m_sSaveFileName & "]"
End Sub

Private Sub UserControl_AsyncReadProgress(AsyncProp As AsyncProperty)
    'Here's the guts of the whole thing!
    'All the interesting message come through this event
    With AsyncProp
        Select Case .StatusCode 'Determines message being recieved
            Case vbAsyncStatusCodeConnecting
                m_sConn = .Status 'Save for Get Property
                RaiseEvent DLConnected(.Status) 'Send back IP address of connection
            Case vbAsyncStatusCodeRedirecting
                m_sRedirect = .Status 'Save for Get Property
                If m_blnFailRedirect Then
                    UserControl.CancelAsyncRead m_sSaveFileName
                    SendError bkDLERedirect, "Redirected to " & .Status  'sends back a path
                    'thought about changing the save file name after Redirect,
                    'but then it's usually a 404error.html file, and who really wants
                    'that saved anyway?
                Else
                    'Keep going, but send message to program than
                    'DL has been redirected
                    RaiseEvent DLRedirect(.Status)
                End If
            Case vbAsyncStatusCodeDownloadingData, vbAsyncStatusCodeEndDownloadData
                'update progress (actual drawing is done in Paint(),
                'so save time if not visible
                If .BytesMax > 0 Then
                    sngPct = CSng(.BytesRead / .BytesMax)
                Else
                    sngPct = 0!
                End If
                m_lBytesRead = .BytesRead 'Save for Get Property
                'ChangeToolTip 'discarded
                RaiseEvent DLProgress(sngPct, .BytesRead, .BytesMax)
            Case vbAsyncStatusCodeMIMETypeAvailable
                'Another tidbit of info
                m_sMIMEType = .Status 'Save for Get Property
                RaiseEvent DLMIMEType(.Status)
            Case vbAsyncStatusCodeCacheFileNameAvailable
                'location of the local Cache file
                m_sCache = .Status 'Save for Get Property
                RaiseEvent DLCacheFile(.Status)
            Case vbAsyncStatusCodeBeginDownloadData
                'Connected, data transfer commenced.
                'Now we know the file size and can report it
                'This could also have gone under
                'vbAsyncStatusCodeCacheFileNameAvailable
                'Which occurs first, but this looks a little neater
                m_lFileSize = .BytesMax 'Save for Get Property
                RaiseEvent DLFileSize(.BytesMax)
                RaiseEvent DLBeginDownload
            Case vbAsyncStatusCodeError
                'Never found a situation that triggered this
                'help says error msg is in Value not Status, but then
                'there was one other typo on that page already...
                Debug.Print "ERROR: ", .Status, Now 'just in case
                SendError bkDLEUnknown, CStr(.Value)
        End Select
    End With
    UserControl.Refresh
End Sub

'Typical event wrappers
Private Sub UserControl_Click()
    RaiseEvent Click
End Sub

Private Sub UserControl_DblClick()
    RaiseEvent DblClick
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)
    RaiseEvent MouseDown(Button, Shift, x, Y)
End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
    RaiseEvent MouseMove(Button, Shift, x, Y)