Comment changer la couleur de l'arrière plan d'un controle Slider
Résolu
PascalCmoa
Messages postés
239
Date d'inscription
mercredi 19 février 2003
Statut
Membre
Dernière intervention
17 janvier 2013
-
3 févr. 2005 à 15:59
cs_ITALIA Messages postés 2169 Date d'inscription vendredi 20 avril 2001 Statut Membre Dernière intervention 30 juin 2009 - 4 févr. 2005 à 10:26
cs_ITALIA Messages postés 2169 Date d'inscription vendredi 20 avril 2001 Statut Membre Dernière intervention 30 juin 2009 - 4 févr. 2005 à 10:26
2 réponses
PascalCmoa
Messages postés
239
Date d'inscription
mercredi 19 février 2003
Statut
Membre
Dernière intervention
17 janvier 2013
5
3 févr. 2005 à 16:07
3 févr. 2005 à 16:07
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]
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]
cs_ITALIA
Messages postés
2169
Date d'inscription
vendredi 20 avril 2001
Statut
Membre
Dernière intervention
30 juin 2009
9
4 févr. 2005 à 10:26
4 févr. 2005 à 10:26
Coches Reponse Acceptée...ça peut aider les autres
It@li@
It@li@