frmcolorpalette.frm

文件传送

        Pt = Pt + 2 + 1
    End If

    If ShwSys Then
        For i = 58 To 59
            LPos = (((i - 58) Mod 2) * 7 + pl) + (((i - 58) Mod 2) * 64)
            TPos = (Int((i - 58) / 2) + (Pt + 2)) + (Int((i - 58) / 2) * 20)
            Call SetRect(Clrs(i).Rct, LPos, TPos, LPos + 64, TPos + 20)
        Next i
        
        Pt = (Pt + 2) + 20
    End If
    
    If ShwMor Then
        Call SetRect(Clrs(60).Rct, pl, (Pt + 2), 4 + 7 + 16 * 8, (Pt + 2) + 20)
        Pt = (Pt + 2) + 20
    End If
    
    For i = 1 To 60
        Call DrawButton(i, 0)
    Next i
End Sub

Private Sub DrawButton(ButId As Integer, state As Integer)
    Dim Clr As Long, Brsh As Long
    Dim R As RECT
    
    Call OleTranslateColor(Me.BackColor, ByVal 0&, Clr)
    Brsh = CreateSolidBrush(Clr)
    Call FillRect(hdc, Clrs(ButId).Rct, Brsh)
    Call DeleteObject(Clr)
    Call DeleteObject(Brsh)
    
    Select Case ButId
        Case 1
            If Not ShwDef Then Exit Sub
            
            Clrs(1).Clr = DefClr
            Clrs(1).Tip = "默认颜色"
            
            Call SetRect(R, Clrs(1).Rct.Left + 3, Clrs(1).Rct.Top + 3, Clrs(1).Rct.Right - 3, Clrs(1).Rct.Bottom - 3)
            Call OleTranslateColor(vbGrayText, ByVal 0&, Clr)
            Brsh = CreateSolidBrush(Clr)
            Call FrameRect(hdc, R, Brsh)
            Call DeleteObject(Brsh)
            Call DeleteObject(Clr)
            
            Call SetRect(R, Clrs(1).Rct.Left + 5, Clrs(1).Rct.Top + 5, Clrs(1).Rct.Left + 5 + 12, Clrs(1).Rct.Top + 5 + 12)
            Call OleTranslateColor(Clrs(1).Clr, ByVal 0&, Clr)
            Brsh = CreateSolidBrush(Clr)
            Call FillRect(hdc, R, Brsh)
            Call DeleteObject(Brsh)
            Call DeleteObject(Clr)
            Call OleTranslateColor(vbGrayText, ByVal 0&, Clr)
            Brsh = CreateSolidBrush(Clr)
            Call FrameRect(hdc, R, Brsh)
            Call DeleteObject(Brsh)
            Call DeleteObject(Clr)
            
            Call SetRect(R, Clrs(1).Rct.Left + 5 + 12, Clrs(1).Rct.Top + 3, Clrs(1).Rct.Right - 2, Clrs(1).Rct.Bottom - 3)
            Call DrawText(hdc, DefCap, -1, R, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE)
        Case 2 To 49
            If Not IsSystemColors Then
                Clrs(ButId).Clr = CLng(Mid(NorClrVal, (ButId - 2) * 8 + 1, 8))
                Clrs(ButId).Tip = Trim(Mid(NorClrVal, (ButId - 2) * 8 + 1, 8))
            Else
                If (ButId <= 26) Then
                    Clrs(ButId).Clr = CLng(Mid(SysClrVal, (ButId - 2) * 10 + 1, 10))
                    Clrs(ButId).Tip = Trim(Mid(SysClrTip, (ButId - 2) * 8 + 1, 8))
                Else
                    Clrs(ButId).Clr = &HFFFFFF
                    Clrs(ButId).Tip = ""
                End If
            End If
            
            Call SetRect(R, Clrs(ButId).Rct.Left + 2, Clrs(ButId).Rct.Top + 2, Clrs(ButId).Rct.Right - 2, Clrs(ButId).Rct.Bottom - 2)
            Call OleTranslateColor(Clrs(ButId).Clr, ByVal 0&, Clr)
            Brsh = CreateSolidBrush(Clr)
            Call FillRect(hdc, R, Brsh)
            Call DeleteObject(Brsh)
            Call DeleteObject(Clr)
            
            Call OleTranslateColor(vbGrayText, ByVal 0&, Clr)
            Brsh = CreateSolidBrush(Clr)
            Call FrameRect(hdc, R, Brsh)
            Call DeleteObject(Brsh)
            Call DeleteObject(Clr)
        Case 50 To 57
            If Not ShwCus Then Exit Sub
            
            Clrs(ButId).Clr = &HFFFFFF
            Clrs(ButId).Tip = "自定义颜色" & Trim(str(ButId - 49))
            
            If Not (LastSavedCustClr = 0) Then
                If (UBound(CustClrs) >= (ButId - 49)) Then
                    Clrs(ButId).Clr = CustClrs(ButId - 49)
                End If
            End If
            
            Call OleTranslateColor(Clrs(ButId).Clr, ByVal 0&, Clr)
            Brsh = CreateSolidBrush(Clr)
            Call SetRect(R, Clrs(ButId).Rct.Left + 2, Clrs(ButId).Rct.Top + 2, Clrs(ButId).Rct.Right - 2, Clrs(ButId).Rct.Bottom - 2)
            Call FillRect(hdc, R, Brsh)
            Call DeleteObject(Brsh)
            Call DeleteObject(Clr)
            
            Call OleTranslateColor(vbGrayText, ByVal 0&, Clr)
            Brsh = CreateSolidBrush(Clr)
            Call FrameRect(hdc, R, Brsh)
            Call DeleteObject(Brsh)
            Call DeleteObject(Clr)
        Case 58 To 60
            Dim TmpStr As String
            Select Case ButId
                Case 58: TmpStr = "普通颜色": If Not ShwSys Then Exit Sub
                Case 59: TmpStr = "系统颜色": If Not ShwSys Then Exit Sub
                Case 60: TmpStr = MorCap: If Not ShwMor Then Exit Sub
            End Select
            
            If state = 0 Then
                Call SetRect(R, Clrs(ButId).Rct.Left, Clrs(ButId).Rct.Top, Clrs(ButId).Rct.Right, Clrs(ButId).Rct.Bottom)
            Else
                Call SetRect(R, Clrs(ButId).Rct.Left + 1, Clrs(ButId).Rct.Top + 1, Clrs(ButId).Rct.Right + 1, Clrs(ButId).Rct.Bottom + 1)
            End If
            Call DrawText(hdc, TmpStr, -1, R, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE)
            Clrs(ButId).Tip = Trim(Mid(OtherTip, (ButId - 58) * 17 + 1, 17))
    End Select
    
    Refresh
End Sub

Private Sub DoAction(ButId As Integer)
    Dim i As Integer
    
    Select Case ButId
        Case 1 To 57
            SelectedColor = Clrs(ButId).Clr
            IsCanceled = False
            Call Form_KeyDown(vbKeyEscape, 0)
        Case 58
            If IsSystemColors Then
                IsSystemColors = False
                For i = 2 To 49
                    Call DrawButton(i, 0)
                Next i
            End If
        Case 59
            If Not IsSystemColors Then
                IsSystemColors = True
                For i = 2 To 49
                    Call DrawButton(i, 0)
                Next i
            End If
        Case 60
            SelectedColor = ShowColor
            If Not SelectedColor = -1 Then
                Call SaveCustClr(SelectedColor)
                IsCanceled = False
            Else
                IsCanceled = True
            End If
            Call Form_KeyDown(vbKeyEscape, 0)
    End Select
End Sub

Private Function IsMouseOnBut(ButId As Integer) As Boolean
    Dim Pt As POINTAPI
    
    Call GetCursorPos(Pt)
    Call ScreenToClient(Me.hwnd, Pt)
    IsMouseOnBut = (Pt.X >= Clrs(ButId).Rct.Left And Pt.X <= Clrs(ButId).Rct.Right) And _
                   (Pt.Y >= Clrs(ButId).Rct.Top And Pt.Y <= Clrs(ButId).Rct.Bottom)
End Function

Private Function ShowColor() As Long
    Dim ClrInf As udtCHOOSECOLOR
    Static CustomColors(64) As Byte
    Dim i As Integer
    
    For i = LBound(CustomColors) To UBound(CustomColors)
        CustomColors(i) = 0
    Next i
    
    With ClrInf
        .lStructSize = Len(ClrInf)              'Size of the structure
        .hwndOwner = Me.hwnd                    'Handle of owner window
        .hInstance = App.hInstance              'Instance of application
        .lpCustColors = StrConv(CustomColors, vbUnicode)       'Array of 16 byte values
        .flags = CC_FULLOPEN                    'Flags to open in full mode
    End With
    
    If Not ChooseColor(ClrInf) = 0 Then
        ShowColor = ClrInf.rgbResult
    Else
        ShowColor = -1
    End If
End Function

Private Sub SaveCustClr(ClrVal As OLE_COLOR)
    If (LastSavedCustClr = 0) Then
        ReDim Preserve CustClrs(1) As OLE_COLOR
    Else
        If (UBound(CustClrs) < 8) Then
            ReDim Preserve CustClrs(UBound(CustClrs) + 1) As OLE_COLOR
        End If
    End If
    
    LastSavedCustClr = LastSavedCustClr + 1
    If (LastSavedCustClr > 8) Then LastSavedCustClr = 1
    
    CustClrs(LastSavedCustClr) = ClrVal
End Sub

Private Sub Form_Unload(cancel As Integer)
    Dim i As Integer
    
    For i = 1 To 60
        Call SetRectEmpty(Clrs(i).Rct)
    Next i
    
    If IsTmr1Active Then
        Call KillTimer(Me.hwnd, CLng(TipTmr1))
        IsTmr1Active = False
    End If
    
    If IsTmr2Active Then
        Call KillTimer(Me.hwnd, CLng(TipTmr2))
        IsTmr2Active = False
    End If

    Unload frmTip
End Sub

Public Sub TipTimer(hwnd As Long, uMsg As Long, idEvent As Long, dwTime As Long)
    Select Case idEvent
        Case 1
            Call ShowTip(True)
            
            Call KillTimer(Me.hwnd, CLng(TipTmr1))
            IsTmr1Active = False
        Case 2
            Call ShowTip(False)
    End Select
End Sub

Private Sub ShowTip(state As Boolean)
    If state Then
        Dim Rct As RECT
        Dim Pt As POINTAPI
        Dim TipTxt As String
        
        'Store the tip text in a variable
        TipTxt = Clrs(MouseButId).Tip

        If TipTxt = "" Then Exit Sub
        
        'Clear Tip Form
        frmTip.Cls
        
        'Draw Tip text and position the Tip Form
        Call GetCursorPos(Pt)
        Call SetRect(Rct, 0, 0, frmTip.ScaleWidth, frmTip.ScaleHeight)
        Call DrawText(frmTip.hdc, TipTxt, -1, Rct, DT_CALCRECT)
        Call SetRect(Rct, 0, 0, Rct.Right + 8, Rct.Bottom + 6)
        Call DrawText(frmTip.hdc, TipTxt, -1, Rct, DT_SINGLELINE Or DT_CENTER Or DT_VCENTER Or DT_NOPREFIX)
        Call DrawEdge(frmTip.hdc, Rct, BDR_RAISEDINNER, BF_RECT)
        frmTip.Move (Pt.X + 2) * Screen.TwipsPerPixelX, (Pt.Y + 20) * Screen.TwipsPerPixelY, _
                    Rct.Right * Screen.TwipsPerPixelX, Rct.Bottom * Screen.TwipsPerPixelY
        frmTip.ZOrder
        frmTip.Refresh
        Call ShowWindow(frmTip.hwnd, SW_SHOWNOACTIVATE)
        
        'Set Timer 2 for the duration of tip
        Call SetTimer(Me.hwnd, CLng(TipTmr2), 4000, AddressOf Timer)
        IsTmr2Active = True
    Else
        On Error Resume Next
        
        'Hide Tip Form
        Call ShowWindow(frmTip.hwnd, SW_HIDE)
        
        'Kill Timer 2 if it is active
        If IsTmr2Active Then
            Call KillTimer(Me.hwnd, CLng(TipTmr2))
            IsTmr2Active = False
        End If
        
        'Kill Timer 1 if it is active
        If IsTmr1Active Then
            Call KillTimer(Me.hwnd, CLng(TipTmr1))
            IsTmr1Active = False
        End If
    End If
End Sub