Comment changer la couleur de l'arrière plan d'un controle Slider [Résolu]

Signaler
Messages postés
240
Date d'inscription
mercredi 19 février 2003
Statut
Membre
Dernière intervention
17 janvier 2013
-
Messages postés
2169
Date d'inscription
vendredi 20 avril 2001
Statut
Membre
Dernière intervention
30 juin 2009
-
Bonjour à tous,


Peut-on me dire comment changer la couleur de l'arrière plan d'un controle Slider .
Evitez de me dire de faire:
monSlider.background = maCouleur

Merci d'avance.

PascalCmoa
[mailto:pascal.aknouche@free.fr email: PascalCmoa]

2 réponses

Messages postés
240
Date d'inscription
mercredi 19 février 2003
Statut
Membre
Dernière intervention
17 janvier 2013
5
Je viens de trouver, Grand merci à Moi , voici le code:

dans un module bas.
<HR>
Option Explicit

<!--webbot bot="Include" u-include="../../terms/copycode.htm" tag="BODY" startspan -->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


<HR>
dans votre form.


Dans votre form, il y a:
- 2 boutons: Command1 et Command2
- 1 Slider: Slider1
- 1 checkbox: Check1,
----

<HR color=#29527c noShade SIZE=1>,
----

Option Explicit

Private Sub Form_Load()

Command1.Caption = "Setup && Subclass"
Command2.Caption = "Quit"
Check1.Caption = "Enable Slider ToolTips"
Check1.Value = vbChecked

End Sub

Private Sub Command1_Click()

CreateSliderBrush RGB(40, 40, 130), False

hSliderHwnd = Slider1.hWnd

Call SubClass(Me.hWnd)

Command1.Enabled = False

End Sub

Private Sub Command2_Click()

Unload Me

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

A vous de jouer maintenant.

PascalCmoa
[mailto:pascal.aknouche@free.fr email: PascalCmoa]
3
Merci

Quelques mots de remerciements seront grandement appréciés. Ajouter un commentaire

Codes Sources 163 internautes nous ont dit merci ce mois-ci

Messages postés
2169
Date d'inscription
vendredi 20 avril 2001
Statut
Membre
Dernière intervention
30 juin 2009
8
Coches Reponse Acceptée...ça peut aider les autres

It@li@