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

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
DenisHen

DenisHen

XLDnaute Junior
Bonjour à la communauté.

Je viens de découvrir un problème sur mon Ordi Portable Perso, Il plante lors d'un Progress Bar (Win11, Office 2024) est modifiée dans l'UserForm en VBA.
Mais sur mon Ordi Fix Perso (Win11, Office 2024), ça fonctionne, et sur le PC Portable Pro (Win10, Office 365) ça fonctionne aussi.

J'ai tenté plein de manipulation trouvées un peu partout sur le net.
Retélécharger le MsComCtl.ocx, version 32 ou version 64, puis dans PowerShell (mode Admin), les regsvr32 mscomctl.ocx dans system32 ou syswow64...

Aucun changement, quelqu'un aurait une idée ?

Denis.
 
Dernière édition:
Trier par date Trier par votes
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...
Bonjour cathodique
et le pire c'est que createwindowExA va chercher le progressbar au même endroit (PrBar =CreateWindowExA(0,"msctls_progress32",.......)
c'est ça qui est absurde en office 64
 
Vote positif 0 Vote négatif
Je m'attendais à autre chose. C'est au final le même progressBar, géré en utilisant des Api.
Cliquez pour agrandir...
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
 

Pièces jointes

Vote positif 0 Vote négatif
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...
Bonjour,

Merci beaucoup @Rheeem. L'aspect est très satisfaisant.

Bon week-end
 
Vote positif 0 Vote négatif
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é
demo4.gif
 

Pièces jointes

Vote positif -1 Vote négatif
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...
Bonjour,

Merci beaucoup. Il y a cependant un petit souci dans le code de l'userform1 (Gif ci-dessous)

ProgressBar1.gif

Bonne journée.
 
Vote positif 0 Vote négatif
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
 

Pièces jointes

Vote positif -1 Vote négatif
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...
Je suppose que le plantage est normal sur mon office 32 bits (voir Gif)
ProgressBar1.gif


Bonne soirée.
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD
Retour