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