command.ctl

vb源码之家界面源码,非常详细的说明和代码

VERSION 5.00
Begin VB.UserControl CommandButton 
   AutoRedraw      =   -1  'True
   ClientHeight    =   3600
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4800
   ScaleHeight     =   240
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   320
End
Attribute VB_Name = "CommandButton"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'*************************************************************************
'**模 块 名：CommandButton
'**说    明：YFsoft 版权所有2005 - 2006(C)
'**创 建 人：叶帆
'**日    期：2005-03-27 19:30:10
'**修 改 人：
'**日    期：
'**描    述：
'**版    本：V1.2.8
'*************************************************************************
Option Explicit
Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long

Private Type SepRGB
    Red As Single
    Green As Single
    Blue As Single
End Type

Private Const DisabledForeColor As Long = 9740965

' Idle Colors
Private Const BorderColorLines As Long = 7549440
Private Const FirstBottomLine As Long = 15199215
Private Const SecondBottomLine As Long = 14082023
Private Const ThirdBottomLine As Long = 13030358

Private Const FirstCornerPixel As Long = 8672545
Private Const SecondCornerPixel As Long = 11376251
Private Const ThirdCornerPixel As Long = 10845522
Private Const FourthCornerPixel As Long = 14602182
    
Private Const FromColorFade As Long = 16250871
Private Const ToColorFade As Long = 15199215

' Disabled Colors
Private Const BorderColorLinesX As Long = 12437454
Private Const FirstBottomLineX As Long = 15726583
Private Const SecondBottomLineX As Long = 15726583
Private Const ThirdBottomLineX As Long = 15726583
    
Private Const FirstCornerPixelX As Long = 12437454
Private Const SecondCornerPixelX As Long = 12437454
Private Const ThirdCornerPixelX As Long = 12437454
Private Const FourthCornerPixelX As Long = 12437454
    
Private Const FromColorFadeX As Long = 15726583
Private Const ToColorFadeX As Long = 15726583
    
' Down colors
Private Const BorderColorLinesD As Long = 7549440
Private Const FirstBottomLineD As Long = 15199215
Private Const SecondBottomLineD As Long = 14082023
Private Const ThirdBottomLineD As Long = 15725559
    
Private Const FirstCornerPixelD As Long = 8672545
Private Const SecondCornerPixelD As Long = 11376251
Private Const ThirdCornerPixelD As Long = 10845522
Private Const FourthCornerPixelD As Long = 14602182
    
Private Const FromColorFadeD As Long = 14607335
Private Const ToColorFadeD As Long = 14607335
    
' Has focus colors
Private Const BorderColorLinesF As Long = 7549440
Private Const FirstTopLineF As Long = 16771022
Private Const SecondTopLineF As Long = 16242621
Private Const FirstBottomLineF As Long = 15199215
    
Private Const SecondBottomLineF As Long = 15183500
Private Const ThirdBottomLineF As Long = 15696491
Private Const FirstCornerPixelF As Long = 8672545
Private Const SecondCornerPixelF As Long = 11376251
    
Private Const ThirdCornerPixelF As Long = 10845522
Private Const FourthCornerPixelF As Long = 14602182
Private Const FromColorFadeF As Long = 16250871
Private Const ToColorFadeF As Long = 15199215
    
Private Const SideFromColorFadeF As Long = 16241597
Private Const SideToColorFadeF As Long = 15183500

' HOT Colors
Private Const BorderColorLinesH As Long = 7549440
Private Const FirstTopLineH As Long = 13562879
Private Const SecondTopLineH As Long = 9231359
Private Const FirstBottomLineH As Long = 15199215
    
Private Const SecondBottomLineH As Long = 3257087
Private Const ThirdBottomLineH As Long = 38630
Private Const FirstCornerPixelH As Long = 8672545
Private Const SecondCornerPixelH As Long = 11376251
    
Private Const ThirdCornerPixelH As Long = 10845522
Private Const FourthCornerPixelH As Long = 14602182
Private Const FromColorFadeH As Long = 16250871
Private Const ToColorFadeH As Long = 15199215
    
Private Const SideFromColorFadeH As Long = 10280929
Private Const SideToColorFadeH As Long = 3192575
    
Private PropCaption As String
Private HasFocus As Boolean
Private MouseOver As Boolean
Private MouseDown As Boolean
Private PropEnabled As Boolean
Private PropForeColor As Long
Private mDotBackColor As Long


Event Click()
Event DblClick()
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

Public Property Let ForeColor(NewValue As OLE_COLOR)
    PropForeColor = NewValue
    Redraw
End Property

Public Property Get ForeColor() As OLE_COLOR
    ForeColor = PropForeColor
End Property

Public Property Let DotBackColor(NewValue As OLE_COLOR)
    mDotBackColor = NewValue
    Redraw
End Property

Public Property Get DotBackColor() As OLE_COLOR
    DotBackColor = mDotBackColor
End Property

Public Property Let Caption(NewValue As String)
    PropCaption = NewValue
    Redraw
End Property

Public Property Get Caption() As String
    Caption = PropCaption
End Property

Public Property Set Font(NewValue As StdFont)
    Set UserControl.Font = NewValue
    Redraw
End Property

Public Property Get Font() As StdFont
    Set Font = UserControl.Font
End Property

Public Property Let Enabled(NewValue As Boolean)
    PropEnabled = NewValue
    Redraw
End Property

Public Property Get Enabled() As Boolean
    Enabled = PropEnabled
End Property

Private Function CreateFade(FromColor As Long, ToColor As Long, FadeLength As Long) As Collection
    On Error GoTo ToExit '打开错误陷阱
    '------------------------------------------------
    Dim Increment As SepRGB, ToColorRGB As SepRGB, FromColorRGB As SepRGB, SubRGB As SepRGB
    Dim Final As SepRGB, Results As New Collection, X As Long

    If FromColor = ToColor Then
        For X = 1 To FadeLength
            Results.Add FromColor
        Next
        GoTo ThatsIt
    End If

    ToColorRGB = GetRGB(ToColor)
    FromColorRGB = GetRGB(FromColor)

    With SubRGB
        .Red = Abs(ToColorRGB.Red - FromColorRGB.Red)
        .Green = Abs(ToColorRGB.Green - FromColorRGB.Green)
        .Blue = Abs(ToColorRGB.Blue - FromColorRGB.Blue)
    End With

    With Increment
        .Red = SubRGB.Red / FadeLength
        .Green = SubRGB.Green / FadeLength
        .Blue = SubRGB.Blue / FadeLength
    End With

    With Final
        .Red = FromColorRGB.Red
        .Green = FromColorRGB.Green
        .Blue = FromColorRGB.Blue

        For X = 1 To FadeLength
            Results.Add RGB(.Red, .Green, .Blue)
        
            If .Red <> ToColorRGB.Red Then If .Red > ToColorRGB.Red Then .Red = .Red - Increment.Red Else .Red = .Red + Increment.Red
            If .Green <> ToColorRGB.Green Then If .Green > ToColorRGB.Green Then .Green = .Green - Increment.Green Else .Green = .Green + Increment.Green
            If .Blue <> ToColorRGB.Blue Then If .Blue > ToColorRGB.Blue Then .Blue = .Blue - Increment.Blue Else .Blue = .Blue + Increment.Blue
        Next
    End With

ThatsIt:
    Set CreateFade = Results
    '------------------------------------------------
    Exit Function
    '----------------
ToExit:
    Resume Next
End Function

Private Function GetRGB(ByVal LongValue As Long) As SepRGB
    LongValue = Abs(LongValue)
    GetRGB.Red = LongValue And 255
    GetRGB.Green = (LongValue \ 256) And 255
    GetRGB.Blue = (LongValue \ 65536) And 255
End Function

Private Sub Redraw()
    On Error GoTo ToExit '打开错误陷阱
    '------------------------------------------------
    Dim sCaption() As String, endCaption As String, X As Long
    Cls

    If PropEnabled = False Then
        DrawDisabled
        GoTo DrawCaption
    End If

    If MouseDown = True Then
        If MouseOver = True Then
            DrawDown
        Else
            GoTo DoOthers
        End If
    Else
DoOthers:
        If MouseOver = True Then
            DrawHot
        Else
            If HasFocus = False Then
                DrawIdle
            Else
                DrawFocus
            End If
        End If
    End If

DrawCaption:
    If LenB(PropCaption) = 0 Then Exit Sub

    With UserControl
        If PropEnabled = True Then
            UserControl.ForeColor = PropForeColor
        Else
            UserControl.ForeColor = DisabledForeColor
        End If

        ' Draws the caption.
        sCaption = Split(PropCaption, " ")

        For X = 0 To UBound(sCaption)
            ' See how much text can fit on one line before I add a line break.

            If TextWidth(endCaption & sCaption(X)) > .ScaleWidth - 3 Then
                If LenB(endCaption) <> 0 Then endCaption = Left$(endCaption, Len(endCaption) - 1)
                endCaption = endCaption & vbCrLf
            End If

            endCaption = endCaption & sCaption(X) & " "
        Next

        endCaption = Left$(endCaption, Len(endCaption) - 1)
        sCaption = Split(endCaption, vbCrLf)

        .CurrentY = (.ScaleHeight / 2) - (TextHeight(endCaption) / 2)

        For X = 0 To UBound(sCaption)
            ' Now draw each new line in the middle of the control.

            .CurrentX = (.ScaleWidth / 2) - (TextWidth(sCaption(X)) / 2)
            Print sCaption(X)
        Next