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

PascalCmoa 240 Messages postés mercredi 19 février 2003Date d'inscription 17 janvier 2013 Dernière intervention - 3 févr. 2005 à 15:59 - Dernière réponse : cs_ITALIA 2169 Messages postés vendredi 20 avril 2001Date d'inscription 30 juin 2009 Dernière intervention
- 4 févr. 2005 à 10:26
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]
Afficher la suite 

2 réponses

Meilleure réponse
PascalCmoa 240 Messages postés mercredi 19 février 2003Date d'inscription 17 janvier 2013 Dernière intervention - 3 févr. 2005 à 16:07
3
Merci
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]

Merci PascalCmoa 3

Avec quelques mots c'est encore mieux Ajouter un commentaire

Codes Sources a aidé 86 internautes ce mois-ci

cs_ITALIA 2169 Messages postés vendredi 20 avril 2001Date d'inscription 30 juin 2009 Dernière intervention - 4 févr. 2005 à 10:26
0
Merci
Coches Reponse Acceptée...ça peut aider les autres

It@li@

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.