Couleur de fond d'un contrôle slider

[Résolu]
Signaler
Messages postés
135
Date d'inscription
dimanche 19 novembre 2000
Statut
Membre
Dernière intervention
2 décembre 2011
-
Messages postés
135
Date d'inscription
dimanche 19 novembre 2000
Statut
Membre
Dernière intervention
2 décembre 2011
-
Bonjour a tous



Quelqu’un peut me dire dans un 1er 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 :




<?xml:namespace prefix o ns "urn:schemas-microsoft-com:office:office" /??>
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

9 réponses

Messages postés
4822
Date d'inscription
lundi 11 novembre 2002
Statut
Membre
Dernière intervention
15 novembre 2016
14
Salut,

Ben apparement, la méthode c'est du SubClassing....Puis en ce qui concerne le fonctionnement sile contrôle est placer dans une picturebox, cela doit-être faisable, je pense qu'il y a quelque chose à faire au niveau du hWnd, il faut envoyer le hwnd du conteneur..

A+
Exploreur

 Linux a un noyau, Windows un pépin

 
Messages postés
13280
Date d'inscription
lundi 13 décembre 2004
Statut
Modérateur
Dernière intervention
3 février 2018
46
salut,

faut vraiment que tu lises ce que tu copies!!!!

dans ta boucle tu stoques la valeur du handle. beh ouai mais en boucle forcément c'est uniquement le dernier
donc faut tous les stoquer (tableau) et faire le test dans ta windowproc

'FORM
Option Explicit

Dim i As Long

Private Sub Form_Load()
    CreateSliderBrush RGB(255, 255, 255),
False
    For i = 0 To 9
        hSliderHwnd(i) = Slider1(i).hWnd
    Next
    Call SubClass(Me.hWnd)
    Check1.Value = vbChecked
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Call UnSubClass
    Call DeleteSliderBrush
End Sub

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

'MODULE
Option Explicit

Private Const WM_USER           As Long = &H400&
Private Const TBM_GETTOOLTIPS   As Long = (WM_USER + 30)
Private Const TTM_ACTIVATE      As Long = (WM_USER + 1)
Private Const GWL_WNDPROC       As Long = (-4)
Private Const WM_GETMINMAXINFO  As Long = &H24
Private Const WM_TIMECHANGE     As Long = &H1E
Private Const WM_DESTROY        As Long = &H2
Private Const WM_CTLCOLORSTATIC As Long = &H138

Dim lFrmHwnd                    As Long
Dim defWindowProc               As Long
Public hSliderHwnd(9)           As Long
Dim hSliderBGBrush              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 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
   If hSliderBGBrush = 0 Then hSliderBGBrush =
CreateSolidBrush(clrref)
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
    lFrmHwnd = hWnd
    defWindowProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub

Public Sub UnSubClass
   If defWindowProc > 0 Then
      SetWindowLong lFrmHwnd, GWL_WNDPROC, defWindowProc
      defWindowProc = 0
      Erase hSliderHwnd
   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
    If hWnd = lFrmHwnd Then
        Select Case uMsg
            Case WM_CTLCOLORSTATIC
                If (IsOneSlide(lParam)) And (hSliderBGBrush <>
0) Then
                    WindowProc = hSliderBGBrush
                Else
                    WindowProc = CallWindowProc(defWindowProc, hWnd, uMsg, wParam,
lParam)
                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)
        End Select
    Else
        WindowProc = CallWindowProc(defWindowProc, hWnd, uMsg, wParam,
lParam)
    End If
End Function

Private Function IsOneSlide(lParam As Long) As Boolean
    IsOneSlide = False
    Dim i As Integer
    For i = 0 To 9
        If lParam = hSliderHwnd(i) Then IsOneSlide = True: Exit
For
    Next i
End Function

pense à valider la réponse
++
<hr size="2" width="100%" />Prenez un instant pour répondre à [infomsg_SONDAGE-POP3-POUR-CS_769706.aspx ce sondage] svp
Messages postés
13280
Date d'inscription
lundi 13 décembre 2004
Statut
Modérateur
Dernière intervention
3 février 2018
46
dans la windowproc (et peut-être ailleurs), remplacer Call UnSubClass(hWnd) par Call UnSubClass
Messages postés
135
Date d'inscription
dimanche 19 novembre 2000
Statut
Membre
Dernière intervention
2 décembre 2011

Merci Exploreur

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



<?xml:namespace prefix o ns "urn:schemas-microsoft-com:office:office" /??>

 





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
Messages postés
135
Date d'inscription
dimanche 19 novembre 2000
Statut
Membre
Dernière intervention
2 décembre 2011

Cela est il possible ?


Ou je fait erreur dans mon code ?
Messages postés
4822
Date d'inscription
lundi 11 novembre 2002
Statut
Membre
Dernière intervention
15 novembre 2016
14
Salut,

Il faut surement retouché le code, car je viens de faire l'essai et cela ne fonctionne pas avec une boucle.....Bon je ne saurais quoi te dire, car cela dépasse mes connaissances....

A+
Exploreur

 Linux a un noyau, Windows un pépin

 
Messages postés
4822
Date d'inscription
lundi 11 novembre 2002
Statut
Membre
Dernière intervention
15 novembre 2016
14
D'ailleurs c'est dans le module qui faut revoir le code....

Bon dev..

A+
Exploreur

 Linux a un noyau, Windows un pépin

 
Messages postés
135
Date d'inscription
dimanche 19 novembre 2000
Statut
Membre
Dernière intervention
2 décembre 2011

Merci Exploreur

Je suis dans le meme cas que toi!
Un expert en SubClassing pour un petit coup de main SVP ?
Merci
Léo
Messages postés
135
Date d'inscription
dimanche 19 novembre 2000
Statut
Membre
Dernière intervention
2 décembre 2011

Merci beaucoup PCPT
Bonne soirée