✔ Programação GLOBAL®: VBA Access - Criando estrutura de Diretórios, Aninhados, Na Rede - Create Directory Structure/Create Multiple Directories/Create Nested Directories

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

| Blog Office VBA | Blog Excel | Blog Access |

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