Le portail francophone de la géomatique

Private Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

Public Enum NetWork
    WithNetworkFolders = 0
    WithoutNetworkFolders = 2
End Enum

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
    Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
    ByVal pszPath As String) As Long

Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
    Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
    As Long
    

Const BIF_RETURNONLYFSDIRS = &H1
Const BIF_USENEWUI = &H40


'Déclaration globale des variables
Dim colRep As New Collection
Dim colFich As New Collection
Dim scurfich As String
Dim scurdoss As String




'----------------------------------------------------------------
Public Sub Main()
    Dim chemin As String
    
    chemin = SelectFolder("C:\", WithNetworkFolders)
    scanneArborescence (chemin)

End Sub


Public Sub scanneArborescence(chemin As String)

Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")

Debug.Print chemin

'fichier racine du répertoire
For Each fichier In fso.getFolder(chemin).files
    'Si extension = .shp on ajoute à la collection
    scurfich = fichier
    If Right(GetFilename(scurfich), 4) = ".shp" Then Addshapelayer GetRepname(scurfich), GetFilename(scurfich)
Next

'dossier racine
For Each dossier In fso.getFolder(chemin).SubFolders
    scurdoss = dossier
    RecurSubFolder scurdoss
Next

Set fso = Nothing

End Sub



'Récupère le nom d'un fichier dans un chemin
Function GetFilename(fichier As String) As String

    'Position du dernier '\' qui va déterminer la position du nom du fichier
    Dim pos As Integer
    pos = InStrRev(fichier, "\")
   
    GetFilename = Mid$(fichier, pos + 1, Len(fichier))

End Function



'Récupère le chemin
Function GetRepname(fichier As String) As String

    'Position du dernier '\' qui va déterminer la position du nom du fichier
    Dim pos As Integer
    pos = InStrRev(fichier, "\")
   
    GetRepname = Mid$(fichier, 1, pos)

End Function



'Méthode récursive qui parcours les dossiers, sous-dossiers....
Sub RecurSubFolder(Folder As String)

    On Error Resume Next    'Juste au cas ou l'accès à un dossier serait refusé.

    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
   
    'Parcourt les fichiers du dossier courant
    For Each fichier In fso.getFolder(Folder).files
        'Si extension = .shp on ajoute à la collection
        scurfich = fichier
    If Right(GetFilename(scurfich), 4) = ".shp" Then Addshapelayer GetRepname(scurfich), GetFilename(scurfich)
    Next
   
    'Idem pour les dossiers sauf si il n'y a pas de sous-dossiers
    If fso.getFolder(Folder).SubFolders.Count <> 0 Then
        For Each dossier In fso.getFolder(Folder).SubFolders
            scurdoss = dossier
            RecurSubFolder (dossier)
        Next
    End If

End Sub



Public Function SelectFolder(Optional Folder As String = "" _
           , Optional NetWorkFolders As NetWork = WithNetworkFolders _
           ) As String
    Dim X As Long, bi As BROWSEINFO, dwIList As Long
    Dim szPath As String, wPos As Integer
    If Folder = "" Then Folder = CurrentProject.Path
    With bi
        .hOwner = hWndAccessApp
        .lpszTitle = "Sélectionnez votre dossier à scanner et cliquez sur OK"
        .ulFlags = BIF_RETURNONLYFSDIRS _
            Or BIF_USENEWUI _
            Or NetWorkFolders
    End With
    dwIList = SHBrowseForFolder(bi)
    szPath = Folder & Space$(512 - Len(Folder))
    X = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)
    If X Then
        wPos = InStr(szPath, Chr(0))
        SelectFolder = Left$(szPath, wPos - 1)
    Else
        SelectFolder = ""
    End If
End Function



' Ajout d'une couche SHP a la carte
' IN : ShpPath : Chemin complet du dossier  ex :  h:Temp
'      ShpName : Nom de la couche ex :  monshape.shp
Public Sub Addshapelayer(ShpPath As String, ShpName As String)

Debug.Print "ShpPath : " & ShpPath
Debug.Print "ShpName : " & ShpName

' declaration du document
Dim pMxDoc As IMxDocument
Set pMxDoc = ThisDocument

' declaration de l'espace de travail : shape
Dim pWorkspaceFactory As IWorkspaceFactory
Set pWorkspaceFactory = New ShapefileWorkspaceFactory

' ouverture de l'espace de travail
Dim pWorkspace As IFeatureWorkspace         ' path du dossier
Set pWorkspace = pWorkspaceFactory.OpenFromFile(ShpPath, 0)

' ouverture du shape
Dim pClass As IFeatureClass         'nom de la couche
Set pClass = pWorkspace.OpenFeatureClass(ShpName)

' declaration d'une couche d'entite
Dim pLayer As IFeatureLayer
Set pLayer = New FeatureLayer

' affectation du shape a cette couche
Set pLayer.FeatureClass = pClass
pLayer.Name = pClass.AliasName

'-affichage de cette couche
pMxDoc.AddLayer pLayer

' reactualisation de l'affichage
pMxDoc.ActiveView.PartialRefresh esriViewGeography, pLayer, Nothing
End Sub