VB6 下拉列表选色今天 19:19
先上图，如果觉得颜色不要看，可以 安装免费插件 换成其它颜色（256*256*256=16777216种）的其中一种。
新建 Form1.frm，用记事本打开：
VERSION 5.00
Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 4440
ClientLeft = 60
ClientTop = 450
ClientWidth = 7110
LinkTopic = "Form1"
ScaleHeight = 296
ScaleMode = 3 'Pixel
ScaleWidth = 474
StartUpPosition = 2 '屏幕中心
Begin VB.PictureBox p2
Height = 420
Left = 3600
ScaleHeight = 360
ScaleWidth = 2880
TabIndex = 3
Top = 300
Width = 2940
End
Begin VB.PictureBox p1
Height = 420
Left = 405
ScaleHeight = 360
ScaleWidth = 2340
TabIndex = 2
Top = 255
Width = 2400
End
Begin VB.Label l1
Caption = "Label1"
Height = 3075
Left = 3705
TabIndex = 1
Top = 930
Width = 2805
End
Begin VB.Label l
Caption = "Label1"
Height = 3075
Left = 375
TabIndex = 0
Top = 885
Width = 2805
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim WithEvents ccBox1 As ColorCombox
Attribute ccBox1.VB_VarHelpID = -1
Dim WithEvents ccBox2 As ColorCombox
Attribute ccBox2.VB_VarHelpID = -1
Private Sub ccBox1_ItemClick(ByVal RGBColor&)
p1.BackColor = RGBColor
End Sub
Private Sub ccBox2_ItemClick(ByVal RGBColor&)
p2.BackColor = RGBColor
End Sub
Private Sub Form_Load()
Set ccBox1 = New ColorCombox
Set ccBox2 = New ColorCombox
ccBox1.CreateColorComboBox hWnd, l.Left, l.Top, l.Width, 9527&
ccBox1.ColorSelected = vbRed
ccBox2.CreateColorComboBox hWnd, l1.Left, l1.Top, l1.Width, ccBox1.ID + 1
ccBox2.ColorSelected = vbGreen
End Sub新建 ColorCombox.cls ，代码：
Option Explicit
Private Type VasmColorComBoxConst
ColorHDC As Long
ColorName As String
ColorRGB As Long
End Type
Private Type ThisClassSet
DefaultColor(0 To 17) As VasmColorComBoxConst
n_hWnd As Long
n_DefaultProc As Long
n_CID As Long
n_hBurshNor As Long
n_hBurshSel As Long
End Type
Dim PG As ThisClassSet
Dim LinkProc&()
Event ItemClick(ByVal RGBColor As Long)
Private Sub MsgHook(Result&, ByVal cHwnd&, ByVal Message&, ByVal wParam&, ByVal lParam&)
Dim Dit As DRAWITEMSTRUCT
Dim i&
Dim txtColor&
Dim hBrush&
Dim Rct As RECT
If (Message = WM_DRAWITEM) And (wParam = PG.n_CID) Then
CopyMemory Dit, ByVal lParam&, LenB(Dit)
If Dit.itemID = -1 Then Exit Sub
i = ((Dit.rcItem.bottom - Dit.rcItem.Top - 12) \ 2) + Dit.rcItem.Top
Select Case Dit.itemState
Case 1, 16, 17, 4113: hBrush = PG.n_hBurshSel: txtColor = GetSysColor(COLOR_HIGHLIGHTTEXT)
Case Else: hBrush = PG.n_hBurshNor: txtColor = 0
End Select
' Debug.Print Dit.itemID, Dit.itemState, Timer
SetBkMode Dit.hDC, 0&
FillRect Dit.hDC, Dit.rcItem, hBrush
BitBlt Dit.hDC, Dit.rcItem.Left + 2, i, 25, 12, PG.DefaultColor(Dit.itemID).ColorHDC, 0, 0, SRCCOPY
Dit.rcItem.Left = Dit.rcItem.Left + 30
SetTextColor Dit.hDC, txtColor&
DrawText Dit.hDC, PG.DefaultColor(Dit.itemID).ColorName, -1&, Dit.rcItem, DT_SINGLELINE Or DT_VCENTER
Exit Sub
End If
Result = CallWindowProc(ByVal PG.n_DefaultProc&, ByVal cHwnd, ByVal Message, ByVal wParam&, ByVal lParam&)
If Message = WM_COMMAND And lParam = PG.n_hWnd Then
i = ItemSelected
Dim ps As POINTS
CopyMemory ps, wParam&, 4&
If ps.y = CBN_SELCHANGE Then
If i = 1 Then
PG.DefaultColor(1).ColorRGB = UserGetColor(PG.n_hWnd, PG.DefaultColor(1).ColorRGB)
DrawColorLabel PG.DefaultColor(1).ColorHDC, PG.DefaultColor(1).ColorRGB
UpdateWindow cHwnd
End If
RaiseEvent ItemClick(PG.DefaultColor(i).ColorRGB)
End If
End If
End Sub
Function CreateColorComboBox(hWndParent As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, Optional ByVal cID As Long) As Long
'CBS_OWNERDRAWVARIABLE Or
Dim cHwnd&
cHwnd = CreateWindowEx(0&, "ComboBox", vbNullString, WS_CHILD Or WS_TABSTOP Or WS_VISIBLE Or WS_VSCROLL Or CBS_OWNERDRAWFIXED Or CBS_DROPDOWNLIST Or CBS_HASSTRINGS Or CBS_AUTOHSCROLL, X1, Y1, X2, 180&, hWndParent, cID&, App.hInstance, ByVal 0&)
If cHwnd Then
SendMessage cHwnd, WM_SETFONT, ByVal SendMessage(hWndParent, WM_GETFONT, ByVal 0&, ByVal 0&), ByVal 0&
Dim i&
For i = 17 To 0 Step -1
SendMessageStr cHwnd, CB_ADDSTRING, ByVal 0&, PG.DefaultColor(i).ColorName
Next
PG.n_CID = cID
PG.n_hWnd = cHwnd
PG.n_DefaultProc = SetWindowLong(hWndParent, ByVal GWL_WNDPROC, ByVal GetWndProcAddress(11))
ColorSelected = PG.DefaultColor(1).ColorRGB
End If
End Function
Public Property Get ItemSelected&()
ItemSelected = SendMessage(PG.n_hWnd, ByVal CB_GETCURSEL, ByVal 0&, ByVal 0&)
End Property
Public Property Let ItemSelected(ByVal vNewValue&)
SendMessage PG.n_hWnd, ByVal CB_SETCURSEL, ByVal vNewValue&, ByVal 0&
End Property
Public Property Get ColorSelected&()
Dim i&
i = SendMessage(PG.n_hWnd, ByVal CB_GETCURSEL, ByVal 0&, ByVal 0&)
ColorSelected = PG.DefaultColor(i).ColorRGB
End Property
Public Property Let ColorSelected(ByVal vNewValue&)
Dim i&
For i = 17 To 0 Step -1
If i ＜＞ 1 Then If PG.DefaultColor(i).ColorRGB = vNewValue Then GoTo l1
Next
i = 1
l1:
If i = 1 Then DrawColorLabel PG.DefaultColor(1).ColorHDC, vNewValue: i = 1: PG.DefaultColor(1).ColorRGB = vNewValue
SendMessage PG.n_hWnd, ByVal CB_SETCURSEL, ByVal i&, ByVal 0&
End Property
Public Property Get ColorCustom&()
ColorCustom = PG.DefaultColor(1).ColorRGB
End Property
Public Property Let ColorCustom(ByVal vNewValue&)
PG.DefaultColor(1).ColorRGB = vNewValue
DrawColorLabel PG.DefaultColor(1).ColorHDC, vNewValue
End Property
Public Property Get ID&()
ID = PG.n_CID
End Property
Public Property Get ColorDefault&()
ColorCustom = PG.DefaultColor(0).ColorRGB
End Property
Public Property Let ColorDefault(ByVal vNewValue&)
PG.DefaultColor(0).ColorRGB = vNewValue
DrawColorLabel PG.DefaultColor(0).ColorHDC, vNewValue
End Property
Private Sub DrawColorLabel(ColorHDC&, RGB_Color&)
Dim hBrush&, hBrush1&
Dim Rct As RECT
SetRect Rct, 0&, 0&, 25&, 12&
hBrush1 = CreateSolidBrush(0&)
hBrush = CreateSolidBrush(RGB_Color&)
FillRect ColorHDC, Rct, hBrush
FrameRect ColorHDC, Rct, hBrush1
DeleteObject hBrush
DeleteObject hBrush1
End Sub
Private Function UserGetColor(ByVal hwndOwner As Long, ByVal ColorInit As Long) As Long
Dim Tcc As TCHOOSECOLOR
Dim Colors(16) As Long
With Tcc
.hInstance = App.hInstance
.hwndOwner = hwndOwner
.lStructSize = LenB(Tcc)
.rgbResult = ColorInit
.flags = CC_RGBINIT Or CC_FULLOPEN
.lpCustColors = VarPtr(Colors(0))
End With
ChooseColor Tcc
UserGetColor = Tcc.rgbResult
End Function
Private Function GetWndProcAddress(ByVal SinceCount As Long) As Long
' 地址指针 ＝ GetWndProcAddress( 取第 N 个公共函数（属性） =或= 所有公共函数个数 + 第 N 个私有函数的函数地址）
Dim mePtr&
Dim jmpAddress&
mePtr = ObjPtr(Me)
CopyMemory jmpAddress, ByVal mePtr, 4
CopyMemory jmpAddress, ByVal jmpAddress + (SinceCount - 1) * 4 + &H1C, 4
ReDim LinkProc(10)
LinkProc(0) = &H83EC8B55
LinkProc(1) = &HFC8B14EC
LinkProc(2) = &H56FC758D
LinkProc(3) = &H3308758D
LinkProc(4) = &HFC04B1C9
LinkProc(5) = &HFF68A5F3
LinkProc(6) = &HB8FFFFFF
LinkProc(7) = &HFFFFFFFF
LinkProc(8) = &H48BD0FF
LinkProc(9) = &H10C2C924
CopyMemory ByVal VarPtr(LinkProc(5)) + 3, mePtr, 4
CopyMemory ByVal VarPtr(LinkProc(7)), jmpAddress, 4
GetWndProcAddress = VarPtr(LinkProc(0))
VirtualProtect ByVal VarPtr(LinkProc(0)), 44&, &H40, mePtr
End Function
Private Sub Class_Initialize()
PG.DefaultColor(2).ColorName = "黑色": PG.DefaultColor(2).ColorRGB = 0&
PG.DefaultColor(3).ColorName = "深红色": PG.DefaultColor(3).ColorRGB = &H80& ' &H800000
PG.DefaultColor(4).ColorName = "绿色": PG.DefaultColor(4).ColorRGB = &H8000&
PG.DefaultColor(5).ColorName = "橄榄色": PG.DefaultColor(5).ColorRGB = &H8080& '
PG.DefaultColor(6).ColorName = "藏青色": PG.DefaultColor(6).ColorRGB = &H800000 ' &H80&
PG.DefaultColor(7).ColorName = "紫色": PG.DefaultColor(7).ColorRGB = &H800080
PG.DefaultColor(8).ColorName = "绿蓝": PG.DefaultColor(8).ColorRGB = &H808000 '&H8080&
PG.DefaultColor(9).ColorName = "灰色": PG.DefaultColor(9).ColorRGB = &H808080
PG.DefaultColor(10).ColorName = "银白": PG.DefaultColor(10).ColorRGB = &HC0C0C0
PG.DefaultColor(11).ColorName = "红色": PG.DefaultColor(11).ColorRGB = &HFF&
PG.DefaultColor(12).ColorName = "亮绿色": PG.DefaultColor(12).ColorRGB = &HFF00&
PG.DefaultColor(13).ColorName = "黄色": PG.DefaultColor(13).ColorRGB = &HFFFF&
PG.DefaultColor(14).ColorName = "蓝色": PG.DefaultColor(14).ColorRGB = &HFF0000
PG.DefaultColor(15).ColorName = "紫红色": PG.DefaultColor(15).ColorRGB = &HFF00FF
PG.DefaultColor(16).ColorName = "兰色": PG.DefaultColor(16).ColorRGB = &HFFFF00
PG.DefaultColor(17).ColorName = "白色": PG.DefaultColor(17).ColorRGB = &HFFFFFF
PG.DefaultColor(0).ColorName = "默认"
PG.DefaultColor(1).ColorName = "自定义"
Dim nHDC&, hBitmap&, hBursh&
Dim i&, Rct As RECT
Dim hBrush1&
nHDC = GetDC(0&)
SetRect Rct, 0&, 0&, 25&, 12&
hBrush1 = CreateSolidBrush(0&)
For i = 2 To 17
PG.DefaultColor(i).ColorHDC = CreateCompatibleDC(nHDC)
hBitmap = CreateCompatibleBitmap(nHDC, 25&, 12&)
SelectObject PG.DefaultColor(i).ColorHDC, hBitmap
DeleteObject hBitmap
hBursh = CreateSolidBrush(PG.DefaultColor(i).ColorRGB)
FillRect PG.DefaultColor(i).ColorHDC, Rct, hBursh
FrameRect PG.DefaultColor(i).ColorHDC, Rct, hBrush1
DeleteObject ByVal hBursh
Next
PG.DefaultColor(0).ColorHDC = CreateCompatibleDC(nHDC)
hBitmap = CreateCompatibleBitmap(nHDC, 25&, 12&)
SelectObject PG.DefaultColor(0).ColorHDC, hBitmap
DeleteObject hBitmap
PG.DefaultColor(1).ColorHDC = CreateCompatibleDC(nHDC)
hBitmap = CreateCompatibleBitmap(nHDC, 25&, 12&)
SelectObject PG.DefaultColor(1).ColorHDC, hBitmap
DeleteObject hBitmap
DeleteObject hBrush1
ReleaseDC 0&, nHDC
PG.n_hBurshNor = CreateSolidBrush(&HFFFFFF)
PG.n_hBurshSel = GetSysColorBrush(COLOR_HIGHLIGHT)
End Sub
Private Sub Class_Terminate()
DestroyWindow PG.n_hWnd
SetWindowLong PG.n_hWnd, GWL_WNDPROC, PG.n_DefaultProc
DeleteObject PG.n_hBurshNor
DeleteObject PG.n_hBurshSel
Dim i&
For i = 17 To 0 Step -1
DeleteDC PG.DefaultColor(i).ColorHDC
Next
End Sub
全部回复（0）