Views

VBA Access - Criando estrutura de Diretórios, Aninhados, Na Rede - Create Directory Structure/Create Multiple Directories/Create Nested Directories






Um dos métodos mais comuns para a criação de diretórios e pastas com o VBA  é usando a instrução MkDir:

MkDir "C:\Bernardes\"

Só que ao se utilizar esta técnica, aprende-se rapidamente as limitações dela. Uma destas é ter de criar uma estrutura de diretório com múltiplas sub-pastas. MkDir só pode criar um diretório num momento, não podendo criar um sub-diretório. 


Assim, supondo que 'C:\Bernardes' não exista, o comando seguinte não iria funcionar e retornará um erro!

MkDir "C:\Bernardes\Luiz"

Se realmente desejar criar essa estrutura usando a instrução MkDir, terá que fazê-lo usando a declaração MkDir duas vezes. Por exemplo:

MkDir "C:\Bernardes"
MkDir "C:\Bernardes\Luiz"

Agora, se você precisa apenas criar 1 ou 2 sub-pasta, talvez o  MkDir ainda seja aceitável, mas há casos em que isso é simplesmente impraticável e outra solução precise ser encontrada. 


Uma possível abordagem pode ser encontrada Criando Diretórios Aninhados (Procure esta solução neste Blog).

Outra abordagem possível é a utilização de uma API simples que pode criar vários diretórios com uma chamada.

Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long

Public Sub MakeFullDir (strPath As String)
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\" 'Optional depending upon intent
    MakeSureDirectoryPathExists strPath
End Sub

Ainda outra solução possível, caso alguém queira mexer um pouco mais, seria analisar o caminho do diretório e avaliar o uso da instrução DIR, criando os diretórios onde precisam estar.

Public Sub MyMkDir (sPath As String)
    Dim iStart          As Integer
    Dim aDirs           As Variant
    Dim sCurDir         As String
    Dim i               As Integer
    If sPath <> "" Then
        aDirs = Split(sPath, "\")
        If Left(sPath, 2) = "\\" Then
            iStart = 3
        Else
            iStart = 1
        End If
        sCurDir = Left(sPath, InStr(iStart, sPath, "\"))
        For i = iStart To UBound(aDirs)
            sCurDir = sCurDir & aDirs(i) & "\"
            If Dir(sCurDir, vbDirectory) = vbNullString Then
                MkDir sCurDir
            End If
        Next i
    End If
End Sub

Veja abaixo a descrição de um procedimento chamado MakeMultiStepDirectory. Este é um código esteticamente mais limpo.

Pode ser usado com referência a diretórios e endereços UNC.


Também pode chamar MakeMultiStepDirectory passando o caminho do diretório inteiro e ele vai automaticamente criar todos os diretórios necessários intermediários.

MakeMultiStepDirectory C:\MyApplication\Settings\Templates\VB

A função MakeMultiStepDirectory pode criar diretórios tanto na máquina local (C:\MyApplication\Settings\Templates\VB), uma unidade mapeada ou um compartilhamento de rede UNC (\\BlackCow\MainShare\MyApplication\Settings\Templates\VB). 

Note que a função não pode criar um compartilhamento (Share); o compartilhamento já deve existir e, claro, você deve ter permissões para criar diretórios nele.

A função MakeMultiStepDirectory faz uso do Scripting.FileSystemObject, desse modo o seu projeto vai precisar fazer uma referência à biblioteca Microsoft Scripting Runtime. 

No VBA com seu projeto aberto, vá ao menu Ferramentas, escolha referências e desça até você encontrar o Microsoft Scripting Runtime Library. Marque a caixa próxima a esta entrada.

A função MakeMultiStepDirectory retorna valores que estão listados em Enum um chamado a EMakeDirStatus, definido no módulo. Esta enumeração é como se segue:
     Public Enum EMakeDirStatus

         ErrSuccess = 0

         ErrRelativePath

         ErrInvalidPathSpecification

         ErrDirectoryCreateError

         ErrSpecIsFileName

         ErrInvalidCharactersInPath

     end Enum

Onde

ErrSuccess indica que a operação foi bem sucedida.

ErrRelativePath indica que um caminho relativo foi passado para a função. Você deve passar um caminho absoluto (começando com qualquer letra de unidade ou um nome de compartilhamento UNC.

ErrInvalidPathSpecification indica que o caminho está mal formado.


ErrDirectoryCreateError indica que houve um erro ao criar o diretório. Na maioria das vezes, esta é uma questão de segurança / autorização.


ErrSpecIsFileName indica que o parâmetro de entrada não era um nome de arquivo ou nome de pasta.


ErrInvalidCharactersInPath indica que houve caracteres inválidos no nome da pasta.


O código para MakeMultiStepDirectory é mostrado abaixo.

Private Declare Function PathIsRelative Lib "Shlwapi" _

        Alias "PathIsRelativeA" (ByVal Path As String) As Long

    Public Enum EMakeDirStatus
        ErrSuccess = 0
        ErrRelativePath
        ErrInvalidPathSpecification
        ErrDirectoryCreateError
        ErrSpecIsFileName
        ErrInvalidCharactersInPath
    End Enum
    Const MAX_PATH = 260

    Function MakeMultiStepDirectory (ByVal PathSpec As String) As EMakeDirStatus
    ' MakeMultiStepDirectory
    ' This function creates a series of nested directories. The parent of
    ' every directory is create before a subdirectory is created, allowing a
    ' folder path specification of any number of directories (as long as the
    ' total length is less than MAX_PATH.
    
    Dim FSO As Scripting.FileSystemObject
    Dim DD As Scripting.Drive
    Dim B As Boolean
    Dim Root As String
    Dim DirSpec As String
    Dim N As Long
    Dim M As Long
    Dim S As String
    Dim Directories() As String
        
    Set FSO = New Scripting.FileSystemObject
        
    ' ensure there are no invalid characters in spec.
    On Error Resume Next
    Err.Clear
    S = Dir(PathSpec, vbNormal)
    If Err.Number <> 0 Then
        MakeMultiStepDirectory = ErrInvalidCharactersInPath
        Exit Function
    End If
    On Error GoTo 0
    
    ' ensure we have an absolute path
    B = CBool(PathIsRelative(PathSpec))
    If B = True Then
        MakeMultiStepDirectory = ErrRelativePath
        Exit Function
    End If
    
    ' if the directory already exists, get out with success.
    If FSO.FolderExists(PathSpec) = True Then
        MakeMultiStepDirectory = ErrSuccess
        Exit Function
    End If
    
    ' get rid of trailing slash
    If Right(PathSpec, 1) = "\" Then
        PathSpec = Left(PathSpec, Len(PathSpec) - 1)
    End If
    
    ' ensure we don't have a filename
    N = InStrRev(PathSpec, "\")
    M = InStrRev(PathSpec, ".")
    If (N > 0) And (M > 0) Then
        If M > N Then
            ' period found after last slash
            MakeMultiStepDirectory = ErrSpecIsFileName
            Exit Function
        End If
    End If
    
    If Left(PathSpec, 2) = "\\" Then
        ' UNC -> \\Server\Share\Folder...
        N = InStr(3, PathSpec, "\")
        N = InStr(N + 1, PathSpec, "\")
        Root = Left(PathSpec, N - 1)
        DirSpec = Mid(PathSpec, N + 1)
    Else
        ' Local or mapped -> C:\Folder....
        N = InStr(1, PathSpec, ":", vbBinaryCompare)
        If N = 0 Then
            MakeMultiStepDirectory = ErrInvalidPathSpecification
            Exit Function
        End If
        Root = Left(PathSpec, N)
        DirSpec = Mid(PathSpec, N + 2)
    End If
    Set DD = FSO.GetDrive(Root)
    Directories = Split(DirSpec, "\")
    DirSpec = DD.Path
    For N = LBound(Directories) To UBound(Directories)
        DirSpec = DirSpec & "\" & Directories(N)
        If FSO.FolderExists(DirSpec) = False Then
            On Error Resume Next
            Err.Clear
            FSO.CreateFolder (DirSpec)
            If Err.Number <> 0 Then
                MakeMultiStepDirectory = ErrDirectoryCreateError
                Exit Function
            End If
        End If
    Next N


    MakeMultiStepDirectory = ErrSuccess
    End Function




Pode chamar esse código a partir do seu próprio código da seguinte forma:

Sub AAA()
      Dim Result As EMakeDirStatus

        Let Result = MakeMultiStepDirectory ("C:\One\Two\Three\Four")


        If Result = ErrSuccess Then
            Debug.Print "Success"
        Else
            Debug.Print "Error"
        End If
    End Sub

Referências: Devhut.net, CPearson.com


Tags: VBA, Access, diretório, pasta, directory, folder, validation, exist, MkDir,  API, MakeFullDir, nested, aninhado, 
Tags: , , , , , , , , , , , ,

Nenhum comentário:

Postar um comentário

Assinar: Postar comentários (Atom)
diHITT - Notícias