EXCEL :: RENAISSANCE d'une barre de progression des traitements

[oguruma]

Bonsoir le Forum,
Cherchant sur le Net je suis tombé sur le code d'une barre de progression.
Auteur : Patrick TOULON
J'avais un peu le même truc mais très rustic...
Pour des besoins de développements j'ai donc repris son code en y apportant quelques modifications fonctionnelles concernant l'affichage des messages.
C'est avec son accord que je publie cette nouvelle version qu'il pourra reprendre pour ses propres évolutions.
Le code comporte 3 modules de tests que l'on peut lancer via l'éditeur VBE.

Les évolutions portent essentiellement sur les paramètres passés à l'affichage de la barre de progression

Sub PROGRESS_BAR(hInit As Long, hFin As Long, _

hMsg As String, _

Optional hMsg2 As String = "Patienter !", _

Optional hMsgFin As String = "Terminé !", _

Optional hThestyle As Long = styleColor.vista, _

Optional hPct As Boolean = True, _

Optional hUnload As Boolean = False, _

Optional hSlide As Boolean = True)

PROGRESS_BAR i, fin, "traitement en cours", "c'est long", "C'est fini !!!", styleColor.Silver, True, True
Affichage de la progression en %, fermeture automatique, progression des traitements en nombre dans la caption de la fenêtre

PROGRESS_BAR i, fin, "traitement en cours", "c'est long", "C'est fini !!!", styleColor.Silver, False, False
On ne souhaite pas afficher la progression en %

PROGRESS_BAR i, fin, "traitement en cours", "c'est long", "C'est fini !!!", styleColor.Silver, False, True, False

la jauge de progression n'est pas affichée ainsi que le nombre en cours dans la caption de la fenêtre
Option utile quand on lance seul traitement qui ne demande pas d'affichage de l'avancement en %

Exemples de lancements plus fonctionnels

    PROGRESS_BAR 1, 13, "traitement en cours", "Requête - DOSSIER_RUP", , styleColor.Silver, True, False
    ActiveWorkbook.Connections("Requête - DOSSIER_RUP").Refresh
    
    PROGRESS_BAR 2, 13, "traitement en cours", "Requête - RUP_1", , styleColor.Silver, True, False
    ActiveWorkbook.Connections("Requête - RUP_1").Refresh

Voilà Patrick à toi tous les honneurs pour reprendre ce que j'ai tenté d'améliorer 😉

Option Explicit

Enum styleColor
    blue_seven = 16762880
    Xp = 2031360
    vista = 6612540
    Xp_Corporate = 16777160
    darkblue = 11827300
    Lady = 13133055
    blood = 255
    Silver = 16777215
End Enum

Sub CREATE_SLIDE_BAR(hThestyle As Long, hCaption As String)
    Dim vBar As CommandBar
   
    With CadreBar
     .slide.Left = .FDP.Left:  .slide.Top = .FDP.Top: If .FDP.Width > .FDP.Height Then .sens = 1: .slide.Height = .FDP.Height Else .sens = 2:    .slide.Width = .FDP.Width
    End With
    With ActiveSheet.Shapes.AddShape(1, 10, 15, 200, 50)
        .Name = "progress"
        .Line.Visible = msoFalse
         .Fill.ForeColor.RGB = hThestyle
        If CadreBar.sens = 2 Then .Fill.OneColorGradient 2, 4, 0.1 Else: .Fill.OneColorGradient 1, 4, 0.1
        .Copy
        Set vBar = CommandBars.Add("temp", , , True)
        With vBar.Controls.Add(msoControlButton)
            .PasteFace
            CadreBar.slide.Picture = .Picture
            CadreBar.start = True
        '    CadreBar.message.Caption = "Veuillez patienter !!" & vbCrLf & " la fin de l'execution"
        CadreBar.Caption = hCaption
        End With
        vBar.Delete
        .Delete
    End With
    CadreBar.Show 0
End Sub
'
'
Sub PROGRESS_BAR(hInit As Long, hFin As Long, _
hMsg As String, _
Optional hMsg2 As String = "Patienter !", _
Optional hMsgFin As String = "Terminé !", _
Optional hThestyle As Long = styleColor.vista, _
Optional hPct As Boolean = True, _
Optional hUnload As Boolean = False, _
Optional hSlide As Boolean = True)

    With CadreBar
        If .start = False Then CREATE_SLIDE_BAR hThestyle, "Progression des traitements"
       
        If hPct Then
            CadreBar.Caption = "Progression des traitements " & hInit & "/" & hFin
        End If

        If .sens = 1 Then
            .slide.Width = ((.FDP.Width / hFin) * hInit)
        Else
            .slide.Height = (((.FDP.Height) / hFin) * hInit): .slide.Top = .FDP.Top + .FDP.Height - .slide.Height
        End If

        If hPct Then
            .message.Caption = hMsg & vbCrLf & hMsg2 & vbCrLf & Round(hInit / hFin * 100, 0) & " %"
        Else
            .message.Caption = hMsg
            .FDP.Visible = False
            If hSlide Then
                .slide.Visible = True
            Else
                .slide.Visible = False
            End If
        End If
        If hInit >= hFin Then
            If hUnload Then
                .message.Caption = Round(hInit / hFin * 100, 0) & " %" & vbCrLf & hMsgFin
                Unload CadreBar
            Else
                .message.Caption = Round(hInit / hFin * 100, 0) & " %" & vbCrLf & hMsgFin
            End If
        End If
             
       DoEvents
     
    End With
End Sub


Sub test()
    Dim i As Long, debut As Long, fin As Long
    debut = 1: fin = 10000
    Load CadreBar
    For i = debut To fin
        ' ton code qui fait ce que tu veux
        'blablabla
        '....
        PROGRESS_BAR i, fin, "traitement en cours", "c'est long", "C'est fini !!!", styleColor.Silver, True, True
    Next
  '  Unload CadreBar
End Sub
Sub test2()
    Dim i As Long, debut As Long, fin As Long
    debut = 1: fin = 10000
    Load CadreBar
    For i = debut To fin
        ' ton code qui fait ce que tu veux
        'blablabla
        '....
        PROGRESS_BAR i, fin, "traitement en cours", "c'est long", "C'est fini !!!", styleColor.Silver, False, False
       
    Next
    MsgBox "fin"
    Unload CadreBar
End Sub

Sub test3()
    Dim i As Long, debut As Long, fin As Long
    debut = 1: fin = 10000
    Load CadreBar
    For i = debut To fin
        ' ton code qui fait ce que tu veux
        'blablabla
        '....
        PROGRESS_BAR i, fin, "traitement en cours", "c'est long", "C'est fini !!!", styleColor.Silver, False, True, False
       
    Next
    MsgBox "fin"
    Unload CadreBar
End Sub
Sub testunload()
    Load CadreBar
    CadreBar.Show 0
    Unload CadreBar
End Sub

 

[patricktoulon]

Bonjour @oguruma
non ma fois elle est bien comme ça 👍

 

[oguruma]

Bonjour @oguruma
non ma fois elle est bien comme ça 👍

Bonjour Patrick, je n'en ferai donc pas plus pour le moment. Si je suis amené dans mes futurs dév à faire à la faire évoluer je publierai les nouvelles versions. 🙂