codice:
Option Explicit
Private colButtons As New Collection
Private Const KeyConst As String = "K"
Private Const PROP_COLOR As String = "SMDColor"
Private Const PROP_HWNDPARENT As String = "SMDhWndParent"
Private Const PROP_LPWNDPROC As String = "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.dll" 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.dll" (ByVal hWnd As Long) As Long
Private Declare Function GetProp Lib "User32.dll" Alias "GetPropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
Private Declare Function GetTextExtentPoint32 Lib "Gdi32.dll" 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.dll" Alias "RemovePropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
Private Declare Function SetProp Lib "User32.dll" Alias "SetPropA" (ByVal hWnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function SetTextColor Lib "Gdi32.dll" (ByVal hDC As Long, ByVal crColor As Long) As Long
Private Declare Function SetWindowLong Lib "User32.dll" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function TextOut Lib "Gdi32.dll" 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 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
If uMsg = WM_DRAWITEM Then
'Per trovare il bottone, cerca un riferimento all'elemento nella "Collection".
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
Private Function FindButton(sKey As String) As Boolean
Dim cmdButton As CommandButton
On Error Resume Next
Set cmdButton = 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 cmdButton As CommandButton
Dim bRC As Boolean
Dim lRC As Long, x As Long, y As Long, lpWndProC As Long, lButtonWidth As Long, lButtonHeight As Long, lPrevColor As Long, lColor As Long
Dim TextSize As Size
Dim sCaption As String
Const PushOffset = 2
Set cmdButton = colButtons.Item(sKey)
sCaption = cmdButton.Caption
lColor = GetProp(cmdButton.hWnd, PROP_COLOR)
lPrevColor = SetTextColor(lParam.hDC, lColor)
lRC = GetTextExtentPoint32(lParam.hDC, sCaption, Len(sCaption), TextSize)
lButtonHeight = lParam.rcItem.Bottom - lParam.rcItem.Top
lButtonWidth = lParam.rcItem.Right - lParam.rcItem.Left
'Se il bottone è premuto, modifica il testo in modo da simulare la pressione.
If lParam.itemAction = ODA_SELECT And lParam.itemState = ODS_BUTTONDOWN Then
cmdButton.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
lpWndProC = GetProp(hWnd, PROP_LPWNDPROC)
'Elabora il messaggio.
ProcessButton = CallWindowProc(lpWndProC, hWnd, uMsg, wParam, lParam)
'Scrive la caption del bottone.
bRC = TextOut(lParam.hDC, x, y, sCaption, Len(sCaption))
lRC = SetTextColor(lParam.hDC, lPrevColor)
Set cmdButton = 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
'Disattiva il subclassing del form.
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
Public Function RegisterButton(Button As CommandButton, Forecolor As Long) As Boolean
Dim hWndParent As Long
Dim lpWndProC As Long
Dim sButtonKey As String
'Crea il valore "colButtons".
sButtonKey = GetKey(Button.hWnd)
'Se si conoscono già le proprietà del bottone, si limita a cambiare il colore del testo, altrimenti esegue tutta la procedura.
If FindButton(sButtonKey) Then
SetProp Button.hWnd, PROP_COLOR, Forecolor
Button.Refresh
Else
'Recupera l'handle del form che possiende il bottone.
hWndParent = GetParent(Button.hWnd)
'Se non riesce a recuperare l'handle, esce.
If (hWndParent = 0) Then
RegisterButton = False
Exit Function
End If
'Il form proprietario è stato trovato.
colButtons.Add Button, sButtonKey
SetProp Button.hWnd, PROP_COLOR, Forecolor
SetProp Button.hWnd, PROP_HWNDPARENT, hWndParent
'Controlla se il form è già stato subclassato.
lpWndProC = GetProp(hWndParent, PROP_LPWNDPROC)
If lpWndProC = 0 Then
'E' un nuovo form; lo subclassa ed aggiunge l'indirizzo della "Windows procedure" alla "Collection".
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
Nel form inserisci:
Permessi di invio
Rispondi quotando