Couleur de fond d'un contrôle sliderRésolu

Question

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 : 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

cs_Exploreur · Accepted Answer

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

Leo_Robotic_Passion · Answer

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

Leo_Robotic_Passion · Answer

Cela est il possible ?


Ou je fait erreur dans mon code ?

cs_Exploreur · Answer

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

cs_Exploreur · Answer

D'ailleurs c'est dans le module qui faut revoir le code....

Bon dev..

A+
Exploreur

 Linux a un noyau, Windows un pépin

Leo_Robotic_Passion · Answer

Merci Exploreur

Je suis dans le meme cas que toi!
Un expert en SubClassing pour un petit coup de main SVP ?
Merci
Léo

PCPT · Answer

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 ++

Prenez un instant pour répondre à [infomsg_SONDAGE-POP3-POUR-CS_769706.aspx ce sondage] svp

PCPT · Answer

dans la windowproc (et peut-être ailleurs), remplacer Call UnSubClass(hWnd) par Call UnSubClass

Leo_Robotic_Passion · Answer

Merci beaucoup PCPT
Bonne soirée

Couleur de fond d'un contrôle slider

9 réponses

Votre réponse

Discussions similaires