xpb.ctl

VB实现的注册码发生器

            End With
        End If
    End If
End Sub

Private Sub UserControl_Initialize()
    Set g_Font = New StdFont
    
    ScaleMode = 3
    PaletteMode = 3
End Sub

Private Sub UserControl_AccessKeyPress(KeyAscii As Integer)
    If Not Me.Enabled Then Exit Sub
        RaiseEvent Click
        GoToURL
End Sub

Private Sub UserControl_AmbientChanged(PropertyName As String)
    Refresh
End Sub

Private Sub UserControl_EnterFocus()
    g_HasFocus = 1
    Refresh
End Sub

Private Sub UserControl_ExitFocus()
    g_HasFocus = 0
    g_MouseDown = 0
    Refresh
End Sub

Private Sub UserControl_Resize()
    
    If ScaleWidth < 10 Then UserControl.Width = 150
    If ScaleHeight < 10 Then UserControl.Height = 150
    
Gen = ScaleWidth
Yuk = ScaleHeight

    
    g_FocusRect.Left = 4
    g_FocusRect.Right = ScaleWidth - 4
    g_FocusRect.Top = 4
    g_FocusRect.Bottom = ScaleHeight - 4
    
    DeleteObject AreaOriginal
    If m_ButtonStyle = gbWinXP Then
        RoundCorners
    End If
    Refresh
End Sub
Public Sub Refresh()
    AutoRedraw = True
                      
    
    UserControl.Cls
    
    
    XPAdjustColorScheme
    If m_ButtonStyle <> gbNoBorder Then Draw3DEffect
    CalcRECTs
    DrawPicture
    If g_HasFocus = 1 And m_ShowFocusRect And m_ButtonStyle <> gbWinXP Then DrawFocusRect hdc, g_FocusRect
    DrawCaption
    AutoRedraw = False
End Sub

Private Sub UserControl_DblClick()
    SetCapture hwnd
    UserControl_MouseDown g_Button, g_Shift, g_X, g_Y
End Sub

Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
    If g_KeyPressed = 0 Then
                             
                             
            If KeyCode = 32 Then
                g_MouseDown = 1
                g_MouseIn = 1
                Refresh
            End If
        g_KeyPressed = 1
    End If
    RaiseEvent KeyDown(KeyCode, Shift)
End Sub

Private Sub UserControl_KeyPress(KeyAscii As Integer)
    RaiseEvent KeyPress(KeyAscii)
End Sub

Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode = 32 Then
        g_MouseDown = 0
        g_MouseIn = 0
        GoToURL
        Refresh

        UserControl_MouseUp 1, Shift, 0, 0
    End If
    g_KeyPressed = 0
    RaiseEvent KeyUp(KeyCode, Shift)
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    g_Button = Button: g_Shift = Shift: g_X = x: g_Y = y
    If Button <> 2 Then
        g_MouseDown = 1
        Refresh
    End If
    RaiseEvent MouseDown(Button, Shift, x, y)
End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    If (x >= 0 And y >= 0) And (x < ScaleWidth And y < ScaleHeight) Then
        If g_MouseIn = 0 Then
            OverTimer.Enabled = True
            g_MouseIn = 1
            If Not m_PictureHover Is Nothing Then
                Set m_Picture = m_PictureHover
            End If
            RaiseEvent MouseIn(Shift)
            Refresh
            DoEvents
            
        End If
    End If
    RaiseEvent MouseMove(Button, Shift, x, y)
End Sub
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    g_MouseDown = 0
    If Button <> 2 Then
        Refresh
        If (x >= 0 And y >= 0) And (x < ScaleWidth And y < ScaleHeight) Then
            Call PlayASound(SoundClick)
            RaiseEvent Click
            GoToURL
        End If
    End If
    RaiseEvent MouseUp(Button, Shift, x, y)
End Sub

Public Property Get Enabled() As Boolean
    Enabled = UserControl.Enabled
End Property

Public Property Let Enabled(ByVal New_Enabled As Boolean)
    UserControl.Enabled() = New_Enabled
    PropertyChanged "Enabled"
    Refresh
End Property
Public Property Get Font() As Font
Attribute Font.VB_UserMemId = -512
    Set Font = g_Font
End Property

Public Property Set Font(ByVal New_Font As Font)
    With g_Font
        .Name = New_Font.Name
        .Size = New_Font.Size
        .Bold = New_Font.Bold
        .Italic = New_Font.Italic
        .Underline = New_Font.Underline
        .Strikethrough = New_Font.Strikethrough
    End With
    PropertyChanged "Font"
End Property

Private Sub g_Font_FontChanged(ByVal PropertyName As String)
    Set UserControl.Font = g_Font
    Refresh
End Sub


Public Property Get hwnd() As Long
    hwnd = UserControl.hwnd
End Property

Public Property Get MousePointer() As MousePointerConstants
    MousePointer = UserControl.MousePointer
End Property

Public Property Let MousePointer(ByVal New_MousePointer As MousePointerConstants)
    UserControl.MousePointer() = New_MousePointer
    PropertyChanged "MousePointer"
End Property

Public Property Get MouseIcon() As StdPicture
    Set MouseIcon = UserControl.MouseIcon
End Property

Public Property Set MouseIcon(ByVal New_MouseIcon As StdPicture)
    Set UserControl.MouseIcon = New_MouseIcon
    PropertyChanged "MouseIcon"
End Property

Public Property Get ShowFocusRect() As Boolean
    ShowFocusRect = m_ShowFocusRect
End Property

Public Property Let ShowFocusRect(ByVal New_ShowFocusRect As Boolean)
    m_ShowFocusRect = New_ShowFocusRect
    PropertyChanged "ShowFocusRect"
    Refresh
End Property
             
Private Sub RunXTRA3D(RENK As Long, BEVELL As Integer, BEVELDEPTHH As Integer)
    Dim T As Integer
    Dim TEMPRENK As Long
                TEMPRENK = RENK
                BEVELDEPTHH = BEVELDEPTHH * (-1)
                
                For T = BEVELL To 0 Step -1
                    TEMPRENK = COLOR_DarkenLightenColor(TEMPRENK, BEVELDEPTHH)
                    DRAWRECT hdc, T, T, ScaleWidth - T, ScaleHeight - T, TEMPRENK, 0
                Next T
             
                BEVELDEPTHH = BEVELDEPTHH * (-1)
                For T = BEVELL To 0 Step -1
                    RENK = RGB(COLOR_LongToRGB(RENK).Red + BEVELDEPTHH, COLOR_LongToRGB(RENK).Green + BEVELDEPTHH, COLOR_LongToRGB(RENK).blue + BEVELDEPTHH)
                    DrawLine T, T, ScaleWidth - (T + 1), T, RENK
                    DrawLine T, T, T, ScaleHeight - (T + 1), RENK
                    
                Next T
End Sub
Private Sub RunXTRA3D_PRESSED(RENK As Long, BEVELL As Integer, BEVELDEPTHH As Integer)
    Dim ret As Integer
    Dim GRIN As Integer
    Dim BLU As Integer
    Dim T As Integer
                Dim TEMPRENK As Long
                TEMPRENK = RENK
                
                For T = BEVELL To 0 Step -1
                    ret = COLOR_LongToRGB(TEMPRENK).Red + BEVELDEPTHH
                    GRIN = COLOR_LongToRGB(TEMPRENK).Green + BEVELDEPTHH
                    BLU = COLOR_LongToRGB(TEMPRENK).blue + BEVELDEPTHH
                    TEMPRENK = RGB(ret, GRIN, BLU)
                    DRAWRECT hdc, T, T, ScaleWidth - T, ScaleHeight - T, TEMPRENK, 0
                Next T
                
                
                BEVELDEPTHH = BEVELDEPTHH * (-1)
                For T = BEVELL To 0 Step -1
                    RENK = COLOR_DarkenLightenColor(RENK, BEVELDEPTHH)
                    DrawLine T, T, ScaleWidth - (T + 1), T, RENK
                    DrawLine T, T, T, ScaleHeight - (T + 1), RENK
                Next T
End Sub
Private Sub RunShowBorderOnFocus(RENK As Long, BEVELL As Integer, BEVELDEPTHH As Integer)
Dim T As Integer
            If BEVELL < 2 Then
                DRAWRECT hdc, 0, 0, ScaleWidth - 1, ScaleHeight - 1, &H80000010
                DRAWRECT hdc, 0, 0, ScaleWidth + 1, ScaleHeight + 1, &H80000014
                DRAWRECT hdc, -1, -1, ScaleWidth + 1, ScaleHeight + 1, &H80000015
            Else
                RunXTRA3D COLOR_UniColor(UserControl.BackColor), m_BEVEL, BEVELDEPTH + 3
            End If
End Sub
Private Sub XPAdjustColorScheme()
If m_ButtonStyle = gbWinXP Then Exit Sub
    If m_ButtonStyle = gbOfficeXP Then
        If m_TransparentBG = True And g_MouseDown = 0 Then
            Transparentia
        Else
            UserControl.BackColor = m_BackColor
        End If
    Else
        If m_TransparentBG = True Then Transparentia
    End If


    
    
    If m_ButtonStyle = gbOfficeXP Then
        Dim l1 As Double
        Dim l2 As Double
        Dim l3 As Double
        Dim ll As Double
        Dim KOLOR As RGB
        l1 = 171
        l2 = 154
        l3 = 108
        ll = -15
        KOLOR = COLOR_LongToRGB(COLOR_UniColor(&H8000000D))
        If g_MouseDown = 0 And g_MouseIn = 1 Then
                If XPDefaultColors = True Then
                   
                   UserControl.BackColor = RGB(KOLOR.Red + l1, KOLOR.Green + l2, _
                                                                    KOLOR.blue + l3)
                Else
                   UserControl.BackColor = XPColor_Hover
                End If
        End If
        
        If g_MouseDown = 1 Then
                If XPDefaultColors = True Then
                    UserControl.BackColor = RGB(KOLOR.Red + l1 + ll, _
                                    KOLOR.Green + l2 + ll, KOLOR.blue + l3)
                Else
                    UserControl.BackColor = XPColor_Pressed
                End If
        End If
    End If
End Sub
Private Sub Draw3DEffect()
    If Not Ambient.UserMode Then
        If m_ButtonStyle = gbWinXP Then
                DrawWinXPButton 0
        ElseIf m_ButtonStyle = gbOfficeXP Then
                XPAdjustColorScheme
        Else
            If m_BEVEL < 2 Then
                DRAWRECT hdc, 0, 0, ScaleWidth, ScaleHeight, &H80000010
                DRAWRECT hdc, 0, 0, ScaleWidth + 1, ScaleHeight + 1, &H80000014
            Else
                RunXTRA3D COLOR_UniColor(UserControl.BackColor), m_BEVEL, BEVELDEPTH
            End If
        End If
    Exit Sub
    End If
    
    
    
    
    
    
    
    
    If m_ButtonStyle = gbOfficeXP Then
                If Not (XPShowBorderAlways = False And g_MouseIn = 0) Then
                    DRAWRECT hdc, 0, 0, ScaleWidth, ScaleHeight, m_ForeColor
                End If
    ElseIf m_ButtonStyle = gbWinXP Then
            If g_MouseDown = 1 Then DrawWinXPButton 2
            If g_MouseDown = 0 And g_MouseIn = 1 Then DrawWinXPButton 0, 1
            If g_MouseDown = 0 And g_MouseIn = 0 Then DrawWinXPButton 0
    Else
        If g_MouseDown = 1 Then
            If m_BEVEL < 2 Then
                DRAWRECT hdc, 0, 0, ScaleWidth, ScaleHeight, &H80000014
                DRAWRECT hdc, 0, 0, ScaleWidth + 1, ScaleHeight + 1, &H80000010
            Else
                RunXTRA3D_PRESSED COLOR_UniColor(UserControl.BackColor), m_BEVEL, BEVELDEPTH
            End If
        End If
        If g_MouseDown = 0 And g_MouseIn = 1 Then
            If m_BEVEL < 2 Then
                DRAWRECT hdc, 0, 0, ScaleWidth, ScaleHeight, &H80000010
                DRAWRECT hdc, 0, 0, ScaleWidth + 1, ScaleHeight + 1, &H80000014
            Else
                RunXTRA3D COLOR_UniColor(UserControl.BackColor), m_BEVEL, BEVELDEPTH
            End If
        End If
        
        If g_MouseDown = 0 And g_MouseIn = 0 And m_ButtonStyle = gbStandard Then
            If m_BEVEL < 2 Then
                DRAWRECT hdc, 0, 0, ScaleWidth, ScaleHeight, &H80000010
                DRAWRECT hdc, 0, 0, ScaleWidth + 1, ScaleHeight + 1, &H80000014
            Else
                RunXTRA3D COLOR_UniColor(UserControl.BackColor), m_BEVEL, BEVELDEPTH
            End If
        End If
         
          If (g_HasFocus = 1 And m_ButtonStyle = gbStandard And g_MouseDown = 0) Or Extender.Default Then
                    RunShowBorderOnFocus COLOR_UniColor(UserControl.BackColor), m_BEVEL, BEVELDEPTH
         End If
    End If
End Sub
Private Sub OverTimer_Timer()
    Dim P As POINTAPI
    GetCursorPos P
    If hwnd <> WindowFromPoint(P.x, P.y) Then
        OverTimer.Enabled = False
        g_MouseIn = 0
        Set m_Picture = m_PictureOriginal
        RaiseEvent MouseOut(g_Shift)
        Refresh
        If g_MouseDown = 1 Then
            g_MouseDown = 0
            Refresh
            g_MouseDown = 1
        End If
    End If
End Sub

Public Sub GoToURL()
    
    If Left(m_URL, 7) = "mailto:" Then
        Navigate UserControl.Parent, m_URL
        Exit Sub
    End If
        If Not m_URL = "" Then UserControl.Hyperlink.NavigateTo m_URL
End Sub
Private Sub Navigate(frm As Form, ByVal WebPageURL As String)
Dim hBrowse As Long
hBrowse = ShellExecute(frm.hwnd, "open", WebPageURL, "", "", 1)
End Sub
Public Property Get URL() As String
    URL = m_URL
End Property

Public Property Let URL(ByVal New_URL As String)