Как изменить цвет текста на кнопке?

[homA]

Извините,если было, скинте тогда линк, в поиске не нашёл....
Вот никак не изменить цвет текста на кнопке(((

[Konst_One]

Код: Выделить всё

'Dieser Source stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Project1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------

Option Explicit

Private Sub Form_Load()
  Call InitButton(Me, RGB(255, 0, 0), RGB(0, 0, 255))
End Sub

Private Sub Form_Unload(Cancel As Integer)
  Call ExitButton
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'--------- Anfang Modul "Module1" alias Module1.bas ---------

Option Explicit

Private Declare Function CreateWindowEx Lib "user32" Alias _
        "CreateWindowExA" (ByVal dwExStyle As Long, ByVal _
        lpClassName As String, ByVal lpWindowName As String, _
        ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, _
        ByVal nWidth As Long, ByVal nHeight As Long, ByVal _
        hwndParent As Long, ByVal hMenu As Long, ByVal hInstance _
        As Long, lpParam As Any) As Long

Private Declare Function DestroyWindow Lib "user32" (ByVal hWnd _
        As Long) As Long

Private Declare Function CallWindowProc Lib "user32" Alias _
        "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal _
        hWnd As Long, ByVal MSG As Long, ByVal wParam As _
        Long, ByVal lParam 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 SendMessage Lib "user32" Alias _
        "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
        ByVal wParam As Long, lParam As Any) As Long

Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" _
        (lpDest As Any, lpSource As Any, ByVal nCount As Long)
       
Private Declare Function DrawEdge Lib "user32" (ByVal hDC As Long, _
        qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) _
        As Long

Declare Function DrawFocusRect Lib "user32" (ByVal hDC As Long, _
        lpRect As RECT) As Long

Private Declare Function InflateRect Lib "user32" (lpRect As RECT, _
        ByVal X As Long, ByVal Y As Long) As Long

Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, _
        lpRect As RECT, ByVal hBrush As Long) As Long

Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, _
        ByVal X As Long, ByVal Y As Long) As Long

Private Declare Function DrawTextEx Lib "user32" Alias "DrawTextExA" _
        (ByVal hDC As Long, ByVal lpsz As String, ByVal n As Long, _
        lpRect As RECT, ByVal un As Long, lpDrawTextParams As Any) _
        As Long

Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal _
        crColor As Long) As Long

Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As _
        Long, ByVal hObject As Long) As Long
       
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject _
        As Long) As Long
   
Private Declare Function SetBkColor Lib "gdi32" (ByVal hDC As Long, _
        ByVal crColor As Long) As Long

Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, _
        ByVal crColor As Long) As Long
       
Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom 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 DRAWTEXTPARAMS
  cbSize As Long
  iTabLength As Long
  iLeftMargin As Long
  iRightMargin As Long
  uiLengthDrawn As Long
End Type

Const GWL_WNDPROC = (-4&)

Const WM_GETFONT = &H31
Const WM_DRAWITEM = &H2B
Const WM_COMMAND = &H111

Const WS_CHILD = &H40000000
Const WS_VISIBLE = &H10000000

Const ODS_FOCUS = &H10
Const ODS_SELECTED = &H1

Const BS_PUSHBUTTON = &H0&
Const BS_OWNERDRAW = &HB&

Const BF_LEFT = &H1
Const BF_TOP = &H2
Const BF_RIGHT = &H4
Const BF_BOTTOM = &H8
Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)

Const BDR_RAISEDOUTER = &H1
Const BDR_SUNKENOUTER = &H2
Const BDR_RAISEDINNER = &H4
Const BDR_SUNKENINNER = &H8
Const EDGE_SUNKEN = (BDR_SUNKENOUTER Or BDR_SUNKENINNER)
Const EDGE_RAISED = (BDR_RAISEDOUTER Or BDR_RAISEDINNER)

Const DT_CENTER = &H1
Const DT_VCENTER = &H4
Const DT_SINGLELINE = &H20

Private Type ODCBTYPE
  Forecolor As Long
  Backcolor As Long
  Caption As String
  Picture As PictureBox
  hWnd As Long
  Left As Long
  Top  As Long
  Width As Long
  Height As Long
  Parent As Form
End Type

Dim MyButton As ODCBTYPE

Dim PrevWndProc&

'Subclassing initieren
Private Sub SubClass(hWnd&)
  PrevWndProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WndProc)
End Sub

'Subclassing Auflösen
Private Sub UnSubClass(hWnd&)
  Call SetWindowLong(hWnd, GWL_WNDPROC, PrevWndProc)
End Sub

'Subclassing Routine des Forms für die ReDrawereignisse
Private Function WndProc(ByVal hWnd As Long, ByVal MSG As Long, _
                         ByVal wParam As Long, ByVal lParam As _
                         Long) As Long
               
  Select Case MSG
    Case WM_DRAWITEM: DrawButton (lParam)
                      WndProc = 1
    Case WM_COMMAND:
                      If lParam = MyButton.hWnd Then
                        MsgBox "Jepp"
                      End If
                      WndProc = 0
                     
    Case Else:        WndProc = CallWindowProc(PrevWndProc, _
                                               hWnd, MSG, _
                                               wParam, _
                                               lParam)
  End Select
End Function

'Erstellen des neuen Buttons
Public Sub InitButton(F As Form, BCol&, FCol&)
  Dim BStyle&
  Dim hFont As Long

    With MyButton
      Set .Parent = F
     
      .Top = 6
      .Left = 6
      .Width = 170
      .Height = 40
      .Forecolor = FCol
      .Backcolor = BCol
      .Caption = "MyCommandButton"
     
      BStyle = BS_PUSHBUTTON Or BS_OWNERDRAW Or _
               WS_CHILD Or WS_VISIBLE
      .hWnd = CreateWindowEx(0&, "BUTTON", vbNullString, BStyle, _
                             .Left, .Top, .Width, .Height, _
                             .Parent.hWnd, 0&, App.hInstance, _
                             ByVal 0&)
      Call SubClass(.Parent.hWnd)
    End With

End Sub

'Löschen des Buttons
Public Sub ExitButton()
  Call DestroyWindow(MyButton.hWnd)
  UnSubClass (MyButton.Parent.hWnd)
End Sub

'Zeichnen des Buttons
Public Sub DrawButton(lParam As Long)
  Dim DI As DRAWITEMSTRUCT, DTP As DRAWTEXTPARAMS, FR As RECT
  Dim FColor&, BColor&, hFont&, hMemFont&, hBrush
  Static GotFocus As Boolean
 
    Call CopyMemory(DI, ByVal lParam, Len(DI))
   
    With DI
      BColor = SetBkColor(.hDC, MyButton.Backcolor)
      hBrush = CreateSolidBrush(MyButton.Backcolor)
      FColor = SetTextColor(.hDC, MyButton.Forecolor)

      FR = .rcItem
      With FR
        .Left = .Left + 5
        .Top = .Top + 5
        .Right = .Right - 5
        .Bottom = .Bottom - 5
      End With
     
      If (.itemState And ODS_SELECTED) Then
        Call DrawEdge(.hDC, .rcItem, EDGE_SUNKEN, BF_RECT)
      Else
        Call DrawEdge(.hDC, .rcItem, EDGE_RAISED, BF_RECT)
      End If

      Call InflateRect(.rcItem, -2, -2)
      Call FillRect(.hDC, .rcItem, hBrush)
      If (.itemState And ODS_SELECTED) Then
        Call OffsetRect(.rcItem, 1&, 1&)
      End If
     
      hFont = SendMessage(MyButton.Parent.hWnd, _
                          WM_GETFONT, 0, ByVal 0&)
                         
      hMemFont = SelectObject(.hDC, hFont)
      DTP.cbSize = Len(DTP)
      Call DrawTextEx(.hDC, MyButton.Caption, Len(MyButton.Caption), _
                      .rcItem, DT_CENTER Or DT_VCENTER Or _
                      DT_SINGLELINE, DTP)

      If (.itemState And ODS_FOCUS) Then
        Call DrawFocusRect(.hDC, FR)
        GotFocus = True
      Else
        If GotFocus Then
          Call DrawFocusRect(.hDC, FR)
          GotFocus = False
        End If
      End If
 
      Call DeleteObject(hBrush)
      Call SetBkColor(.hDC, BColor)
      Call SetTextColor(.hDC, FColor)
      Call SelectObject(.hDC, hMemFont)
      Call DeleteObject(hFont)
    End With
   
    Call CopyMemory(ByVal lParam, DI, Len(DI))
End Sub
'---------- Ende Modul "Module1" alias Module1.bas ----------
'-------------- Ende Projektdatei Project1.vbp --------------

[Vellan]

А по моему проще кнопку свою написать.

[kirrun]

О, Боже! Неужели низя покороче???

[Amed]

Предложи способ короче...

[uhm]

Использовать VBA'шную кнопку, у нее есть свойство Forecolor
Вообще, судя по всему, доблестный майкрософт просто забыл объявить это свойство

[Sur]

Использовать чекбокс в графическом режиме.
Private Sub Check1_Click()
If Check1.Value = 0 Then
'код на клик
End If
Check1.Value = 0
End Sub

[kirrun]

Вот и нашелся способ покороче...
У чекбокса есть свойство ForeColor...

[Konst_One]

изъясняйтесь понятней, а то спрашивают про CommandButton, а оказывается все дело в волшебных пузырьках

[kirrun]

Хы... а графический чекбокс и отличается от коммандбуттона только названием, свойствами и событиями =) Программер привыкнет, а юзер и не заметит =)