colorpicker.ctl

文件传送

VERSION 5.00
Begin VB.UserControl ColorPicker 
   AutoRedraw      =   -1  'True
   ClientHeight    =   2190
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   3855
   ScaleHeight     =   146
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   257
   ToolboxBitmap   =   "ColorPicker.ctx":0000
End
Attribute VB_Name = "ColorPicker"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'颜色选择下拉框控件
'还包含Common.bas\frmTip.frm\frmColorPalette.frm三个文件


'**********************************************************************
'************** Project :  ColorPicker OCX      ***********************
'************** Version :  1.0                  ***********************
'************** Author  :  Abdul Gafoor.GK      ***********************
'************** Date    :  10/October/2000      ***********************
'**********************************************************************
'
'   This is my second ActiveX control.  My first control was
'   Dropdown Calculator, which can be downloaded with source
'   code from either www.a1vbcode.com or www.vbcode.com
'
'   If you like this control, please don't forget to send
'   your comments in '[e-mail]'
'
'**********************************************************************

Option Explicit

'API function & constant declarations
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long

Private Declare Function DrawFocusRect Lib "user32" (ByVal hdc As Long, lpRect As RECT) As Long

'Module specific variable declarations
Private RClr As RECT
Private RBut As RECT

Private IsInFocus As Boolean
Private IsButDown As Boolean

'Enums
Public Enum cpAppearanceConstants
    Flat
    [3D]
End Enum

'Default Property Values:
Private Const m_def_ShowToolTips = True
Private Const m_def_ShowSysColorButton = True
Private Const m_def_ShowDefault = True
Private Const m_def_ShowCustomColors = True
Private Const m_def_ShowMoreColors = True
Private Const m_def_DefaultCaption = "默认颜色"
Private Const m_def_MoreColorsCaption = "更多颜色..."
Private Const m_def_BackColor = &H8000000C
Private Const m_def_Appearance = cpAppearanceConstants.[3D]
Private Const m_def_Color = &HFFFFFF
Private Const m_def_DefaultColor = &HFFFFFF

'Property Variables:
Private m_ShowToolTips As Boolean
Private m_ShowSysColorButton    As Boolean
Private m_ShowDefault           As Boolean
Private m_ShowCustomColors      As Boolean
Private m_ShowMoreColors        As Boolean
Private m_DefaultCaption        As String
Private m_MoreColorsCaption     As String
Private m_BackColor             As OLE_COLOR
Private m_Appearance            As cpAppearanceConstants
Private m_Color                 As OLE_COLOR
Private m_DefaultColor          As OLE_COLOR

'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_MemberFlags = "200"
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."
Event KeyDown(KeyCode As Integer, Shift As Integer) 'MappingInfo=UserControl,UserControl,-1,KeyDown
Attribute KeyDown.VB_Description = "Occurs when the user presses a key while an object has the focus."
Event KeyPress(KeyAscii As Integer) 'MappingInfo=UserControl,UserControl,-1,KeyPress
Attribute KeyPress.VB_Description = "Occurs when the user presses and releases an ANSI key."
Event KeyUp(KeyCode As Integer, Shift As Integer) 'MappingInfo=UserControl,UserControl,-1,KeyUp
Attribute KeyUp.VB_Description = "Occurs when the user releases a key while an object has the focus."
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."
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."
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."
Event Resize() 'MappingInfo=UserControl,UserControl,-1,Resize
Attribute Resize.VB_Description = "Occurs when a form is first displayed or the size of an object changes."

Private Sub UserControl_Click()
    RaiseEvent Click
End Sub

Private Sub UserControl_GotFocus()
    IsInFocus = True
    Call RedrawControl
End Sub

Private Sub UserControl_Initialize()
    ScaleMode = vbPixels
End Sub

Private Sub UserControl_LostFocus()
    IsInFocus = False
    Call RedrawControl
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseDown(Button, Shift, X * Screen.TwipsPerPixelX, Y * Screen.TwipsPerPixelY)
    
    If Button = 1 Then
        If (X >= RBut.Left And X <= RBut.Right) And (Y >= RBut.Top And Y <= RBut.Bottom) Then
            IsButDown = True
            Call RedrawControl
        End If
    End If
End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseMove(Button, Shift, X * Screen.TwipsPerPixelX, Y * Screen.TwipsPerPixelY)
    
    If IsButDown Then
        If Not ((X >= RBut.Left And X <= RBut.Right) And (Y >= RBut.Top And Y <= RBut.Bottom)) Then
            IsButDown = False
            Call RedrawControl
        End If
    End If
End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseUp(Button, Shift, X * Screen.TwipsPerPixelX, Y * Screen.TwipsPerPixelY)
    
    If Button = 1 Then
        If IsButDown Then
            IsButDown = False
            Call RedrawControl
        End If
        
        If ((X >= ScaleLeft And X <= ScaleWidth) And (Y >= ScaleTop And Y <= ScaleHeight)) Then
            Call ShowPalette
        End If
    End If
End Sub

Private Sub UserControl_Resize()
    RaiseEvent Resize
    If Height < 285 Then Height = 285
    
    Call RedrawControl
End Sub

Private Sub UserControl_DblClick()
    RaiseEvent DblClick
End Sub

Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
    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)
    RaiseEvent KeyUp(KeyCode, Shift)
End Sub

Private Sub RedrawControl()
    Dim Rct As RECT
    Dim Brsh As Long, Clr As Long
    
    Dim lx As Long, ty As Long
    Dim rx As Long, by As Long
    
    lx = ScaleLeft: ty = ScaleTop
    rx = ScaleWidth: by = ScaleHeight
    
    Cls
    
    'Draw background
    Call SetRect(Rct, 0, 0, rx, by)
    Call OleTranslateColor(m_BackColor, ByVal 0&, Clr)
    Brsh = CreateSolidBrush(Clr)
    Call FillRect(hdc, Rct, Brsh)
    If m_Appearance = [3D] Then
        Call DrawEdge(hdc, Rct, EDGE_SUNKEN, BF_RECT)
    Else
        Call DrawEdge(hdc, Rct, BDR_SUNKENOUTER, BF_RECT Or BF_FLAT Or BF_MONO)
    End If
    Call DeleteObject(Brsh)
    Call DeleteObject(Clr)
    
    'Draw button
    Dim CurFontName As String
    CurFontName = Font.name
    Font.name = "Marlett"
    Call OleTranslateColor(vbButtonFace, ByVal 0&, Clr)
    Brsh = CreateSolidBrush(Clr)
    If m_Appearance = [3D] Then
        If IsButDown Then
            Call SetRect(RBut, rx - 15, 2, rx - 2, by - 2)
            Call FillRect(hdc, RBut, Brsh)
            Call DrawEdge(hdc, RBut, EDGE_RAISED, BF_RECT Or BF_FLAT)
            Call SetRect(Rct, RBut.Left + 2, RBut.Top, RBut.Right, RBut.Bottom)
            Call DrawText(hdc, "6", 1&, Rct, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE)
        Else
            Call SetRect(RBut, rx - 15, 2, rx - 2, by - 2)
            Call FillRect(hdc, RBut, Brsh)
            Call DrawEdge(hdc, RBut, EDGE_RAISED, BF_RECT)
            Call SetRect(Rct, RBut.Left, RBut.Top, RBut.Right, RBut.Bottom - 1)
            Call DrawText(hdc, "6", 1&, Rct, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE)
        End If
    Else
        Call SetRect(RBut, rx - 15, ty, rx, by)
        Call FillRect(hdc, RBut, Brsh)
        Call DrawEdge(hdc, RBut, BDR_SUNKENOUTER, BF_RECT Or BF_FLAT)
        Call SetRect(Rct, RBut.Left + 1, RBut.Top, RBut.Right, RBut.Bottom - 1)
        Call DrawText(hdc, "6", 1&, Rct, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE)
    End If
    Font.name = CurFontName
    Call DeleteObject(Brsh)
    Call DeleteObject(Clr)
    
    'Draw Color
    If m_Appearance = [3D] Then
        Call SetRect(RClr, 4, 4, rx - 17, by - 4)
    Else
        Call SetRect(RClr, 3, 3, rx - 17, by - 3)
    End If
    Call OleTranslateColor(m_Color, ByVal 0&, Clr)
    Brsh = CreateSolidBrush(Clr)
    Call FillRect(hdc, RClr, Brsh)
    Call DeleteObject(Brsh)
    Call DeleteObject(Clr)
    
    'Draw border to the color