Microsoft 365 Recherche de répertoire à partir d'une URL

Option Explicit
Dim oMappedDrive    As Object
Dim oFSO            As Object
Dim oNetwork        As Object
Dim sServer         As String
Dim sPort           As String
Dim Last_Row        As Double
Dim Max_Folders     As Integer


Sub ScanWebDav()
Dim I               As Double
Dim sLetter         As String
Dim sDossier        As String
Dim sUrl            As String
Dim sUser           As String
Dim sPsw            As String
    
 Max_Folders = 5 ' Nombre Max de dossiers à développer dans l'arborescence
     sServer = "Mon.serveur.WebDav"
       sPort = "5006"
    sDossier = "/" & "Dossier_Initial_où_démarrer" ' ou rien
       sUser = "__Utilisateur___"
        sPsw = "__Mot_De_Passe__"
        
        sUrl = "https://" & sServer & ":" & sPort & sDossier
    
    Set oFSO = CreateObject("Scripting.FileSystemObject")
        Set oNetwork = CreateObject("WScript.Network")
            Application.Cursor = xlWait
            Remove_Drive
            For I = Asc("Z") To Asc("A") Step -1
                sLetter = Chr(I)
                If Not oFSO.DriveExists(sLetter) Then
                  oNetwork.MapNetworkDrive sLetter & ":", sUrl, False, sUser, sPsw
                  Set oMappedDrive = oFSO.GetDrive(sLetter)
                  Exit For
                End If
            Next I
            
            Application.ScreenUpdating = False
            Cells.Clear
            Columns.ColumnWidth = 1
            Cells.HorizontalAlignment = xlLeft
            Cells.VerticalAlignment = xlCenter

            Last_Row = 0
                ListOf oMappedDrive.rootfolder, 1, 0
            
            With Cells(Last_Row + 1, 1).Resize(, 2 + (Max_Folders * 2))
                .Resize(, 2).Value = Array(ChrW(&H2126), "Fin de liste")
                .Interior.Color = 11892015
                .Font.Color = vbWhite
            End With
            Columns.AutoFit
            
            Application.Cursor = xlDefault
            Select Case MsgBox("Scan terminé" & vbLf & _
                                "Dernière ligne: " & Last_Row & vbLf & vbLf & _
                                "Voulez-vous aller à celle-ci", vbInformation + vbYesNo)
                Case vbYes:     Application.Goto Cells(Last_Row, 1), True
                Case Else:      Application.Goto Cells(1, 1), True
            End Select
            
            Remove_Drive
            
            Set oMappedDrive = Nothing
        Set oNetwork = Nothing
    Set oFSO = Nothing

End Sub
Sub ListOf(Espace As Object, C As Double, NFolders As Double)
Dim Save_Column     As Double
Dim Save_NFolders   As Double
Dim Elem            As Object

    Save_Column = C
    Save_NFolders = NFolders
    
    For Each Elem In Espace.SubFolders ' Liste des Dossiers
        If Not Elem.Name Like "[#]*" Then ' Généralement un dossier #Recycle
            Last_Row = Last_Row + 1
            With Cells(Last_Row, C)
                .Font.Name = "WingDings"
                .Value = "0"
                .Interior.Color = 11389944
            End With
            With Cells(Last_Row, C + 1)
                .Value = Elem.Name
                .Borders.LineStyle = xlContinuous
            End With
            If NFolders < Max_Folders Then
                Last_Row = Last_Row - 1
                    ListOf Elem, C + 2, NFolders + 1
                C = Save_Column
                NFolders = Save_NFolders
            End If
        End If
    Next
    
    For Each Elem In Espace.files ' Liste des fichiers
        Last_Row = Last_Row + 1
        Cells(Last_Row, C + 1) = Elem.Name
    Next

End Sub
Sub Remove_Drive()
Dim Drv As Object
For Each Drv In oFSO.drives
    If Drv.isready Then
        If Drv.ShareName Like "*" & sServer & "*" _
        And Drv.ShareName Like "*" & sPort & "*" Then
            oNetwork.RemoveNetworkDrive Drv, True, True
        End If
    End If
Next
End Sub