frmcolorpalette.frm

文件传送

VERSION 5.00
Begin VB.Form frmColorPalette 
   AutoRedraw      =   -1  'True
   BorderStyle     =   0  'None
   ClientHeight    =   2760
   ClientLeft      =   3255
   ClientTop       =   2835
   ClientWidth     =   2250
   LinkTopic       =   "Form1"
   MouseIcon       =   "frmColorPalette.frx":0000
   ScaleHeight     =   184
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   150
   ShowInTaskbar   =   0   'False
End
Attribute VB_Name = "frmColorPalette"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'这是一个颜色选择下拉框控件
'由我汉化并修正其中文显示问题.
'包含frmColorPalette.frm\frmTip.frm\CommDlgs.bas\ColorPicker.ctl四个文件.可以把这三个文件提取出来作控件用
'实际版权归原作者所有


Option Explicit
Option Base 1

'API function & constant declarations
Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As udtCHOOSECOLOR) As Long
Private Type udtCHOOSECOLOR
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    rgbResult As Long
    lpCustColors As String
    flags As Long
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type
Private Const CC_FULLOPEN = &H2
Private Const CC_ANYCOLOR = &H100

Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long

Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Const SW_SHOWNOACTIVATE = 4
Private Const SW_HIDE = 0

Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long

'Module specific variable declarations
Private Type cpColorInformation
    Clr As OLE_COLOR
    Rct As RECT
    Tip As String
End Type

Private Clrs(60) As cpColorInformation

Private IsSystemColors As Boolean
Private MouseButId As Integer
Private MouseDownButId As Integer
Private CurClrButId As Integer

Private Const NorClrVal = "&HFFFFFF&HC0C0FF&HC0E0FF&HC0FFFF&HC0FFC0&HFFFFC0&HFFC0C0&HFFC0FF" & _
                          "&HE0E0E0&H8080FF&H80C0FF&H80FFFF&H80FF80&HFFFF80&HFF8080&HFF80FF" & _
                          "&HC0C0C0&H0000FF&H0080FF&H00FFFF&H00FF00&HFFFF00&HFF0000&HFF00FF" & _
                          "&H808080&H0000C0&H0040C0&H00C0C0&H00C000&HC0C000&HC00000&HC000C0" & _
                          "&H404040&H000080&H004080&H008080&H008000&H808000&H800000&H800080" & _
                          "&H000000&H000040&H404080&H004040&H004000&H404000&H400000&H400040"
Private Const SysClrVal = "&H80000000&H80000001&H80000002&H80000003&H80000004&H80000005" & _
                          "&H80000006&H80000007&H80000008&H80000009&H8000000A&H8000000B" & _
                          "&H8000000C&H8000000D&H8000000E&H8000000F&H80000010&H80000011" & _
                          "&H80000012&H80000013&H80000014&H80000015&H80000016&H80000017" & _
                          "&H80000018"
Private Const NorClrTip = ""
Private Const SysClrTip = "滚动条     " & _
                          "桌面      " & _
                          "活动标题栏   " & _
                          "非活动标题栏  " & _
                          "菜单条     " & _
                          "窗口背景    " & _
                          "窗口框架    " & _
                          "菜单文本    " & _
                          "窗口文本    " & _
                          "活动标题栏文本 " & _
                          "活动边框    " & _
                          "非活动边框   " & _
                          "应用程序工作区 " & _
                          "突出显示    " & _
                          "突出显示文本  " & _
                          "按钮表面    " & _
                          "按钮阴影    " & _
                          "无效文本    " & _
                          "按钮文本    " & _
                          "非活动标题栏文本" & _
                          "按钮突出显示  " & _
                          "按钮暗阴影   " & _
                          "按钮亮阴影   " & _
                          "工具提示文本  " & _
                          "工具提示    "
Private Const OtherTip = "普通颜色             " & _
                         "系统颜色             " & _
                         "显示颜色对话框          "

Private pl As Long, Pt As Long

Private Const TipTmr1 = 1
Private Const TipTmr2 = 2
Private IsTmr1Active As Boolean
Private IsTmr2Active As Boolean
Private TipButId As Integer

Public SelectedColor As OLE_COLOR
Public IsCanceled As Boolean

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    If (KeyCode = vbKeyEscape) Then
        Me.Hide
    End If
End Sub

Private Sub Form_Load()
    Dim R As RECT
    
    Me.ScaleMode = vbPixels
    Me.Font.name = "Arial"
    
    Call SetCapture(hwnd)
    
    IsSystemColors = False
    MouseButId = -1
    MouseDownButId = -1
    IsCanceled = True
    
    Call Initialize
    
    Width = (pl + (8 * 16) + 7 + 4) * Screen.TwipsPerPixelX
    Height = (Pt + 4) * Screen.TwipsPerPixelY
    
    Call SetRect(R, 0, 0, ScaleWidth, ScaleHeight)
    Call DrawEdge(hdc, R, BDR_RAISEDINNER, BF_RECT)
    
    Load frmTip
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Not (Button = 1) Then Exit Sub
    
    If Not (MouseButId = -1) Then
        If (MouseButId = 58) Or (MouseButId = 59) Or (MouseButId = 60) Then
            Call DrawButton(MouseButId, 1)
        End If
        Call DrawButEdge(MouseButId, 2)
        
        MouseDownButId = MouseButId
        
        Call ShowTip(False)
    End If
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim i As Integer
    Dim IsMouseOnBut As Boolean
    
    If Not (MouseDownButId = -1) Then
        Exit Sub
    End If
    
    For i = 1 To 60
        IsMouseOnBut = (X >= Clrs(i).Rct.Left And Y >= Clrs(i).Rct.Top) And (X <= Clrs(i).Rct.Right And Y <= Clrs(i).Rct.Bottom)
        If IsMouseOnBut Then
            Exit For
        End If
    Next i
    
    If (Not MouseButId = -1) And (Not MouseButId = i) Then
        Call DrawButEdge(MouseButId, 0)
        MouseButId = -1
        Call ShowTip(False)
    End If
    
    If IsMouseOnBut And (Not MouseButId = i) Then
        MouseButId = i
        Call DrawButEdge(MouseButId, 1)
        
        If ShwTip Then
            Call SetTimer(Me.hwnd, CLng(TipTmr1), 1000, AddressOf Timer)
            IsTmr1Active = True
        End If
    End If
    
    If Not IsMouseOnBut Then
        If IsTmr1Active Then
            Call KillTimer(Me.hwnd, CLng(TipTmr1))
            IsTmr1Active = False
        End If
    End If
    
'    If (i >= 1) And (i <= 57) Then
'        If Not Me.MousePointer = vbCustom Then Me.MousePointer = vbCustom
'    Else
'        If Not Me.MousePointer = vbDefault Then Me.MousePointer = vbDefault
'    End If
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim IsMouseOver As Boolean
    
    If Not (MouseDownButId = -1) Then
        If (MouseDownButId = 58) Or (MouseDownButId = 59) Or (MouseDownButId = 60) Then
            Call DrawButton(MouseDownButId, 0)
        End If
        Call DrawButEdge(MouseDownButId, 1)
        
        If IsMouseOnBut(MouseDownButId) Then
            Call DoAction(MouseDownButId)
        End If
        
        MouseDownButId = -1
    End If
    
    IsMouseOver = X >= 0 And Y >= 0 And X <= ScaleWidth And Y <= ScaleHeight
    If IsMouseOver Then
        Call SetCapture(Me.hwnd)
    Else
        Call ReleaseCapture
        Call Form_KeyDown(vbKeyEscape, 0)
    End If
End Sub

Private Sub DrawButEdge(ClrId As Integer, EdgeStyle As Integer)
    Select Case EdgeStyle
        Case 0: Call DrawEdge(hdc, Clrs(ClrId).Rct, BDR_RAISEDINNER, BF_RECT Or BF_FLAT)
        Case 1: Call DrawEdge(hdc, Clrs(ClrId).Rct, BDR_RAISEDINNER, BF_RECT)
        Case 2: Call DrawEdge(hdc, Clrs(ClrId).Rct, BDR_SUNKENOUTER, BF_RECT)
    End Select
    
    Refresh
End Sub

Private Sub Initialize()
    Dim i As Integer
    Dim LPos As Long, TPos As Long
    Dim FrmBkClr As Long
    
    pl = 4: Pt = 0
    
    If ShwDef Then
        Call SetRect(Clrs(1).Rct, pl, (Pt + 4), pl + 7 + 16 * 8, (Pt + 4) + 22)
        Pt = (Pt + 4) + 22
    End If
    
    For i = 2 To 49
        LPos = (((i - 2) Mod 8) + pl) + (((i - 2) Mod 8) * 16)
        TPos = (Int((i - 2) / 8) + (Pt + 4)) + (Int((i - 2) / 8) * 16)
        Call SetRect(Clrs(i).Rct, LPos, TPos, LPos + 16, TPos + 16)
    Next i
    Pt = (Pt + 4) + (6 * 16) + 5

    If ShwCus Then
        FrmBkClr = Me.ForeColor
        Me.ForeColor = vb3DShadow
        CurrentX = 4: CurrentY = Pt + 2
        Line -(16 * 8 + 4 + 7, CurrentY)
        Me.ForeColor = vb3DHighlight
        CurrentX = 4: CurrentY = Pt + 2 + 1
        Line -(16 * 8 + 4 + 7, CurrentY)
        Me.ForeColor = FrmBkClr
        
        Pt = Pt + 2 + 1
        
        For i = 50 To 57
            LPos = (((i - 50) Mod 8) + 4) + (((i - 50) Mod 8) * 16)
            TPos = (Int((i - 50) / 8) + (Pt + 2)) + (Int((i - 50) / 8) * 16)
            Call SetRect(Clrs(i).Rct, LPos, TPos, LPos + 16, TPos + 16)
        Next i
        
        Pt = (Pt + 2) + 16
    End If
    
    If ShwMor Or ShwSys Then
        FrmBkClr = Me.ForeColor
        Me.ForeColor = vb3DShadow
        CurrentX = 4: CurrentY = Pt + 2
        Line -(16 * 8 + 4 + 7, CurrentY)
        Me.ForeColor = vb3DHighlight
        CurrentX = 4: CurrentY = Pt + 2 + 1
        Line -(16 * 8 + 4 + 7, CurrentY)
        Me.ForeColor = FrmBkClr