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

[vtemma]

Bonjour,
Aujourd'hui, j'accède à mes répertoires via la Macro suivante.

Les données que nous avons vont-être déplacées et seront accessibles via un serveur Webdav donc une URL.

Lorsque je remplace Dossier = "https:/adresse.com/" : j'ai une erreur d'exécution le répertoire.

Je cherche une façon de mettre à jour mon code pour donner la nouvelle adresse et que mon programme fonctionne toujours.

Sub recup_donnee()
Dim Dossier As String

'Définit le répertoire pour débuter la recherche de fichiers.
'(Attention à ne pas indiquer un répertoire qui contient trop de sous-dossiers ou de
'fichiers, sinon le temps de traitement va être très long).
Dossier = "C:\TEST\"

'Appelle la procédure de recherche des fichiers
ListeFichiers Dossier

MsgBox "import terminé"

End Sub

Sub ListeFichiers(Repertoire As String)
'
'Nécessite d'activer la référence "Microsoft Scripting RunTime"
'Dans l'éditeur de macros (Alt+F11):
'Menu Outils
'Références
'Cochez la ligne "Microsoft Scripting RunTime".
'Cliquez sur le bouton OK pour valider.

Dim Fso As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim chemin As String
Dim i As Long

Set Fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = Fso.GetFolder(Repertoire)

'Boucle sur tous les fichiers du répertoire
For Each FileItem In SourceFolder.Files
If Mid(FileItem.Name, 1, 18) = "TOTO" Then
chemin = FileItem.ParentFolder & "\" & FileItem.Name
Call ImportDonnee(chemin)
End If
Next FileItem


'--- Appel récursif pour lister les fichier dans les sous-répertoires ---.
For Each SubFolder In SourceFolder.SubFolders
ListeFichiers SubFolder.Path
Next SubFolder

End Sub

 

[fanch55]

Bonsoir,
Testez avec le code ci-joint à placer dans un module
La sub à lancer est ScanWebDav après avoir renseigné les paramètres .
Nota: cela suppose que le lanceur possède les droits de déclarer un Lecteur réseau

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

 

[vtemma]

Bonjour, Merci pour cette piste mais ça revient à dire qu'il n'est pas possible de parcourir des répertoires autrement qu'avec un disque monté.

 

[fanch55]

Bonjour,
Sans disque monté grace à XMLHTTP.
Vous trouverez dans le module Mod_Webdav
TestLst : lister les fichiers
TestGet: télécharger un fichier

Pour le fun :
Feuille "Folder List" : explorer le Serveur,
double-clic sur un des répertoires en jaune pour scanner celui-ci

Bémol:
mon Webdav est un serveur Apache sous Unix/Linux
un serveur windows IIS peut avoir une structure différente .