Bonjour a tous

Quelqu'un peut me dire dans un 1^er temps si il y a un inconvénient à utiliser cette méthode pour mettre une couleur de fond sur un contrôle slider ?
Et si il est possible de gérer cet événement si le contrôle est placé sur une picturebox ?

dans un module :

Option Explicit

Public defWindowProc As Long
Public hSliderHwnd As Long
Private hSliderBGBrush As Long

Private Const WM_USER = &H400&
Private Const TBM_GETTOOLTIPS = (WM_USER + 30)
Private Const TTM_ACTIVATE = (WM_USER + 1)

Private Const GWL_WNDPROC As Long = (-4)
Private Const WM_GETMINMAXINFO As Long = &H24
Private Const WM_TIMECHANGE = &H1E
Private Const WM_DESTROY = &H2

Private Const WM_CTLCOLORSTATIC = &H138

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 CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam 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 Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Public Sub CreateSliderBrush(clrref As Long, bReset As Boolean)
   If (hSliderBGBrush <> 0) Or (bReset = True) Then
      Call DeleteSliderBrush
   End If
  
   If hSliderBGBrush = 0 Then
      hSliderBGBrush = CreateSolidBrush(clrref)
   End If
End Sub

Public Sub DeleteSliderBrush()
   If (hSliderBGBrush <> 0) Then
      DeleteObject hSliderBGBrush
      hSliderBGBrush = 0
   End If
End Sub

Public Function Slider_ActivateToolTips(hwndSlider As Long, bEnabled As Boolean) As Long
    Dim hToolTips As Long
        hToolTips = SendMessage(hwndSlider, TBM_GETTOOLTIPS, ByVal 0&, ByVal 0&)
  
    If hToolTips <> 0 Then
         Slider_ActivateToolTips = SendMessage(hToolTips, TTM_ACTIVATE, ByVal Abs(bEnabled), ByVal 0&)
    End If
End Function

Public Sub SubClass(hWnd As Long)
    On Error Resume Next
        defWindowProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub

Public Sub UnSubClass(hWnd As Long)
   If defWindowProc Then
      SetWindowLong hWnd, GWL_WNDPROC, defWindowProc
      defWindowProc = 0
   End If
End Sub

Public Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
   Select Case hWnd
      Case Form1.hWnd
         Select Case uMsg
            Case WM_CTLCOLORSTATIC
                If (lParam = hSliderHwnd) And (hSliderBGBrush <> 0) Then
                  WindowProc = hSliderBGBrush
                  Exit Function
                Else
                  WindowProc = CallWindowProc(defWindowProc, hWnd, uMsg, wParam, lParam)
                  Exit Function
                End If
            Case WM_DESTROY
               If (hSliderBGBrush <> 0) Then
                  Call DeleteSliderBrush
                  hSliderBGBrush = 0
               End If
                  Call UnSubClass(hWnd)
            Case Else
               WindowProc = CallWindowProc(defWindowProc, hWnd, uMsg, wParam, lParam)
               Exit Function
          End Select
            Case Else
                WindowProc = CallWindowProc(defWindowProc, hWnd, uMsg, wParam, lParam)
          End Select
End Function

dans un form :

- 1 Slider: Slider1
- 1 checkbox: Check1

Option Explicit

Private Sub Form_Load()
    CreateSliderBrush RGB(255, 255, 255), False
    hSliderHwnd = Slider1.hWnd
    Call SubClass(Me.hWnd)
    Check1.Value = vbChecked
End Sub

Private Sub Form_Unload(Cancel As Integer)
   If defWindowProc <> 0 Then
      Call UnSubClass(Me.hWnd)
   End If
     Call DeleteSliderBrush
End Sub

Private Sub Check1_Click()
    Slider_ActivateToolTips Slider1.hWnd, (Check1.Value = vbChecked)
End Sub

Merci
Léo

Merci Exploreur

Autre question :
Disons que j'ai un groupe de 10 slider.
Je devrais gérer de cette façon :

Option Explicit

Dim i As Long

Private Sub Form_Load()
    CreateSliderBrush RGB(255, 255, 255), False
For i = 0 To 9
    hSliderHwnd = Slider1(i).hWnd

Next
    Call SubClass(Me.hWnd)
    Check1.Value = vbChecked
End Sub

Private Sub Form_Unload(Cancel As Integer)
   If defWindowProc <> 0 Then
      Call UnSubClass(Me.hWnd)
   End If
     Call DeleteSliderBrush
End Sub

Private Sub Check1_Click()
For i = 0 To 9
    Slider_ActivateToolTips Slider1(i).hWnd, (Check1.Value = vbChecked)
Next
End Sub

Quelqu'un sait pourquoi je n'ai qu'un contrôle qui prend la couleur de fond ?

Merci
Léo

Cela est il possible ?

Ou je fait erreur dans mon code ?

A+
Exploreur

 Linux a un noyau, Windows un pépin

A+
Exploreur

 Linux a un noyau, Windows un pépin