20-08-24, 08:21 PM (آخر تعديل لهذه المشاركة : 20-08-24, 08:39 PM {2} بواسطة Taha Okla.)
خاصية اللون لخط أي أداة بالعادة تكون (ForeColor) فإن لم توجد ، فيعني أنه لا يمكن استخدامها ..
الأفضل أن لا تعتمد على أدوات خارجية غير الأدوات القياسية .. فإن كان لابد .. فـ في المرفقات أداة زر إحترافية .. فيك تغير شكلها لأكثر من نمط وكلذلك لون الخط. اعتمدت عليها كثيرا في مشاريعي الأولى .. قبل أن أرجع للفكر القديم بأن لا أعتمد على أي أدوات خارجية ..
أو طريقة من خلال الكود (فيك تغير ألوان خطوط الأزارا):
أفتح مودل جديد (Module1) وضع في الكود التالي :
كود :
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 Const VER_PLATFORM_WIN32_NT As Long = 2
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 Type OSVERSIONINFO
OSVSize As Long
dwVerMajor As Long
dwVerMinor As Long
dwBuildNumber As Long
PlatformID As Long
szCSDVersion As String * 128
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 Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" _
(lpVersionInformation As Any) As Long
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
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 cmdButton = colButtons.Item(sKey)
sCaption = cmdButton.Caption
'the button is pressed! Offset the text
'so it looks like the button is pushed
If ((lParam.itemState And ODS_BUTTONDOWN) = ODS_BUTTONDOWN) Then
cmdButton.SetFocus
DoEvents 'unneeded on XP - could use If Not IsWinXPPlus() Then 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 WndProc address
lpWndProC = GetProp(hWnd, PROP_LPWNDPROC)
'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 cmdButton = Nothing
End Function
Private Sub RemoveForm(hWndParent As Long)
Dim hWndButton As Long
Dim cnt As Integer
UnsubclassForm hWndParent
On Error GoTo RemoveForm_Exit
For cnt = colButtons.Count - 1 To 0 Step -1
hWndButton = colButtons(cnt).hWnd
If GetProp(hWndButton, PROP_HWNDPARENT) = hWndParent Then
RemoveProp hWndButton, PROP_COLOR
RemoveProp hWndButton, PROP_HWNDPARENT
colButtons.Remove cnt
End If
Next cnt
RemoveForm_Exit:
End Sub
Private Function UnsubclassForm(hWnd As Long) As Boolean
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)
'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
Private Sub Form_Load()
RegisterButton Command1, &H80C0FF ' أي زر تريد تغيير لونه أكتبه بهذه الطريقة إما رقم اللون
RegisterButton Command2, vbBlue ' أو اسم اللون
' لكن في البداية عليك الذهاب إلى خصائص الزر وتغيير خاصية
' Style = 1 - Graphical
