Créer et insérer une progress bar dans une macro

Bonjour à tous !

J'aimerais créer et insérer une macro dans le code ci-dessous car cette macro prend un certain temps à s'exécuter et cela pourrait laisser penser à l'utilisateur que CATIA a planté.

Code:

Option Explicit

Public MyMergedAreasCollection As Collection
Public ExcelExportFile As String 'Chemin complet du fichier Excel d'export

Private Function Row_Col_IntegerConversion(MyRow As Integer, MyCol As Integer, MyNbCol As Integer) As Integer
Row_Col_IntegerConversion = (MyRow - 1) * MyNbCol + MyCol - 1
End Function

Private Function CreateDrawTabCell(iRow As Integer, iCol As Integer, MyTable As DrawingTable, ListOfmergeCells()) As DrawTabCell
Dim MyCell As DrawTabCell
Dim MytableVBS As Object
Dim MyTestCell As DrawingText
Dim MyTextProperties As DrawingTextProperties
Dim MyMergedArea As MergedArea

Dim MyNbCol As Integer
Dim MyfirstRow As Long, MyfirstCol As Long, RowLg As Long, ColLg As Long

Set MyCell = New DrawTabCell
Set MytableVBS = MyTable
Set MyTestCell = MyTable.GetCellObject(iRow, iCol)
Set MyTextProperties = MyTestCell.TextProperties
Set MyMergedArea = New MergedArea

MyNbCol = MyTable.NumberOfColumns

With MyCell
    .row = iRow
    .column = iCol
    .merged = ListOfmergeCells(Row_Col_IntegerConversion(iRow, iCol, MyNbCol))
    .value = MyTestCell.Text
    .fontname = MyTextProperties.fontname
    .fontsize = MyTextProperties.fontsize
    .bold = MyTextProperties.bold
    .italic = MyTextProperties.italic
    .underline = MyTextProperties.underline
    .alignement = MyTable.GetCellAlignment(iRow, iCol)
End With

If MyCell.merged = 1 Then
    MyTable.GetMergeInfos iRow, iCol, MyfirstRow, MyfirstCol, RowLg, ColLg
    If MyfirstRow = iRow And MyfirstCol = iCol Then
        With MyMergedArea
            .firstRow = MyfirstRow
            .firstCol = MyfirstCol
            .RowLg = RowLg
            .ColLg = ColLg
        End With
        MyMergedAreasCollection.Add MyMergedArea
    End If
End If

Set CreateDrawTabCell = MyCell

End Function

Private Sub Write_Excel(MyExcel As String, NbRow As Integer, NbCol As Integer, MyCellsCollection As Collection, MyMergedAreasCollection As Collection)

Dim ObjExcel, ObjWbooks, ObjSheet
Dim iRow As Integer, iCol As Integer

'Création de l'objet Excel
Set ObjExcel = CreateObject("Excel.Application")

'Désactivation des messages erreurs liés à Excel
ObjExcel.Application.DisplayAlerts = False

'Définition et sauvegarde du fichier Excel d'Export
Set ObjWbooks = ObjExcel.Workbooks.Add
ObjWbooks.SaveAs Filename:=ExcelExportFile, FileFormat:=51
Set ObjSheet = ObjExcel.ActiveWorkbook.Worksheets(1)

Dim MyCurrentCell As DrawTabCell
Dim MyMergedArea As MergedArea

ObjSheet.Range(ObjSheet.Cells(1, 1), ObjSheet.Cells(NbRow, NbCol)).NumberFormat = "@"



For Each MyCurrentCell In MyCellsCollection

    ObjSheet.Cells(MyCurrentCell.row, MyCurrentCell.column).value = MyCurrentCell.value
    
    With ObjSheet.Cells(MyCurrentCell.row, MyCurrentCell.column).Font
        .Name = MyCurrentCell.fontname
        .Size = MyCurrentCell.fontsize / 0.36
        Select Case MyCurrentCell.underline
            Case 1
                .underline = 2
            Case Else
                .underline = -4142
        End Select
        .bold = MyCurrentCell.bold
        .italic = MyCurrentCell.italic
    End With
    
    With ObjSheet.Cells(MyCurrentCell.row, MyCurrentCell.column)
        Select Case MyCurrentCell.alignement
            Case CatTableTopLeft
                .VerticalAlignment = -4160
                .HorizontalAlignment = -4131
            Case CatTableMiddleLeft
                .VerticalAlignment = -4108
                .HorizontalAlignment = -4131
            Case CatTableBottomLeft
                .VerticalAlignment = -4107
                .HorizontalAlignment = -4131
            Case CatTableTopCenter
                .VerticalAlignment = -4160
                .HorizontalAlignment = -4108
            Case CatTableMiddleCenter
                .VerticalAlignment = -4108
                .HorizontalAlignment = -4108
            Case CatTableBottomCenter
                .VerticalAlignment = -4107
                .HorizontalAlignment = -4108
            Case CatTableTopRight
                .VerticalAlignment = -4160
                .HorizontalAlignment = -4152
            Case CatTableMiddleRight
                .VerticalAlignment = -4108
                .HorizontalAlignment = -4152
            Case CatTableBottomRight
                .VerticalAlignment = -4107
                .HorizontalAlignment = -4152
            End Select
    End With
    
    
Next MyCurrentCell

For Each MyMergedArea In MyMergedAreasCollection
    ObjSheet.Range(ObjSheet.Cells(MyMergedArea.firstRow, MyMergedArea.firstCol), ObjSheet.Cells(MyMergedArea.firstRow + MyMergedArea.RowLg - 1, MyMergedArea.firstCol + MyMergedArea.ColLg - 1)).merge
Next


' Sort the data using the fourth column as the sorting key
ObjSheet.Range(ObjSheet.Cells(4, 1), ObjSheet.Cells(NbRow, NbCol)).Sort _
    Key1:=ObjSheet.Cells(3, 4), Order1:=2, Header:=1, _
    OrderCustom:=1, MatchCase:=False, Orientation:=1


ObjExcel.ActiveWorkbook.Save
    
'Reset de l'objet Excel et des messages d'alertes Excel
ObjExcel.Quit
ObjExcel.Application.DisplayAlerts = True
Set ObjExcel = Nothing

End Sub

Sub CATMain()

Dim MyDocument As Document
Dim InputObjectType(0), oListOfmergeCells()
Dim MyTable As DrawingTable
Dim MyCellsCollection As Collection
Dim MytableVBS As Object
Dim NbRow As Integer, NbCol As Integer, sizeTab As Integer
Dim iRow As Integer, iCol As Integer
Dim ExportFilePath As String
Dim MySelection As Selection
Dim MySelectionVBS As Object
Dim Status

If Not Is_ActiveDocument_Draw Then
    MsgBox "Un Drawing doit être ouvert", vbExclamation
    End
End If

Set MyDocument = CATIA.ActiveDocument
Set MySelection = MyDocument.Selection

Set MyCellsCollection = New Collection
Set MyMergedAreasCollection = New Collection

Set MySelectionVBS = MySelection

InputObjectType(0) = "DrawingTable"
Status = MySelectionVBS.SelectElement2(InputObjectType, "Sélectionner la Drawing Table à exporter", True)
If (Status = "Cancel") Then
    MsgBox "Tâche annulée", vbInformation
    End
End If
Set MySelection = MySelectionVBS

Set MyTable = MySelection.Item(1).value

ExportTabDrawFrom.Show

NbRow = MyTable.NumberOfRows
NbCol = MyTable.NumberOfColumns

sizeTab = NbRow * NbCol
ReDim oListOfmergeCells(sizeTab - 1)

Set MytableVBS = MyTable
MytableVBS.GetCellsMerge oListOfmergeCells

For iRow = 1 To NbRow
    For iCol = 1 To NbCol
        MyCellsCollection.Add CreateDrawTabCell(iRow, iCol, MyTable, oListOfmergeCells)
    Next iCol
Next iRow

Write_Excel ExcelExportFile, NbRow, NbCol, MyCellsCollection, MyMergedAreasCollection

 ' Récupérer le chemin du fichier Excel exporté
ExportFilePath = ExcelExportFile

Select Case MsgBox("Export Terminé" & Chr(10) & "Fichier Excel d'export sauvegardé sous:" & ExtraireChemin(ExcelExportFile) & vbCrLf & "Voulez-vous ouvrir le dossier d'export?", vbYesNo + vbQuestion)
    Case vbYes
        ShellExecute 0, "OPEN", ExtraireChemin(ExcelExportFile), "", "", 3
End Select

MsgBox "Importation"

 ' Appeler la fonction ImportExcel avec le chemin du fichier exporté
ImportExcel ExportFilePath
Create_DrawingTable

End Sub





Si quelqu'un a une solution je suis preneur merci d'avance !