Classe Directory

'
' clsDirec : classe Directory
'
' Permet de manipuler des repertoires
'
' Auteur: ChF
'
' Property
'    Name   : nom du repertoire
'    Path   : Chemin complet
'    SmallPath : Chemin d'acces au repertoire
'
' Méthodes
'    Create : Cree l'objet
'    Destroy    : Détruit l'objet
'    fOpen  : Selection d'un repertoire via une bdial standanrd
'    fDelete    : supprime le repertoire
'    fMake : Cree un nouveau repertoire
'    fExplore : Explore le repertoire avec l'Explorateur W$

Option Compare Database
Option Explicit
Private clsHwnd As Long
Private clsPath As String
Private clsName As String
Private clsSmallPath As String

'************************************************
'API SHBrowseForFolder: recherche d'un répertoire
'************************************************
Private Type udtBROWSEINFO
    hWndOwner As Long
    pidlRoot As Long
    pszDisplayName As Long
    lpszTitle As Long
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

Private Const BIF_RETURNONLYFSDIRS = 1
Private Const MAX_PATH = 260

Private Declare Sub API_CoTaskMemFree Lib "ole32.dll" Alias "CoTaskMemFree" (ByVal hMem As Long)
Private Declare Function API_lstrCat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function API_SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolder" (lpbi As udtBROWSEINFO) As Long
Private Declare Function API_SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDList" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Public Property Get Path() As String
    Path = clsPath
End Property
Public Property Let Path(Value As String)
    If Left(Value, Len(Value) - 1) <> "\" Then
        Value = Value & "\"
    End If
    clsPath = Value
    sAffectNameAndPath
End Property
Public Property Let Name(Value As String)
Dim od As New clsDirectory
    With od
        .Path = Value
        '
        'Test si le repertoire d'acces a change ou si pas de repertoire dans nouveau nom
        '
        If .SmallPath = clsSmallPath Or Len(.SmallPath) = 0 Then
            '
            ' Si non le nom et recree le clspath
            '
            clsName = Value
            If Left(clsName, 1) = "\" Then clsName = Mid(clsName, 2)
            clsPath = clsSmallPath & clsName
            If Mid(clsPath, Len(clsPath), 1) <> "\" Then
                clsPath = clsPath & "\"
            End If
        Else
            '
            ' Si oui, on considere que c'est clsPAth qui change
            '
            Path = Value
        End If
    End With
    Set od = Nothing
End Property
Public Property Get Name() As String
    Name = clsName
End Property
Public Function Create(Optional strPath As String = "") As Boolean
    Create = True
    Path = strPath
End Function
Public Property Get SmallPath() As String
    SmallPath = clsSmallPath
End Property
Public Function Destroy() As Boolean
    Destroy = True
End Function
Public Function fMake() As Boolean
'Purpose    : Create a new folder named clsPath
'Inputs     :
'Assumes    :
'Returns    : True =>Ok
'             False => not OK, plus Err is set
'Effects    : a new folder is created

    On Error Resume Next
    MkDir Path
    If Err <> 0 Then
        fMake = False
    Else
        fMake = True
    End If
    On Error GoTo 0
End Function
Public Function fDelete() As Boolean
'Purpose    : Delete de folder
'Inputs     :
'Assumes    :
'Returns    : True =>Ok
'             False => not OK, plus Err is set
'Effects    : the folder is deleted

    On Error Resume Next
    RmDir Path
    If Err <> 0 Then
        fDelete = False
    Else
        fDelete = True
    End If
    On Error GoTo 0
End Function
Public Function fOpen(sPrompt As String)
'Purpose    : Select a directory (or folder) using a Windows standard dialog box
'Inputs     : strPrompt : Message show in the dialog box
'Assumes    :
'Returns    :
'Effects    : clsPath and clsName are modified

Dim iNull As Integer
Dim lpidList As Long
Dim lResult As Long
Dim sPath As String
Dim udtBI As udtBROWSEINFO

    With udtBI
        .hWndOwner = clsHwnd
        .lpszTitle = API_lstrCat(sPrompt, "")
        .ulFlags = BIF_RETURNONLYFSDIRS
    End With

    lpidList = API_SHBrowseForFolder(udtBI)
    If lpidList Then
        sPath = String$(MAX_PATH, 0)
        lResult = API_SHGetPathFromIDList(lpidList, sPath)
        Call API_CoTaskMemFree(lpidList)
        iNull = InStr(sPath, vbNullChar)
        If iNull Then
            sPath = Left$(sPath, iNull - 1)
        End If
    End If
    Path = sPath
End Function

Public Function fExplore(Optional opt As Long = d_ExploreDefault)
'Purpose    : Open in a new window an instance of the windows explorer
'Inputs     : optional Opt = d_ExploreDefaut (default value) to open the explorer with the focus on clsPath
'                            d_ExploreFrom to open the explorer with the root falg set on clsPath
'Assumes    :
'Returns    :
'Effects    :
Dim of As New clsFile
    With of
        .Name = "Explorer"
        If (opt And d_ExploreDefault) = d_ExploreDefault Then
            .Execute "/n,/e," & Path
        ElseIf (opt And d_ExploreFrom) = d_ExploreFrom Then
            .Execute "/n,/e,/root," & Path
        End If
    End With
    
End Function
Private Sub sAffectNameAndPath()
Dim s As New clsString
Dim p As New clsString

    With s
        .Value = clsPath
        .Value = .Reverse
        If .index("\", 2) <> 0 Then
            p.Value = .subStr(2, .index("\", 2) - 2)
            clsName = p.Reverse
            p.Value = .subStr(.index("\", 2))
            clsSmallPath = p.Reverse
            If clsSmallPath = "\" Then clsSmallPath = ""
        Else
            clsName = .Value
            clsSmallPath = ""
        End If
    End With
    Set p = Nothing
    Set s = Nothing
End Sub