XL 2016 VBA - Trouver les feuilles d'un classeur fermé

Function ADONameToExcel(adoName As String) As String
    .../...
    ' Remplacements spécifiques faits par ADO
    nom = Replace(nom, "#", ".") ' le point devient #
    nom = Replace(nom, "_", "!") ' le point d’exclamation devient

' https://analystcave.com/vba-xml-working-xml-files/
Sub ListSheetNames()
' Chemin :
    Dim origPath As String
    Dim origFich As String
    Dim zipPath As String
' Créer une instance de Shell.Application
    Dim shellApp As Object
' Ouvrir le fichier .zip comme un fichier ZIP
    Dim zip As Object
' Parcourir les éléments pour trouver le dossier "xl"
    Dim item As Object
' Parcourir les éléments dans "xl" pour trouver workbook.xml
    Dim subItem As Object
' Extraire workbook.xml dans TEMP
    Dim xmlFile As String
' Charger le document XML
    Dim XDoc As Object
    Dim xmlContent As Object
' Collecte des nom des Feuilles
    Dim sheetNames As Collection
    Dim sheetName As Variant
    Dim startPos As Long, endPos As Long
    Dim cheminFich As String
' -----------------------------------------------------------------------------

    ' Chemin du fichier XLSX
    origPath = "C:\Users\VotreChemin\LeDossier\"
    origFich = "LeFichier.xlsx"
    zipPath = origPath & origFich & ".zip"

    ' Renommer temporairement en .zip
    Name origPath & origFich As zipPath

    ' Créer une instance de Shell.Application
    Set shellApp = CreateObject("Shell.Application")

    ' Ouvrir le fichier .zip comme un fichier ZIP
    Set zip = shellApp.Namespace(CStr(zipPath))

    ' Vérifier si le fichier ZIP a été ouvert correctement
    If Not zip Is Nothing Then
        ' Parcourir les éléments pour trouver le dossier "xl"
        For Each item In zip.Items
            If item.Name = "xl" Then
                ' Parcourir les éléments dans "xl" pour trouver workbook.xml
                For Each subItem In item.GetFolder.Items
                    If InStr(subItem.Name, "workbook.xml") > 0 Then
                        ' Extraire workbook.xml dans TEMP
                            'xmlFile = Environ("TEMP") & "\workbook.xml"
                            'xmlFile = origPath & CStr(subItem.Name)
                            xmlFile = Environ("TEMP") & "\" & CStr(subItem.Name)
                            ' Copie effective depuis le ZIP vers TEMP
                            shellApp.Namespace(Environ("TEMP")).CopyHere subItem
                            ' CopyHere fait l’extraction asynchrone, donc il faut attendre que le fichier apparaisse dans TEMP avant de le lire :
                            Do While Dir(xmlFile) = ""
                                DoEvents
                            Loop
                        ' Lire le contenu XML
                            Set XDoc = CreateObject("MSXML2.DOMDocument")
                                XDoc.async = False: XDoc.validateOnParse = False
                                'XDoc.Load (ThisWorkbook.Path & "\workbook.xml")
                                'XDoc.Load (origPath & CStr(subItem.Name))
                                XDoc.Load (xmlFile)
                        'Get Document Elements
                            Set xmlContent = XDoc.DocumentElement
                                'MsgBox xmlContent.XML
                        Exit For
                    End If
                Next subItem
                Exit For
            End If
        Next item
    End If

    ' Extraire les noms des feuilles
    Set sheetNames = New Collection
    If Len(xmlContent.XML) > 0 Then
        startPos = InStr(1, xmlContent.XML, "<sheet name=""")
        Do While startPos > 0
            startPos = startPos + Len("<sheet name=""")
            endPos = InStr(startPos, xmlContent.XML, """")
            sheetName = Mid(xmlContent.XML, startPos, endPos - startPos)
            sheetNames.Add sheetName
            startPos = InStr(endPos, xmlContent.XML, "<sheet name=""")
        Loop
    End If

    ' Afficher les noms des feuilles
    For Each sheetName In sheetNames
        Debug.Print sheetName
        Affichage = Affichage & (i + 1) & " - " & sheetName & vbCrLf
    Next sheetName

    ' Remettre le fichier à son nom d'origine
    Name zipPath As origPath & origFich
    
    ' Resultat
    MsgBox Affichage
    
    Set XDoc = Nothing ' Libère le XML
    If Dir(xmlFile) <> "" Then Kill xmlFile
    
End Sub

If InStr(subItem.Name, "workbook.xml") > 0 Then
        ' Extraire workbook.xml dans TEMP
            xmlFile = Environ("TEMP") & "\" & CStr(subItem.Name)
            ' Copie effective depuis le ZIP vers TEMP
                shellApp.Namespace(Environ("TEMP")).CopyHere subItem
            ' CopyHere fait l’extraction asynchrone, donc il faut attendre que le fichier apparaisse dans TEMP avant de le lire :
                Do While Dir(xmlFile) = ""
                    DoEvents
                Loop
            ' Lire le contenu XML
                Set XDoc = CreateObject("MSXML2.DOMDocument")
                    XDoc.async = False: XDoc.validateOnParse = False
                    XDoc.Load (xmlFile)
            'Get Document Elements
                Set xmlContent = XDoc.DocumentElement
                'MsgBox xmlContent.XML
    Exit For
    End If

originalXLX="chemin du fichier xls*"

fichierZIP=lememe avec l'extension ".zip"

xmlFile = Environ("TEMP") & "\workbook.xml"

filecopy originalXLX , fichierZIP

Set shellApp = CreateObject("Shell.Application")

set f=shellApp.Namespace(fichierZIP &"\xl").items.item("workbook.xlm")

shellApp.Namespace(Environ("TEMP")&"\").copyhere f.path

'ton xml est dans le environ(temp)

' https://analystcave.com/vba-xml-working-xml-files/
Sub ListSheetNames_MiseAJoursObtimisé()
' Chemin :
    Dim origPath As String
    Dim origFich As String
    Dim zipPath As String
' Créer une instance de Shell.Application
    Dim shellApp As Object
' Ouvrir le fichier .zip comme un fichier ZIP
    Dim zip As Object
' Parcourir les éléments pour trouver le dossier "xl"
    Dim item As Object
' Parcourir les éléments dans "xl" pour trouver workbook.xml
    Dim subItem As Object
' Extraire workbook.xml dans TEMP
    Dim xmlFile As String
' Charger le document XML
    Dim XDoc As Object
    Dim xmlContent As Object
' Collecte des nom des Feuilles
    Dim sheetNames As Collection
    Dim sheetName As Variant
    Dim startPos As Long, endPos As Long
    Dim cheminFich As String
' -------------------------------------------------------------------
' Extraire les noms des feuilles
    Dim node As Object
' Optimisé : utiliser tableau + Join pour vitesse si beaucoup de feuilles
    Dim arr() As String
    Dim Affichage As String
    Dim i As Long
' Initialisation des variables
    Affichage = ""
    i = 0
' -------------------------------------------------------------------

' Chemin du fichier XLSX
   origPath = "C:\Users\LeChemin\LeDossier\"
   origFich = "LeFichier.xlsx"
   zipPath = origPath & origFich & ".zip"

' Renommer temporairement en .zip
   Name origPath & origFich As zipPath

' Créer une instance de Shell.Application
   Set shellApp = CreateObject("Shell.Application")

' Ouvrir le fichier .zip comme un fichier ZIP
   Set zip = shellApp.Namespace(CStr(zipPath))

If Not zip Is Nothing Then
    ' Parcourir les éléments pour trouver le dossier "xl"
    For Each item In zip.Items
        If item.Name = "xl" Then
            ' Parcourir les éléments dans "xl" pour trouver workbook.xml
            For Each subItem In item.GetFolder.Items
                If InStr(subItem.Name, "workbook.xml") > 0 Then
                    ' Extraire workbook.xml dans TEMP
                        xmlFile = Environ("TEMP") & "\" & CStr(subItem.Name)
                        shellApp.Namespace(Environ("TEMP")).CopyHere subItem
                        Do While Dir(xmlFile) = "": DoEvents: Loop
                    ' Lire le contenu XML
                        Set XDoc = CreateObject("MSXML2.DOMDocument")
                            XDoc.async = False
                            XDoc.validateOnParse = False
                            XDoc.Load xmlFile  ' ? Optimisé : chemin correct
                        Set xmlContent = XDoc.DocumentElement
                    Exit For
                End If
            Next subItem
            Exit For
        End If
    Next item
End If

' -------------------------------------------------------------------
' Extraire les noms des feuilles
    Set sheetNames = New Collection
    If Len(xmlContent.XML) > 0 Then
    ' ? Optimisé : Parsing DOM plus rapide et sûr
        For Each node In xmlContent.getElementsByTagName("sheet")
            sheetNames.Add node.getAttribute("name")
        Next node
    End If

' -------------------------------------------------------------------
' Afficher les noms des feuilles
' ? Optimisé : utiliser tableau + Join pour vitesse si beaucoup de feuilles
    ReDim arr(1 To sheetNames.Count)
    i = 1
    For Each sheetName In sheetNames
        arr(i) = sheetName
        i = i + 1
    Next sheetName
    Affichage = Join(arr, vbCrLf)
    Debug.Print Affichage

' Remettre le fichier à son nom d'origine
    Name zipPath As origPath & origFich

' Résultat
    MsgBox Affichage

' Libération et suppression TEMP
    Set XDoc = Nothing
    If Dir(xmlFile) <> "" Then Kill xmlFile
End Sub

Sub ListSheetNames_MiseAJourSimplifié()
    ' -------------------------------------------------------------------
    ' Objectif : lister les noms des feuilles d'un fichier XLSX
    ' Méthode : copier le fichier en .zip temporaire, extraire workbook.xml
    ' -------------------------------------------------------------------

    Dim origPath As String, origFich As String
    Dim originalXLSX As String, fichierZIP As String
    Dim xmlFile As String
    Dim shellApp As Object, f As Object
    Dim XDoc As Object, xmlContent As Object
    Dim sheetNames As Collection, node As Object
    Dim arr() As String, Affichage As String
    Dim i As Long
    Dim sheetName As Variant

    ' -------------------------------------------------------------------
    ' Chemin du fichier XLSX
    origPath = "C:\Users\VotreChemin\LeDossier\"
    origFich = "LeFichier.xlsx"
    originalXLSX = origPath & origFich
    fichierZIP = Environ("TEMP") & "\tempFile.zip"

    ' Copier le fichier XLSX en ZIP temporaire
    FileCopy originalXLSX, fichierZIP

    ' -------------------------------------------------------------------
    ' Extraire workbook.xml
    xmlFile = Environ("TEMP") & "\workbook.xml"
    Set shellApp = CreateObject("Shell.Application")
    ' Pointer directement sur workbook.xml dans le ZIP
    Set f = shellApp.Namespace(fichierZIP & "\xl").Items.item("workbook.xml")
    shellApp.Namespace(Environ("TEMP") & "\").CopyHere f.Path

    ' Attendre que le fichier soit copié
    Do While Dir(xmlFile) = "": DoEvents: Loop

    ' -------------------------------------------------------------------
    ' Charger le XML
    Set XDoc = CreateObject("MSXML2.DOMDocument")
    XDoc.async = False
    XDoc.validateOnParse = False
    XDoc.Load xmlFile
    Set xmlContent = XDoc.DocumentElement

    ' -------------------------------------------------------------------
    ' Extraire les noms des feuilles
    Set sheetNames = New Collection
    For Each node In xmlContent.getElementsByTagName("sheet")
        sheetNames.Add node.getAttribute("name")
    Next node

    ' -------------------------------------------------------------------
    ' Préparer l'affichage
    ReDim arr(1 To sheetNames.Count)
    i = 1
    For Each sheetName In sheetNames
        arr(i) = sheetName
        i = i + 1
    Next sheetName
    Affichage = Join(arr, vbCrLf)

    ' Afficher le résultat
    Debug.Print Affichage
    MsgBox Affichage

    ' -------------------------------------------------------------------
    ' Nettoyage
    Set XDoc = Nothing
    Set shellApp = Nothing
    If Dir(xmlFile) <> "" Then Kill xmlFile
    If Dir(fichierZIP) <> "" Then Kill fichierZIP

End Sub