Option Explicit 'non-vb colours Const vbDarkRed = &H90& Const vbDarkBlue = &H900000 'consts for the Command1 button control array Const nDefault = 0 Const nRed = 1 Const nGreen = 2 Const nBlue = 3 Const nYellow = 4 Const nMagenta = 5 Const nCyan = 6 Const nWhite = 7 Const nDkRed = 8 Const nDkBlue = 9 Private Sub Command2_Click() Unload Me End Sub Private Sub Form_Load() 'create the coloured buttons RegisterButton Command1(nRed), vbRed RegisterButton Command1(nGreen), vbGreen RegisterButton Command1(nBlue), vbBlue RegisterButton Command1(nYellow), vbYellow RegisterButton Command1(nMagenta), vbMagenta RegisterButton Command1(nCyan), vbCyan RegisterButton Command1(nWhite), vbWhite RegisterButton Command1(nDkRed), vbDarkRed RegisterButton Command1(nDkBlue), vbDarkBlue 'set the default backcolour Option1(0).Value = True End Sub Private Sub Option1_Click(Index As Integer) Dim clrref As Long 'set the backcolour Select Case Index Case 0: clrref = vbButtonFace Case 1: clrref = vbApplicationWorkspace Case 2: clrref = vbBlack Case 3: clrref = vbWhite Case 4: clrref = vbRed Case 5: clrref = vbGreen Case 6: clrref = &H900000 Case 7: clrref = vbCyan Case 8: clrref = vbMagenta Case 9: clrref = vbYellow End Select Command1(nRed).BackColor = clrref Command1(nGreen).BackColor = clrref Command1(nBlue).BackColor = clrref Command1(nYellow).BackColor = clrref Command1(nMagenta).BackColor = clrref Command1(nCyan).BackColor = clrref Command1(nWhite).BackColor = clrref Command1(nDkRed).BackColor = clrref Command1(nDkBlue).BackColor = clrref End Sub ' En un Modulo Option Explicit Private colButtons As New Collection Private Const KeyConst = "K" Private Const PROP_COLOR = "SMDColor" Private Const PROP_HWNDPARENT = "SMDhWndParent" Private Const PROP_LPWNDPROC = "SMDlpWndProc" Private Const GWL_WNDPROC As Long = (-4) Private Const ODA_SELECT As Long = &H2 Private Const ODS_SELECTED As Long = &H1 Private Const ODS_FOCUS As Long = &H10 Private Const ODS_BUTTONDOWN As Long = ODS_FOCUS Or ODS_SELECTED Private Const WM_DESTROY As Long = &H2 Private Const WM_DRAWITEM As Long = &H2B Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Type SIZE cx As Long cy As Long End Type Private Type DRAWITEMSTRUCT CtlType As Long CtlID As Long itemID As Long itemAction As Long itemState As Long hWndItem As Long hDC As Long rcItem As RECT itemData As Long End Type Private Declare Function CallWindowProc Lib "user32" _ Alias "CallWindowProcA" _ (ByVal lpPrevWndFunc As Long, _ ByVal hWnd As Long, _ ByVal msg As Long, _ ByVal wParam As Long, _ lParam As DRAWITEMSTRUCT) As Long Private Declare Function GetParent Lib "user32" _ (ByVal hWnd As Long) As Long Private Declare Function GetProp Lib "user32" _ Alias "GetPropA" _ (ByVal hWnd As Long, _ ByVal lpString As String) As Long Private Declare Function GetTextExtentPoint32 Lib "gdi32" _ Alias "GetTextExtentPoint32A" _ (ByVal hDC As Long, _ ByVal lpSz As String, _ ByVal cbString As Long, _ lpSize As SIZE) As Long Private Declare Function RemoveProp Lib "user32" _ Alias "RemovePropA" _ (ByVal hWnd As Long, _ ByVal lpString As String) As Long Private Declare Function SetProp Lib "user32" _ Alias "SetPropA" _ (ByVal hWnd As Long, _ ByVal lpString As String, _ ByVal hData As Long) As Long Private Declare Function SetTextColor Lib "gdi32" _ (ByVal hDC As Long, _ ByVal crColor 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 TextOut Lib "gdi32" _ Alias "TextOutA" _ (ByVal hDC As Long, _ ByVal x As Long, _ ByVal y As Long, _ ByVal lpString As String, _ ByVal nCount As Long) As Long Private Function FindButton(sKey As String) As Boolean Dim Command1Button As CommandButton On Error Resume Next Set Command1Button = colButtons.Item(sKey) FindButton = (Err.Number = 0) End Function Private Function GetKey(hWnd As Long) As String GetKey = KeyConst & hWnd End Function Private Function ProcessButton(ByVal hWnd As Long, _ ByVal uMsg As Long, _ ByVal wParam As Long, _ lParam As DRAWITEMSTRUCT, _ sKey As String) As Long Dim Command1Button As CommandButton Dim bRC As Boolean Dim lRC As Long Dim x As Long Dim y As Long Dim lpWndProC As Long Dim lButtonWidth As Long Dim lButtonHeight As Long Dim lPrevColor As Long Dim lColor As Long Dim TextSize As SIZE Dim sCaption As String Const PushOffset = 2 Set Command1Button = colButtons.Item(sKey) sCaption = Command1Button.Caption lColor = GetProp(Command1Button.hWnd, PROP_COLOR) lPrevColor = SetTextColor(lParam.hDC, lColor) 'In Pixels/Logical Units lRC = GetTextExtentPoint32(lParam.hDC, _ sCaption, Len(sCaption), TextSize) 'In Pixels/Logical Units lButtonHeight = lParam.rcItem.Bottom - lParam.rcItem.Top lButtonWidth = lParam.rcItem.Right - lParam.rcItem.Left 'The button is pressed! Offset the text 'so it looks like the button is pushed If (lParam.itemAction = ODA_SELECT) And _ (lParam.itemState = ODS_BUTTONDOWN) Then Command1Button.SetFocus DoEvents x = (lButtonWidth - TextSize.cx + PushOffset) \ 2 y = (lButtonHeight - TextSize.cy + PushOffset) \ 2 Else x = (lButtonWidth - TextSize.cx) \ 2 y = (lButtonHeight - TextSize.cy) \ 2 End If 'Get the default WndProd address lpWndProC = GetProp(hWnd, PROP_LPWNDPROC) 'Do the default button processing ProcessButton = CallWindowProc(lpWndProC, hWnd, uMsg, wParam, lParam) 'Put our text on the button bRC = TextOut(lParam.hDC, x, y, sCaption, Len(sCaption)) 'Restore the device context to the original color lRC = SetTextColor(lParam.hDC, lPrevColor) ProcessButton_Exit: Set Command1Button = Nothing End Function Private Sub RemoveForm(hWndParent As Long) Dim hWndButton As Long Dim i As Integer UnsubclassForm hWndParent On Error GoTo RemoveForm_Exit For i = colButtons.Count - 1 To 0 Step -1 hWndButton = colButtons(i).hWnd If GetProp(hWndButton, PROP_HWNDPARENT) = hWndParent Then RemoveProp hWndButton, PROP_COLOR RemoveProp hWndButton, PROP_HWNDPARENT colButtons.Remove i End If Next i RemoveForm_Exit: Exit Sub End Sub Private Function UnsubclassForm(hWnd As Long) As Boolean Dim lpWndProC As Long lpWndProC = GetProp(hWnd, PROP_LPWNDPROC) If lpWndProC = 0 Then UnsubclassForm = False Else Call SetWindowLong(hWnd, GWL_WNDPROC, lpWndProC) RemoveProp hWnd, PROP_LPWNDPROC UnsubclassForm = True End If End Function Private Function ButtonColorProc(ByVal hWnd As Long, _ ByVal uMsg As Long, _ ByVal wParam As Long, _ lParam As DRAWITEMSTRUCT) As Long Dim lpWndProC As Long Dim bProcessButton As Boolean Dim sButtonKey As String bProcessButton = False 'Assume default processing If (uMsg = WM_DRAWITEM) Then 'Do we have this button? To find out, just 'try to reference the item in the collection. 'If it's there, we own the button. If it's 'not there, we'll get an error. sButtonKey = GetKey(lParam.hWndItem) bProcessButton = FindButton(sButtonKey) End If If bProcessButton Then ProcessButton hWnd, uMsg, wParam, lParam, sButtonKey Else lpWndProC = GetProp(hWnd, PROP_LPWNDPROC) ButtonColorProc = CallWindowProc(lpWndProC, hWnd, uMsg, wParam, lParam) If uMsg = WM_DESTROY Then RemoveForm hWnd End If End Function Public Function RegisterButton(Button As CommandButton, _ Forecolor As Long) As Boolean Dim hWndParent As Long Dim lpWndProC As Long Dim sButtonKey As String 'Make the colButtons key for the button sButtonKey = GetKey(Button.hWnd) 'If we already own the button, just change the 'color otherwise we need to process the whole thing. If FindButton(sButtonKey) Then SetProp Button.hWnd, PROP_COLOR, Forecolor Button.Refresh Else 'Get the handle to the buttons parent form. hWndParent = GetParent(Button.hWnd) 'If we can't find a parent form, report a 'problem and get out. If (hWndParent = 0) Then RegisterButton = False Exit Function End If 'found the parent, gather all of the necessary 'button values and add it to the collection. colButtons.Add Button, sButtonKey SetProp Button.hWnd, PROP_COLOR, Forecolor SetProp Button.hWnd, PROP_HWNDPARENT, hWndParent 'Determine if we've already subclassed this form. lpWndProC = GetProp(hWndParent, PROP_LPWNDPROC) 'It's a new form. Subclass it and add the 'Window proc address to the collection. If (lpWndProC = 0) Then lpWndProC = SetWindowLong(hWndParent, _ GWL_WNDPROC, AddressOf ButtonColorProc) SetProp hWndParent, PROP_LPWNDPROC, lpWndProC End If End If RegisterButton = True End Function Public Function UnregisterButton(Button As CommandButton) As Boolean Dim hWndParent As Long Dim sKeyButton As String sKeyButton = GetKey(Button.hWnd) If (FindButton(sKeyButton) = False) Then UnregisterButton = False Exit Function End If hWndParent = GetProp(Button.hWnd, PROP_HWNDPARENT) UnregisterButton = UnsubclassForm(hWndParent) colButtons.Remove sKeyButton RemoveProp Button.hWnd, PROP_COLOR RemoveProp Button.hWnd, PROP_HWNDPARENT End Function