Autres Problème de Progress Bar (erreur d'ocx)

cathodique à dit:

Bonjour,

Je m'attendais à autre chose. C'est au final le même progressBar, géré en utilisant des Api.
Toujours aussi perspicace Patrick, merci beaucoup pour ton partage.
Bonne journée.

Cliquez pour agrandir...

Cousinhub à dit:

Re-,
Effectivement, ça marche mieux
Cependant, double apparition de ce msg :

Regarde la pièce jointe 1226176

Et ensuite, la progress bar "progresse" bien 🙂

Cliquez pour agrandir...

Le demandeur (@DenisHen ) a eu un problème d'ocx.

Cliquez pour agrandir...

Je m'attendais à autre chose. C'est au final le même progressBar, géré en utilisant des Api.

Cliquez pour agrandir...

Option Explicit
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As LongPtr
Private Declare PtrSafe Function OpenThemeData Lib "UxTheme.dll" (ByVal hwnd As LongPtr, ByVal LPCWSTR As LongPtr) As LongPtr
Private Declare PtrSafe Function CloseThemeData Lib "UxTheme.dll" (ByVal hTheme As LongPtr) As Long
Private Declare PtrSafe Function DrawThemeBackground Lib "UxTheme.dll" (ByVal hTheme As LongPtr, ByVal hdc As LongPtr, ByVal iPartId As Long, ByVal iStateId As Long, pRect As RECT, ByVal pClipRect As LongPtr) As Long
Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Public Enum PPState
 PBFS_NORMAL = 1: PBFS_ERROR: PBFS_PAUSED: PBFS_PARTIAL
End Enum
Private nMax As Double
Private nMin As Double
Private Pz As Long

Private Sub SetProgressRange(ByVal Min As Double, ByVal Max As Double)
 nMin = Min
 nMax = Max
Pz = -1
End Sub

Private Sub Progress(ByVal Value As Double, Optional State As PPState = PBFS_NORMAL)
Const PP_BAR = 1
Const PP_FILL = 5
Dim hTheme As LongPtr, dc As LongPtr, Dest As RECT
Dim u As Long, dlt As Double
If nMin >= nMax Then Exit Sub
 dlt = (Value - nMin) / (nMax - nMin)
 u = dlt * 100
 If u = Pz Then Exit Sub
   Caption = u
   Pz = u
   On Error GoTo Fin
   dc = GetDC(Frame1.[_GethWnd])
   GetClientRect Frame1.[_GethWnd], Dest
   hTheme = OpenThemeData(0, StrPtr("Progress"))
   If Pz = 0 Then
      DrawThemeBackground hTheme, dc, PP_BAR, 1, Dest, 0
   End If
   Dest.Right = Dest.Right * Pz / 100
   DrawThemeBackground hTheme, dc, PP_FILL, State, Dest, 0
Fin: CloseThemeData hTheme
   ReleaseDC Frame1.[_GethWnd], dc
End Sub
Private Sub CommandButton1_Click()
Dim t As Single, i
 t = Timer
 SetProgressRange 1, 500

 For i = 1 To 500
    Progress i, PBFS_PARTIAL
    While (Timer - t) < 0.01
     DoEvents
    Wend
    t = Timer
 Next
 MsgBox "Terminé"
End Sub

Rheeem à dit:

Si c'est l'aspect visuel qui t’intéresse et tu souhaites avoir un contrôle avec un look moderne il est possible de dessiner le style sans créer le contrôle ce qui est le plus important.

Code:

Option Explicit
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As LongPtr
Private Declare PtrSafe Function OpenThemeData Lib "UxTheme.dll" (ByVal hwnd As LongPtr, ByVal LPCWSTR As LongPtr) As LongPtr
Private Declare PtrSafe Function CloseThemeData Lib "UxTheme.dll" (ByVal hTheme As LongPtr) As Long
Private Declare PtrSafe Function DrawThemeBackground Lib "UxTheme.dll" (ByVal hTheme As LongPtr, ByVal hdc As LongPtr, ByVal iPartId As Long, ByVal iStateId As Long, pRect As RECT, ByVal pClipRect As LongPtr) As Long
Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Public Enum PPState
 PBFS_NORMAL = 1: PBFS_ERROR: PBFS_PAUSED: PBFS_PARTIAL
End Enum
Private nMax As Double
Private nMin As Double
Private Pz As Long

Private Sub SetProgressRange(ByVal Min As Double, ByVal Max As Double)
 nMin = Min
 nMax = Max
Pz = -1
End Sub

Private Sub Progress(ByVal Value As Double, Optional State As PPState = PBFS_NORMAL)
Const PP_BAR = 1
Const PP_FILL = 5
Dim hTheme As LongPtr, dc As LongPtr, Dest As RECT
Dim u As Long, dlt As Double
If nMin >= nMax Then Exit Sub
 dlt = (Value - nMin) / (nMax - nMin)
 u = dlt * 100
 If u = Pz Then Exit Sub
   Caption = u
   Pz = u
   On Error GoTo Fin
   dc = GetDC(Frame1.[_GethWnd])
   GetClientRect Frame1.[_GethWnd], Dest
   hTheme = OpenThemeData(0, StrPtr("Progress"))
   If Pz = 0 Then
      DrawThemeBackground hTheme, dc, PP_BAR, 1, Dest, 0
   End If
   Dest.Right = Dest.Right * Pz / 100
   DrawThemeBackground hTheme, dc, PP_FILL, State, Dest, 0
Fin: CloseThemeData hTheme
   ReleaseDC Frame1.[_GethWnd], dc
End Sub
Private Sub CommandButton1_Click()
Dim t As Single, i
 t = Timer
 SetProgressRange 1, 500

 For i = 1 To 500
    Progress i, PBFS_PARTIAL
    While (Timer - t) < 0.01
     DoEvents
    Wend
    t = Timer
 Next
 MsgBox "Terminé"
End Sub

Cliquez pour agrandir...

patricktoulon à dit:

Bonsoir
pour faire un simple slider autant le faire en vba tout court(sans api )
pour cela une toute petite classounette
un moduleclasse nommé "progressXbar"

VB:

Option Explicit
Public fondprogress
Public slider
Public uf
Public pct
Public Sub Create(usf, leftx As Long, topx As Long, largeur As Long, hauteur As Long, Optional couleur As Long = vbRed)
    Set uf = usf
    Set fondprogress = usf.Controls.Add("forms.Label.1", "Fondprogress", True)
    With fondprogress
        .BorderStyle = 1: .Move leftx, topx, largeur, hauteur
    End With
  
    Set slider = usf.Controls.Add("forms.Label.1", "slider", True)
    With slider
        .BorderStyle = 0: .Move leftx + 1, topx + 1, 0, hauteur - 2: .BackColor = couleur
    End With
  
    Set pct = usf.Controls.Add("forms.Label.1", "pct", True)
    With pct
        .BorderStyle = 0: .Move leftx + 1, topx - 10, 50, 10: .Caption = "%"
    End With
  
End Sub

Public Sub progress(x As Long, fin As Long)
    slider.Width = (uf.Controls("fondprogress").Width - 2) * (x / fin)
    pct.Caption = (x / fin) * 100 & " %"
End Sub

dans le userform

VB:

Option Explicit
Dim progressBar As New progressXbar
Dim Go As Boolean

Private Sub UserForm_Activate()
    progressBar.Create Me, 17, 17, 200, 10
End Sub

Private Sub CommandButton1_Click()
    Dim i As Long, t
    Go = True
    For i = 1 To 1000
        If Not Go Then Exit For
        progressBar.progress i, 1000
        t = Timer: Do While Timer - t < 0.01: DoEvents: Loop
    Next
    MsgBox "Terminé"
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Go = False
End Sub

et voila
on choisi le left ,top width,height,couleur
on create et on la fait tourner avec progress
Terminé
Regarde la pièce jointe 1226186

Cliquez pour agrandir...

patricktoulon à dit:

Bonjour @cathodique , @DenisHen , @Dranreb , @Cousinhub ,@Rheeem
pour le coup j'ai pris 10 petites minutes et je vous les ai refaites au propre.

userform1 api createWindowExA
options :
segmentée ou pleine
couleur de fond
couleur du slider

userform2 créée avec des labels dans une micro classounette
options :
couleur de fond
couleur du slider

Pour les deux vous avez les boutons de couleur qui ouvre la palette de couleur

voila comme ça c'est propre et simple

Je ne fais pas de démo vous verrez par vous-même
patrick

Cliquez pour agrandir...

patricktoulon à dit:

pour info il faire un create d'abords !!!

Cliquez pour agrandir...