' In the Declarations section of a BAS module:

Private Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Long
End Type

Private Declare Function CreateDirectory Lib "kernel32" Alias _
    "CreateDirectoryA" (ByVal lpPathName As String, _
    lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long

' In the same BAS module, implement a CreateDirectory API wrapper:

Private Function NewDirectory(ByVal Path As String) As Long

    Dim lpSA As SECURITY_ATTRIBUTES

    lpSA.nLength = Len(lpSA)
    If (CreateDirectory(Path, lpSA) <> 0) Then
        ' NewDirectory = 0   ' Directory created
    Else
        NewDirectory = Err.LastDllError ' API error code
    End If

End Function

' API declares, types and constants
Private Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Long
End Type

Private Declare Function CreateDirectory Lib "kernel32" Alias _
    "CreateDirectoryA" (ByVal lpPathName As String, _
    lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long
'
Private Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000
Private Const FORMAT_MESSAGE_IGNORE_INSERTS As Long = &H200
Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK As Long = &HFF

Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" _
    (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, _
    ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, _
    Arguments As Long) As Long

' The APIMakeDirectory function can be called from anywhere in the
' project. It encapsulates three private (module-level) functions:
'   - EvalFileName: validates the new directory name
'   - NewDirectory: Creates the new directory
'   - APIErrorMessage: provides a description of API error codes
'
' APIMakeDirectory returns True on success. Optional errCode and
' errMsg arguments receive error information. If RenameOnCollision is
' True and there is a name clash in the destination path, the directory
' is renamed and the new name is returned in Path.
'
Public Function APIMakeDirectory(Path As String, Optional RenameOnCollision As _
    Boolean, Optional errCode As Long, Optional errMsg As String) As Boolean

    Dim RetVal As Long
    Dim i As Long
    Dim TempName As String
    On Error GoTo exitError
    
    ' Extract directory name
    TempName = Path
    For i = Len(Path) To 1 Step -1
        If (Mid$(Path, i, 1) = "\") Then
            TempName = Mid$(Path, i + 1)
            Exit For
        End If
    Next
    
    ' Validate directory name
    If EvalFileName(TempName) = True Then
        Err.Raise 1005, , "Invalid directory name."
    End If
        
    ' Create the directory (RenameOnCollision if requested)
    RetVal = NewDirectory(Path)
    If RenameOnCollision Then
        i = 0
        TempName = Path
        Do While (RetVal = 183)
            i = i + 1
            Path = TempName & " (" & CStr(i) & ")"
            RetVal = NewDirectory(Path)
        Loop
    End If
    
    If RetVal = 0 Then ' success
        errCode = RetVal
        errMsg = "Directory created."
        APIMakeDirectory = True
    Else
        Err.Raise RetVal, , APIErrorMessage(RetVal)
    End If
    
exitNormal:
    Exit Function
    
exitError:
    errCode = Err.Number
    errMsg = Err.Description
    Resume exitNormal
End Function

' EvalFileName ensures that the basename of a file or directory
' conforms to the Microsoft file naming guidelines (see MSDN webpage)
' http://msdn.microsoft.com/library/default.asp?url=/library/en-us/fileio/base/
' naming_a_file.asp
'
' Return value:
'   True = Valid basename
'   False = Invalid basename
'
' Note: Since EvalFileName checks only the basename of a file or
' directory, it does not test the max filename length condition
' (ANSI 255 for files, 248 for directories, including the path)
' This error is however trapped by the APIMakeDirectory function
'
Private Function EvalFileName(ByVal Name As String) As Boolean
                            
    Dim i As Long
    Dim Test As String
    Const BAD_FILENAME_CHARS As String = """" & "/" & "\" & ":" & "|" & "<" & _
        ">" & "*" & "?"
    
    ' We need a name
    If Len(Trim$(Name)) = 0 Then
        Exit Function
    End If
    
    ' Test trailing space or period
    Test = Right$(Name, 1)
    If Test = " " Or Test = "." Then
        Exit Function
    End If
    
    ' Test illegal and non-printable characters
    Test = BAD_FILENAME_CHARS
    For i = 0 To 31
        Test = Test & Chr$(i)
    Next
    For i = 1 To Len(Name)
        If InStr(1, Test, Mid$(Name, i, 1)) > 0 Then
            Exit Function
        End If
    Next
    
    ' Test possible use of reserved words
    ' (CON, PRN, AUX, CLOCK$, NUL)
    If LCase$(Name) = "con" Or LCase$(Name) = "prn" Or LCase$(Name) = "aux" Or _
        LCase$(Name) = "clock$" Or LCase$(Name) = "nul" Then
            Exit Function
    End If
    ' COM/LPT (1-9)
    For i = 1 To 9
        If LCase$(Name) = "com" & CStr(i) Or LCase$(Name) = "lpt" & CStr(i) Then
            Exit Function
        End If
    Next
    
    ' All tests clear, return success
    EvalFileName = True

End Function

' CreateDirectory API wrapper function: Creates a new directory
'
Private Function NewDirectory(ByVal Path As String) As Long

    Dim lpSA As SECURITY_ATTRIBUTES

    lpSA.nLength = Len(lpSA)
    If (CreateDirectory(Path, lpSA) <> 0) Then
        ' NewDirectory = 0   ' Directory created
    Else
        NewDirectory = Err.LastDllError ' API error code
    End If

End Function

' FormatMessage API wrapper function: Returns system error description.
'
Private Function APIErrorMessage(ByVal errCode As Long) As String

    Dim MsgBuffer As String * 257
    Dim MsgLength As Long
  
    MsgLength = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or _
        FORMAT_MESSAGE_IGNORE_INSERTS Or FORMAT_MESSAGE_MAX_WIDTH_MASK, 0&, _
        errCode, 0&, MsgBuffer, 256&, 0&)
    If (MsgLength = 0) Then
        APIErrorMessage = "Unknown error."
    Else
        APIErrorMessage = Left$(MsgBuffer, MsgLength)
    End If

End Function