هل يمكن تغيير لون الخط داخل الommand

السلام عليكم

هذه الامكانية متاحة في الفيجوال بيسك دوت نت ولكن في الفيجوال 6 غير متاحة

شكرا لك ياأخي وزادك علماً....

اهلا بك اخي العزيز

تفضل الكود التالي يمكنك من عمل هذا الأمر ، :

في وحده نمطيه Module ضع هذا الكود :

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

أخيرا إذهب إلى كود نافذة النموذج ويفضل الحدث Load وأكتب كما بالكود التالي :

RegisterButton Command1, vbRed

حيث :

Command1 الزر

vbRed اللون الذي تريد

تحياتي لك اخي العزيز