GFCreateDirectory/GFCreateDirectory.frm

VERSION 5.00
Begin VB.Form Mfrm
   Caption         =   "Form1"
   ClientHeight    =   3195
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4695
   LinkTopic       =   "Form1"
   ScaleHeight     =   3195
   ScaleWidth      =   4695
   StartUpPosition =   3 'Windows‑Standard
End
Attribute VB_Name = "Mfrm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)?, 2004 by Louis.
'
'NOTE: this project allows creating a whole sub directory tree with one function call.
'If you'd have an empty drive you could create 'C:\MyApp\Skins\BaseSkin\' with one
'single function call (not possible using VB MkDir command).
'Downloaded from www.louis‑coder.com.
'
'GFCreateDirectory
Private Declare Function CreateDirectory Lib "kernel32" Alias "CreateDirectoryA" (ByVal lpPathName As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long
'GFCreateDirectory
Private Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Long
End Type
'GFCreateDirectory
Dim GFCreateDirectorySubCallNumber As Integer

Private Sub Form_Load()
    'on error resume next
    Debug.Print GFCreateDirectory("C:\MP3\0000\Lyte Funke Ones\Monsterhits\")
    Debug.Print GFCreateDirectorySubCallNumber 'DEBUG (must be 0)
End Sub

Private Function GFCreateDirectory(ByVal DirectoryName As String) As Boolean
    On Error GoTo Error: 'important; creates up to 100 sub directories in current directory or given parent directory; returns True if directory is existing when function is left, or False if there was an error creating the directory
    Dim Temp As Long
    Dim SECURITY_ATTRIBUTESVar As SECURITY_ATTRIBUTES
    '
    'NOTE: MkDir and CreateDirectory() can create one sub directory only,
    'this function is able to create up to 100 ones from one call, i.e. even if only
    'c:\ exists, the value of DirectoryName can be c:\sub1\sub2\sub3\.
    '
    'verify
    If DirectoryName = "" Then 'verify first
        GoTo Error:
    End If
    If (Right$(DirectoryName, 1) = "\") And (Len(DirectoryName) > 1) Then DirectoryName = Left$(DirectoryName, Len(DirectoryName) ‑ 1) 'for any reason RmDir fails when we called Dir("C:\Test\", vbDirectory), but it doesn't fail for Dir("C:\Test", vbDirectory)
    If Not (Dir(DirectoryName, vbDirectory) = "") Then
        GoTo Success:
    End If
    If (GFCreateDirectorySubCallNumber < 100) Then
        GFCreateDirectorySubCallNumber = GFCreateDirectorySubCallNumber + 1
    Else
        GoTo Error:
    End If
    'begin
Redo:
    'NOTE: remove last backslash so that GetDirectoryName() will cut last directory name.
    If Right$(DirectoryName, 1) = "\" Then DirectoryName = Left$(DirectoryName, Len(DirectoryName) ‑ 1)
    If Not (Dir(GFCreateDirectory_GetDirectoryName(DirectoryName), vbDirectory) = "") Then
        'one sub directory to create left
        If Not (CreateDirectory(DirectoryName, SECURITY_ATTRIBUTESVar) = 0) Then
            GFCreateDirectory = True 'ok
            GoTo Success: '(*1)
        Else
            GoTo Error: '(*2)
        End If
    Else
        'several sub directories to create left
        GFCreateDirectory = GFCreateDirectory(GFCreateDirectory_GetDirectoryName(DirectoryName))
        'NOTE: if arrived here (over (*1) or (*2) of last call), the first sub directory has been created.
        If GFCreateDirectory = True Then
            GoTo Redo:
        Else
            GoTo Error:
        End If
    End If
    GFCreateDirectorySubCallNumber = 0 'reset
    Exit Function
Success:
    GFCreateDirectory = True 'ok
    GFCreateDirectorySubCallNumber = 0 'reset
    Exit Function
Error: 'if passed directory name is i.e. '>>>', Dir() will create an error
    GFCreateDirectory = False 'error
    GFCreateDirectorySubCallNumber = 0 'reset
    'NOTE: if function returns False there cannot be any more subcalls, so
    'GFCreateDirectorySubCallNumber can be reset to zero.
    Exit Function
End Function

Private Function GFCreateDirectory_GetDirectoryName(ByVal GetDirectoryNameName As String) As String
    On Error Resume Next 'returns chars from string beginning to (including) last backslash or nothing
    Dim Temp As Long
    GFCreateDirectory_GetDirectoryName = "" 'reset
    For Temp = Len(GetDirectoryNameName) To 1 Step (‑1)
        If Mid$(GetDirectoryNameName, Temp, 1) = "\" Then
            GFCreateDirectory_GetDirectoryName = Left$(GetDirectoryNameName, Temp)
            Exit For
        End If
    Next Temp
End Function


[END OF FILE]