颜色下拉组合框。拉不下来
为什么用WINDOS API添加的颜色下拉组合框。拉不下来，在VB中就可以。用到EXCEL就不可以了.请高手指点。原代码http://www.excelpx.com/thread-292328-1-1.html
*****类模块代码********************************************
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() As Long
Event ItemClick(ByVal RGBColor As Long)
Private Sub MsgHook(Result As Long, ByVal cHwnd As Long, ByVal Message As Long, ByVal wParam As Long, ByVal lParam As Long)
Dim Dit As DRAWITEMSTRUCT
Dim i As Long
Dim txtColor As Long
Dim hBrush As Long
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, 12, 12, PG.DefaultColor(Dit.itemID).ColorHDC, 0, 0, SRCCOPY
'BitBlt Dit.hDC, Dit.rcItem.Left + 2, i, 25, 12, PG.DefaultColor(Dit.itemID).ColorHDC, 0, 0, SRCCOPY
Dit.rcItem.Left = Dit.rcItem.Left + 20
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 As Long
cHwnd = CreateWindowEx(0, "ComboBox", vbNullString, WS_CHILD Or WS_GROUP 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, 0, ByVal 0)
If cHwnd Then
SendMessage cHwnd, WM_SETFONT, ByVal SendMessage(hWndParent, WM_GETFONT, ByVal 0&, ByVal 0&), ByVal 0&
Dim i As Long
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() As Long
ItemSelected = SendMessage(PG.n_hWnd, ByVal CB_GETCURSEL, ByVal 0, ByVal 0)
End Property
Public Property Let ItemSelected(ByVal vnewvalue As Long)
SendMessage PG.n_hWnd, ByVal CB_SETCURSEL, ByVal vnewvalue&, ByVal 0&
End Property
Public Property Get ColorSelected() As Long
Dim i As Long
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 As Long)
Dim i As Long
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() As Long
ColorCustom = PG.DefaultColor(1).ColorRGB
End Property
Public Property Let ColorCustom(ByVal vnewvalue As Long)
PG.DefaultColor(1).ColorRGB = vnewvalue
DrawColorLabel PG.DefaultColor(1).ColorHDC, vnewvalue
End Property
Public Property Get ID() As Long
ID = PG.n_CID
End Property
Public Property Get ColorDefault() As Long
ColorCustom = PG.DefaultColor(0).ColorRGB
End Property
Public Property Let ColorDefault(ByVal vnewvalue As Long)
PG.DefaultColor(0).ColorRGB = vnewvalue
DrawColorLabel PG.DefaultColor(0).ColorHDC, vnewvalue
End Property
Private Sub DrawColorLabel(ColorHDC As Long, RGB_Color As Long)
Dim hBrush As Long, hBrush1 As Long
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
Dim mePtr As Long
Dim jmpAddress As Long
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(0).ColorName = "默认"
PG.DefaultColor(1).ColorName = "自定义"
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
Dim nHDC As Long, hBitmap As Long, hBursh As Long
Dim i As Long, Rct As RECT
Dim hBrush1 As Long
nHDC = GetDC(0&)
SetRect Rct, 0&, 0&, 12&, 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, 12&, 12&)
SelectObject PG.DefaultColor(0).ColorHDC, hBitmap
DeleteObject hBitmap
PG.DefaultColor(1).ColorHDC = CreateCompatibleDC(nHDC)
hBitmap = CreateCompatibleBitmap(nHDC, 12&, 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
*******FORM代码：****************************************************
Option Explicit
Public WithEvents ccBox1 As ColorCombox
Private Sub ccBox1_ItemClick(ByVal RGBColor As Long)
‘p1.BackColor = RGBColor
End Sub
Private Sub UserForm_Initialize()
Dim hWnd As Long
Set ccBox1 = New ColorCombox
'ccBox1.CreateColorComboBox hWnd, l.Left, l.Top, l.Width, 9527&
hWnd = FindWindow(vbNullString, Form.Caption)
ccBox1.CreateColorComboBox hWnd, 20, 35, 100
ccBox1.ColorSelected = vbRed
End Sub
--------------------编程问答-------------------- 人工帮顶,每天回帖即可获得10分可用分 --------------------编程问答-------------------- 这么多代码，错误的只有一两处，你编译都通过了吗？ --------------------编程问答-------------------- 那里有错误请指出。 --------------------编程问答-------------------- 版主帮帮忙啊 --------------------编程问答-------------------- 看出处 http://www.cnblogs.com/pctgl/articles/1834447.html --------------------编程问答-------------------- 确实。。。 api的声明一个都没添加，因为我用的win.tlb库... --------------------编程问答-------------------- 你好，谢谢。你写的这个很好用。我想用到EXCEL里做控件。你能不能帮我改改。能在EXCEL里使用。
补充：VB , VBA
