急！！颜色选择的控件

是注册还是要安装我已经忘了，我现在只有actskin4.ocx,要的话留邮箱。

Option ExplicitPrivate Sub cmdClose_Click()
    Unload Me
End SubPrivate Sub ColorSelector1_Click()
    picsample.BackColor = QBColor(ColorSelector1.SelectedColor)
End SubPrivate Sub Form_Load()
    ColorSelector1.SelectedColor = 15
End Sub
控件
Option ExplicitPrivate Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End TypePrivate Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetCapture Lib "user32" () As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
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
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetFocus Lib "user32" () As LongPrivate Const GWL_EXSTYLE = (-20)
Private Const WS_EX_TOOLWINDOW = &H80Dim m_SelectedColor As Integer
'Event Declarations:
Event Click() 'MappingInfo=picPopup,picPopup,-1,Click
Private Sub cmdPopup_Click()
    picSelection.SetFocus 'so we dont see the Focus Rectangle
    'Show or hide the popup window
    If picPopup.Visible = False Then
        ShowPopUp
    Else
        HidePopUp
    End If
End SubPrivate Sub picPopup_Paint()
    Dim a As Integer
    Dim nRowHeight As Long

    'paint the color bands
    nRowHeight = Int(picPopup.ScaleHeight / 16)
    For a = 0 To 15
        picPopup.Line (Screen.TwipsPerPixelX, (a * nRowHeight) + Screen.TwipsPerPixelY)-(picPopup.ScaleWidth - (2 * Screen.TwipsPerPixelX), ((a + 1) * nRowHeight) - Screen.TwipsPerPixelY), QBColor(0), B
        picPopup.Line (2 * Screen.TwipsPerPixelX, (a * nRowHeight) + (2 * Screen.TwipsPerPixelY))-(picPopup.ScaleWidth - (3 * Screen.TwipsPerPixelX), ((a + 1) * nRowHeight) - (2 * Screen.TwipsPerPixelY)), QBColor(a), BF
    Next a

End SubPrivate Sub picSelection_Click()
    'Fire the click event
    cmdPopup_Click
End SubPrivate Sub picSelection_GotFocus()
    picSelection_Paint
End SubPrivate Sub picSelection_LostFocus()
    picSelection_Paint
End SubPrivate Sub picSelection_Paint()
    'Draw a focus rectangle
    Dim rct As RECT

    If GetFocus = picSelection.hwnd And picPopup.Visible = False Then
        GetClientRect picSelection.hwnd, rct
        With rct
            .Left = .Left + 1
            .Right = .Right - 1
            .Top = .Top + 1
            .Bottom = .Bottom - 1
        End With
        DrawFocusRect picSelection.hdc, rct
    Else
        picSelection.Cls
    End If
    'Paint the interior with the selected color
    picSelection.Line (2 * Screen.TwipsPerPixelX, 2 * Screen.TwipsPerPixelY)-(picSelection.ScaleWidth - (3 * Screen.TwipsPerPixelX), picSelection.ScaleHeight - (3 * Screen.TwipsPerPixelY)), QBColor(m_SelectedColor), BF

End SubPrivate Sub UserControl_ExitFocus()
    'Although in most circumstances the popup window will have already been
    'hidden before this, we check here just in case.
    If picPopup.Visible Then HidePopUp
End Sub

Private Sub UserControl_Initialize()
    'Set the parent and window style for the popup picturebox
    'set style to Toolwindow so after we've set parent to the Desktop
    'the popup doesn't show in the Taskbar
    SetWindowLong picPopup.hwnd, GWL_EXSTYLE, WS_EX_TOOLWINDOW
    SetParent picPopup.hwnd, 0
End SubPrivate Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
    'Keypreview is set, so we get all of the keypresses here first.
    'Check for keypresses which should cause the popup to show/hide
    'Alt and either the up or down arrow toggle the show state of the popup
    If (KeyCode = vbKeyUp Or KeyCode = vbKeyDown) And (Shift = 4) Then
        cmdPopup_Click
    ElseIf KeyCode = vbKeyDown And m_SelectedColor < 15 Then
        m_SelectedColor = m_SelectedColor + 1
        picSelection_Paint
        RaiseEvent Click
    ElseIf KeyCode = vbKeyUp And m_SelectedColor > 0 Then
        m_SelectedColor = m_SelectedColor - 1
        picSelection_Paint
        RaiseEvent Click
    End If
End SubPrivate Sub UserControl_Resize()
    'Position the constituent controls
    cmdPopup.Move UserControl.ScaleWidth - cmdPopup.Width, 0, cmdPopup.Width, UserControl.ScaleHeight
    picSelection.Move 0, 0, UserControl.ScaleWidth - (cmdPopup.Width + Screen.TwipsPerPixelX), UserControl.ScaleHeight
    picPopup.Width = UserControl.Extender.Width
End SubPrivate Sub HidePopUp()    'This procedure is called whenever the popup window needs to be hidden.
    If GetCapture = picPopup.hwnd Then
        ReleaseCapture
    End If
    picPopup.Visible = False
    DoEvents
    picSelection_Paint

End SubPrivate Sub ShowPopUp()    'This procedure is called whenever the popup needs to be shown.

    Dim ileft As Long
    Dim iTop As Long
    Dim ctlRect As RECT

    'Determine position for pop up window
    'We want to show the popup below the control, but if we can't we'll show it above
    GetWindowRect UserControl.hwnd, ctlRect 'screen rectange of the control
    If ctlRect.Bottom + (picPopup.Height / Screen.TwipsPerPixelX) > Screen.Height / Screen.TwipsPerPixelY Then
        'put it above
        iTop = (ctlRect.Top - (picPopup.Height / Screen.TwipsPerPixelY)) * Screen.TwipsPerPixelY
    Else
        'put it below
        iTop = ctlRect.Bottom * Screen.TwipsPerPixelY
    End If
    'If the popup window is as wide as, or wider than the control, we want to align
    'it to the left edge of the control.  Otherwise, we align it to the right.  If
    'we're too far to the right, we push it back left.
    If (ctlRect.Right - ctlRect.Left) > picPopup.Width / Screen.TwipsPerPixelX Then
        'try to align to the right of the control
        If ctlRect.Right > Screen.Width / Screen.TwipsPerPixelX Then
            ileft = Screen.Width - picPopup.Width
        Else
            ileft = ctlRect.Right * Screen.TwipsPerPixelX - picPopup.Width
        End If
        'Check we haven't gone outside the left edge of the screen
        If ileft < 0 Then ileft = 0
    Else
        'try to align to the left
        If ctlRect.Left < 0 Then
            ileft = 0
        Else
            ileft = ctlRect.Left * Screen.TwipsPerPixelX
        End If
        'Check we haven't gone outside the left edge of the screen
        If ileft + picPopup.Width > Screen.Width Then ileft = Screen.Width - picPopup.Width
    End If

    With picPopup
        .Top = iTop
        .Left = ileft
        .Visible = True
        .ZOrder
    End With
    picPopup_Paint
    DoEvents
    picSelection_Paint
    'Capture the mouse so we get all subsequent mouse clicks
    SetCapture picPopup.hwnd

End SubPrivate Sub picPopUp_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)

    'We've set capture to the popup window, so here we check for mouse presses
    'and if the user clicks outside of the popup, we call the HidePopUp routine
    'to validate and dismiss the popup window.
    If x < 0 Or x > picPopup.Width Or y < 0 Or y > picPopup.Height Then
        'user has clicked outside the popup so hide it
        HidePopUp
    ElseIf Button = vbLeftButton Then
        'Calculate the row
        m_SelectedColor = Int(y / (picPopup.ScaleHeight / 16))
        'update the display
        picSelection_Paint
        HidePopUp
        RaiseEvent Click
    Else
        'nothing to do
    End IfEnd SubPrivate Sub UserControl_Show()
    'Get the tooltip
    picSelection.ToolTipText = UserControl.Extender.ToolTipText
End SubPublic Property Let SelectedColor(New_SelectedColor As Integer)
    If New_SelectedColor >= 0 And New_SelectedColor < 16 Then
        m_SelectedColor = New_SelectedColor
        picSelection_Paint
    End If
End PropertyPublic Property Get SelectedColor() As Integer
    SelectedColor = m_SelectedColor
End Property

'用VB实现颜色选择Private Type CHOOSECOLOR
    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 TypePrivate Declare Function CHOOSECOLOR Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As CHOOSECOLOR) As Long
Dim CustomColors() As BytePrivate Sub Command1_Click()
    Dim NewColor As Long
    NewColor = ShowColor
    If NewColor <> -1 Then
        Me.BackColor = NewColor
    Else
        MsgBox "你选择取消"
    End If
End SubPrivate Sub Form_Load()
    ReDim CustomColors(0 To 16 * 4 - 1) As Byte
    Dim i As Integer
    For i = LBound(CustomColors) To UBound(CustomColors)
        CustomColors(i) = 0
    Next i
     Command1.Caption = "选择颜色"
End Sub
Private Function ShowColor() As Long
    Dim cc As CHOOSECOLOR
    Dim Custcolor(16) As Long
    Dim lReturn As Long    cc.lStructSize = Len(cc)
    cc.hwndOwner = Me.hWnd
    cc.hInstance = App.hInstance
    cc.lpCustColors = StrConv(CustomColors, vbUnicode)
    cc.flags = 0    If CHOOSECOLOR(cc) <> 0 Then
        ShowColor = cc.rgbResult
        CustomColors = StrConv(cc.lpCustColors, vbFromUnicode)
    Else
        ShowColor = -1
    End If
End Function

调试易

急！！颜色选择的控件

解决方案 »

急！！ 颜色选择的控件

解决方案 »

急！！颜色选择的控件