EXCEL :: CLASS_LIBRARY_TOOLS_V1.0 - Classes utilitaires - Fichier Log, Gestion de pile d'exécution, isExists, Paramètres, Collection, Dictionnaire

oguruma · 2 Mai 2025

Bonjour le Forum,
ci-joint un classeur Excel dans lequel vous trouverez une série de classes utilitaires. Certaines sont déjà connues car elles sont utilisées dans les différentes livraisons d'utilitaires en téléchargements que j'ai effectué. En particulier Cls_CollectionParameters, SpeedMacro, Cls_MessagesDialog.

Les nouvelles classes :
Cls_LogFile : combinée avec Cls_LogFileDefine : elle permet d'implémenter un fichier log afin de tracer les traitements
Cls_StackModule : elle permet d'empiler et de dépiler les différents appels de procédures et de fonctions. En cas d'erreur il suffit de dépiler le contenu de la pile afin de savoir par où sont passés les traitements. En effet sauf erreur, VBA ne dispose pas de fonctions qui renvoie la procédure active au moment de son exécution.
Cls_ObjectExists : cette classe comporter quelques fonctions permettant de tester la présence de fichiers, de dossiers, d'objets comme les tableaux, les shapes, les graphiques, les TCD, les connexions PowerQuery
Cls_ToolsString : cette classe complète les fonctions Left et Right. Elle a l'avantage de pouvoir préciser un délimiteur/séparateur texte et aussi de faire la recherche dans les deux sens via le suffixe Back

Test des différentes classes dans l'onglet DEMOs

Cls_LogFile

Il est possible d'afficher la log générée dans une fenêtre

et dans un fichier

[02-05-2025 19:20:30] : Initialisation de la log
[02-05-2025 19:20:30] : Fichier log D:\DATA\10__DEVELOPPEMENTS__EXCEL__LABS\§__LAB14_TOOLS\$LIBMAC_FILELOG$2025_05_02.log
[02-05-2025 19:20:30] : Ligne 1
[02-05-2025 19:20:30] : Ligne 2
[02-05-2025 19:20:30] : Ligne 3

Afin que cette log soit activée il est nécessaire d'implémenter un tableau de paramètres comme suit

Cls_StackModule

En cas de répétition de modules cas des appels récursifs un index est créé comme -§0001 suffixé au nom du module

le module5 ne figure plus dans la pile

tous les appels au module1 ne figurent plus dans la pile

Dans la manière de procéder (voir le code de démonstration) il suffit d'appeler la fonction avec le nom de la procédure à empiler et de dépiler à la sortie de la procédure - bien entendu cela suppose un peu de rigueur dans votre code et de ne pas oublier de dépiler à chaque sortie ou d'empiler à chaque entrée

cas avec une provocation d'erreur

==> l'erreur a eu lieu à l'étape 3 c'est la dernière qui a été empilée et donc conservée car c'est la gestion d'erreur qui a pris le relai.

Pour le reste des tests voir les boutons dans l'onglet ainsi que le code de test et les classes

VB:

Option Explicit

Const FILELOG As String = "$LIBMAC_FILELOG$"

Private pWb_MACRO As Workbook
Private pFileNameLog As String
Private pLogFileCollection As Collection
Private pObjLogLine As Cls_LogFileDefine
Private pLogFileStatusOK As Boolean
Private pNbLines As Long


Private Sub Class_Initialize()
    Dim oParamLog As Cls_CollectionParameters
   
    Set oParamLog = New Cls_CollectionParameters
    Call oParamLog.Imp_Parameters_Instanciate
   
    ' On va récupérer le paramètre d'activation
    If UCase(oParamLog.Imp_Parameters_GetParameter("LOGFILE")) = "OUI" Then
        pLogFileStatusOK = True
    Else
        pLogFileStatusOK = False
    End If
   
    ' Si la log est active on initialise la collection qui va contenir la log
    If pLogFileStatusOK Then
        Set pWb_MACRO = ThisWorkbook
        pFileNameLog = ThisWorkbook.Path & "\" & FILELOG & Format(Now, "yyyy_mm_dd") & ".log"
        Set pLogFileCollection = New Collection
        If pLogFileStatusOK Then InitLog
    End If
End Sub

Property Get FileNameLog()
    FileNameLog = pFileNameLog
End Property

Property Get isLogActive()
    isLogActive = pLogFileStatusOK
End Property

Property Get NbLines()
    NbLines = pNbLines
End Property

Sub AddLogLine(hLogLine As Variant)
    If pLogFileStatusOK Then
        Set pObjLogLine = New Cls_LogFileDefine
        pObjLogLine.sTimeStamp = "[" & Format(Now, "dd-mm-yyyy hh:mm:ss") & "] : "
        pObjLogLine.sDescription = hLogLine
        pLogFileCollection.Add pObjLogLine, Key:=CStr(pLogFileCollection.Count + 1)
        pNbLines = pNbLines + 1
    End If
End Sub

Function GetLog() As Variant
    If pLogFileStatusOK Then
        Dim vLog As Variant
        Dim idx As Long
        ReDim vLog(0)
        idx = -1
        For Each pObjLogLine In pLogFileCollection
            idx = idx + 1
            ReDim Preserve vLog(idx)
            vLog(idx) = pObjLogLine.sTimeStamp & pObjLogLine.sDescription
        Next
        GetLog = vLog
    End If
End Function

Sub GetLogToFrm()
    If pLogFileStatusOK Then
        Dim sLog As String
        For Each pObjLogLine In pLogFileCollection
            sLog = sLog & pObjLogLine.sTimeStamp & pObjLogLine.sDescription & vbLf
        Next
        frm_SCRIPT.Caption = pFileNameLog
        frm_SCRIPT.txt_SCRIPT.Value = sLog
        frm_SCRIPT.Show 1
    End If
End Sub

Sub GetLogToFile()
    If pLogFileStatusOK Then
        Dim sLog As String
        Dim iFp As Integer
        iFp = FreeFile
        Close
        Open pFileNameLog For Output As iFp
        For Each pObjLogLine In pLogFileCollection
            sLog = pObjLogLine.sTimeStamp & pObjLogLine.sDescription
            Print #iFp, sLog
        Next
        Close
    End If
End Sub

Sub InitLog()
    If pLogFileStatusOK Then
        Call AddLogLine("Initialisation de la log")
        Call AddLogLine("Fichier log " & pFileNameLog)
    End If
End Sub

Private Sub Class_Terminate()
    Set pLogFileCollection = Nothing
    Set pObjLogLine = Nothing
End Sub

VB:

Option Explicit

Public sTimeStamp As String
Public sDescription As String

VB:

Option Explicit


Private pWb_MACRO As Workbook
Private pStack As Object

Private Sub Class_Initialize()
    Set pWb_MACRO = ThisWorkbook
    Set pStack = CreateObject("Scripting.Dictionary")
End Sub

Sub Push(hKey As String, Optional hValue As String)
    Const DELIM = "-§"
    If Not pStack.exists(hKey) Then
        pStack.Add hKey, hValue
    Else
        pStack.Add hKey & DELIM & Right("0000" & CStr(pStack.Count), 4), hValue
    End If
End Sub

Sub Pop(hKey As String)
    If pStack.exists(hKey) Then
        pStack.Remove (hKey)
    End If
End Sub

Sub PopAll(hKey As String)
    Const VERSION = 5
    Const DELIM = "-§"
    Dim sKey As String
    Dim vStack As Variant
    Dim iLenStack As Integer
    Dim iPos As Integer
    For Each vStack In pStack
        iPos = InStr(1, vStack, DELIM)
        If iPos > 0 Then
            sKey = Left(vStack, Len(vStack) - VERSION - 1)
        Else
            sKey = vStack
        End If
        If hKey = sKey Then
            If pStack.exists(vStack) Then
                pStack.Remove (vStack)
            End If
        End If
    Next
End Sub

Function GetStackToString(Optional hSep As String = " ") As String
    Dim szStack As String
    Dim vStack As Variant
    GetStackToString = ""
    For Each vStack In pStack
        szStack = szStack & hSep & vStack
    Next
    GetStackToString = Trim(szStack)
End Function

Function getCount() As Integer
    getCount = pStack.Count
End Function

Sub ClearStack()
    Set pStack = Nothing
End Sub

Private Sub Class_Terminate()
    Set pStack = Nothing
End Sub

VB:

Option Explicit

Function StringLeft(hSourceString As String, hSearchString As String) As String
    Dim iPos As Integer
    iPos = InStr(hSourceString, hSearchString)
    If iPos > 0 Then iPos = iPos - 1
    StringLeft = Left(hSourceString, iPos)
End Function

Function StringRight(hSourceString As String, hSearchString As String) As String
    Dim iPos As Integer
    Dim iStart As Integer
    Dim iLen As Integer
    iPos = InStr(hSourceString, hSearchString)
    iLen = Len(hSourceString)
    iStart = iLen - iPos
    StringRight = Right(hSourceString, iStart)
End Function

Function StringLeftBack(hSourceString As String, hSearchString As String) As String
    Dim sSourceStringBack As String
    Dim sSearchStringBack As String
    Dim sTurnBack As String
    Dim iPos As Integer
    Dim iNdx As Integer
    Dim iLengthString As Integer
    Dim iStartString As Integer
    Dim sTmpResult As String

    For iNdx = Len(hSourceString) To 1 Step -1
        sSourceStringBack = sSourceStringBack & Mid(hSourceString, iNdx, 1)
    Next
    For iNdx = Len(hSearchString) To 1 Step -1
        sSearchStringBack = sSearchStringBack & Mid(hSearchString, iNdx, 1)
    Next
    iPos = InStr(sSourceStringBack, sSearchStringBack)
    iLengthString = Len(sSourceStringBack)
    iStartString = iLengthString - iPos
    sTmpResult = Right(sSourceStringBack, iStartString)
    For iNdx = Len(sTmpResult) To 1 Step -1
        sTurnBack = sTurnBack & Mid(sTmpResult, iNdx, 1)
    Next
    StringLeftBack = sTurnBack
End Function
 
Function StringRightBack(hSourceString As String, hSearchString As String) As String
    Dim sSourceStringBack As String
    Dim sSearchStringBack As String
    Dim sTurnBack As String
    Dim iPos As Integer
    Dim iNdx As Integer
    Dim iLengthString As Integer
    Dim iStartString As Integer
    Dim sTmpResult As String

    For iNdx = Len(hSourceString) To 1 Step -1
        sSourceStringBack = sSourceStringBack & Mid(hSourceString, iNdx, 1)
    Next
    For iNdx = Len(hSearchString) To 1 Step -1
        sSearchStringBack = sSearchStringBack & Mid(hSearchString, iNdx, 1)
    Next
    iPos = InStr(sSourceStringBack, sSearchStringBack)
    If iPos > 0 Then iPos = iPos - 1
    sTmpResult = Left(sSourceStringBack, iPos)
    For iNdx = Len(sTmpResult) To 1 Step -1
        sTurnBack = sTurnBack & Mid(sTmpResult, iNdx, 1)
    Next
    StringRightBack = sTurnBack
 End Function

VB:

Option Explicit

'**********************************************************************
'* Vérifie si la feuille existe
'**********************************************************************
Public Function isWkExists(hWb As Workbook, hWKName As String) As Boolean
    Dim wkItem As Worksheet
    isWkExists = False
    For Each wkItem In hWb.Worksheets
        If UCase(wkItem.Name) = UCase(hWKName) Then
            isWkExists = True
            Exit For
        End If
    Next
End Function

'**********************************************************************
'* Enumère tous les objets du classeur actif
'**********************************************************************
Function enumWbListObjects(hWb As Workbook, Optional hToString As Boolean = -1, Optional hSep As String = " ") As Variant
    Dim objItem As ListObject
    Dim sName As String
    Dim vResult As Variant
    Dim wk As Worksheet
    Dim idx As Integer
    If hToString Then
        vResult = ""
    Else
        ReDim vResult(0)
    End If
    idx = -1
    For Each wk In hWb.Worksheets
        For Each objItem In wk.ListObjects
            If hToString Then
                vResult = vResult & hSep & objItem.Name
            Else
                idx = idx + 1
                ReDim Preserve vResult(idx)
                vResult(idx) = objItem.Name
            End If
        Next
    Next
    enumWbListObjects = vResult
End Function

'**********************************************************************
'* Vérifie si l'objet existe dans la feuille Worksheet
'**********************************************************************
Function isObjectExists(hWk As Worksheet, hObjame As String) As Boolean
    Dim objItem As Object
    isObjectExists = False
    For Each objItem In hWk.ListObjects
        If UCase(objItem.Name) = UCase(hObjame) Then
            isObjectExists = True
            Exit For
        End If
    Next
End Function

'**********************************************************************
'* Vérifie si l'objet existe dans le classeur
'**********************************************************************
Function isObjectWbExists(hWb As Workbook, hObjame As String) As Boolean
    Dim objItem As Object
    Dim wk As Worksheet
    isObjectWbExists = False
    For Each wk In hWb.Worksheets
        For Each objItem In wk.ListObjects
            If UCase(objItem.Name) = UCase(hObjame) Then
                isObjectWbExists = True
                Exit For
            End If
        Next
    Next
End Function

'*****************************************************************************
'* Vérifie si l'objet existe dans la feuille Worksheet en passant une chaine
'*****************************************************************************
Function isObjectWkStringExists(hWb As Workbook, hWk As String, hObjame As String) As Boolean
    Dim objItem As Object
    Dim oWk As Worksheet
    isObjectWkStringExists = False
    If isWkExists(hWb, hWk) Then
        Set oWk = hWb.Worksheets(hWk)
        For Each objItem In oWk.ListObjects
            If UCase(objItem.Name) = UCase(hObjame) Then
                isObjectWkStringExists = True
                Exit For
            End If
        Next
    End If
End Function

'**********************************************************************
'* Vérifie si le champ nommé existe
'**********************************************************************
Function isExistsRange(hRange As String) As Boolean
    Dim wb As Workbook
    Dim v As Name
    isExistsRange = False
    Set wb = ActiveWorkbook
    For Each v In wb.Names
        If v.Name = hRange Then
            isExistsRange = True
            Exit Function
        End If
    Next
End Function

'**********************************************************************
'* Enumère les requêtes de connexion dans une feuille
'**********************************************************************
Function enumWkQueriesConnection(hWk As Worksheet, Optional hPos As Integer = 11, Optional hToString As Boolean = -1) As Variant
    Dim oListObject As ListObject
    Dim oQueryTable As QueryTable
    Dim sName As String
    Dim vResult As Variant
    Dim idx As Integer
    If hToString Then
        vResult = ""
    Else
        ReDim vResult(0)
    End If
    idx = -1
    If hWk.ListObjects.Count > 0 Then
        For Each oListObject In hWk.ListObjects
            Set oQueryTable = Nothing
            On Error Resume Next
            Set oQueryTable = oListObject.QueryTable
            On Error GoTo -1
            If Not oQueryTable Is Nothing Then
                sName = hWk.Parent.Queries(Mid(oListObject.QueryTable.WorkbookConnection.Name, hPos)).Name
                If hToString Then
                    vResult = vResult & " " & sName
                Else
                    idx = idx + 1
                    ReDim Preserve vResult(idx)
                    vResult(idx) = sName
                End If
            End If
        Next
    End If
    enumWkQueriesConnection = vResult
End Function

'**********************************************************************
'* Enumère les requêtes de connexion dans un classeur
'**********************************************************************
Function enumWbWkQueriesConnection(hWb As Workbook, Optional hPos As Integer = 11, Optional hToString As Boolean = -1, Optional hSep As String = " ") As Variant
    Dim oListObject As ListObject
    Dim oQueryTable As QueryTable
    Dim wk As Worksheet
    Dim sName As String
    Dim sfullname
    Dim vResult As Variant
    Dim idx As Integer
    If hToString Then
        vResult = ""
    Else
        ReDim vResult(0)
    End If
    idx = -1
    For Each wk In hWb.Worksheets
        If wk.ListObjects.Count > 0 Then
            For Each oListObject In wk.ListObjects
                Set oQueryTable = Nothing
                On Error Resume Next
                Set oQueryTable = oListObject.QueryTable
                On Error GoTo -1
                If Not oQueryTable Is Nothing Then
                    sfullname = oListObject.QueryTable.WorkbookConnection.Name
                    sName = wk.Parent.Queries(Mid(oListObject.QueryTable.WorkbookConnection.Name, hPos)).Name
                    If hToString Then
                        vResult = vResult & hSep & sName & " (" & sfullname & ")"
                    Else
                        idx = idx + 1
                        ReDim Preserve vResult(idx)
                        vResult(idx) = sName
                    End If
                End If
            Next
        End If
    Next
    enumWbWkQueriesConnection = vResult
End Function

'**********************************************************************
'* Vérifie si la requête PowerQuery Existe
'**********************************************************************
Function isExistsWbWorkbookQuery(hWb As Workbook, hName As String) As Boolean
    Dim oWbQuery As WorkbookQuery
    isExistsWbWorkbookQuery = False
    For Each oWbQuery In hWb.Queries
        If hName = oWbQuery.Name Then
            isExistsWbWorkbookQuery = True
            Exit For
        End If
    Next
End Function

'**********************************************************************
'* Vérifie si le tableau a requête PowerQuery
'**********************************************************************
Function isExistsQueryTable(hWb As Workbook, hWk As String, hQueryTable As String) As Boolean
    Dim oListObject As ListObject
    Dim oQueryTable As QueryTable
    Dim wk As Worksheet
    isExistsQueryTable = False
    Set oQueryTable = Nothing
    Set oListObject = Nothing
    If isWkExists(hWb, hWk) Then
        Set wk = hWb.Worksheets(hWk)
        If isObjectExists(wk, hQueryTable) Then
            Set oListObject = ThisWorkbook.Worksheets(hWk).ListObjects(hQueryTable)
            On Error Resume Next
            Set oQueryTable = oListObject.QueryTable
            If Not oQueryTable Is Nothing Then
                isExistsQueryTable = True
            End If
        End If
    End If
    On Error GoTo -1
End Function

'**********************************************************************
'* On vérifie si le fichier existe
'**********************************************************************
Function isFileExists(szFile As String) As Boolean
    Dim oFSO As Object
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    isFileExists = oFSO.FileExists(szFile)
End Function

'**********************************************************************
'* On vérifie si le dossier existe
'**********************************************************************
Function isFolderExists(szFolder As String)
    Dim oFSO As Object
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    isFolderExists = oFSO.FolderExists(szFolder)
End Function

'**********************************************************************
'* On vérifie si le dossier existe - autre méthode
'**********************************************************************
Function isFolderExists2(sDossier As String)
    If sDossier <> "" And Len(Dir(sDossier, vbDirectory)) > 0 Then
       isFolderExists2 = True
    Else
       isFolderExists2 = False
    End If
End Function

'**********************************************************************
'* On vérifie si le TCD existe dans le classeur
'**********************************************************************
Function isTCDWbExists(hWb As Workbook, hTCD As String)
    Dim oPivotTable As PivotTable
    Dim wk As Worksheet
    isTCDWbExists = False
    For Each wk In hWb.Worksheets
        For Each oPivotTable In wk.PivotTables
            If UCase(oPivotTable.Name) = UCase(hTCD) Then
                isTCDWbExists = True
                Exit For
            End If
        Next
    Next
End Function

'**********************************************************************
'* On vérifie si la shape existe dans le classeur
'**********************************************************************
Function isShapeWbExists(hWb As Workbook, hShape As String)
    Dim oShape As Shape
    Dim wk As Worksheet
    isShapeWbExists = False
    For Each wk In hWb.Worksheets
        For Each oShape In wk.Shapes
            If oShape.Name = hShape Then
                isShapeWbExists = True
                Exit For
            End If
        Next
    Next
End Function

'**********************************************************************
'* On vérifie si le graph existe dans le classeur
'**********************************************************************
Function isChartObjectWbExists(hWb As Workbook, hChart As String)
    Dim oChartObject As ChartObject
    Dim wk As Worksheet
    isChartObjectWbExists = False
    For Each wk In hWb.Worksheets
        For Each oChartObject In wk.ChartObjects
            If oChartObject.Name = hChart Then
                isChartObjectWbExists = True
                Exit For
            End If
        Next
    Next
End Function

Effectuez une recherche sur Excel Downloads...

EXCEL :: CLASS_LIBRARY_TOOLS_V1.0 - Classes utilitaires - Fichier Log, Gestion de pile d'exécution, isExists, Paramètres, Collection, Dictionnaire

oguruma

XLDnaute Impliqué

Pièces jointes

Discussions similaires

Nous accordons de l'importance à votre vie privée