Binaryworld - Using the CreateDirectory and CreateDirectoryEx API functions ... [ VB -> Files & Folder ]

The VB's MkDir function creates a directory in a specified path. If the directory already exists, MkDir raises error 75 (Path/file access error); yet, it raises the same error code if you attempt to create the directory on a read-only drive. Even worse, in Windows NT/2K/XP workstations, if you try to create a directory named "prn", which is a reserved word, MkDir does not raise any error even though the directory is not created. An easy alternative to MkDir is provided by the FileSystemObject object. Another one involves using the CreateDirectory API function. Because this function is part of the Windows "kernel32" library, you do not have to add any references to your project or package additional DLL files with your application. You must however declare the API function as well as write some additional code:

Click here to copy the following block

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

Private Declare Function CreateDirectoryEx Lib "kernel32.dll" Alias "CreateDirectoryExA" ( _
    ByVal lpTemplateDirectory As String, _
    ByVal lpNewDirectory As String, _
    lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long

Private Declare Function RemoveDirectory Lib "kernel32.dll" Alias "RemoveDirectoryA" ( _
    ByVal lpPathName As String) As Long

Private Declare Function SetFileAttributes Lib "kernel32.dll" Alias "SetFileAttributesA" ( _
    ByVal lpFileName As String, _
    ByVal dwFileAttributes As Long) As Long

Private Const FILE_ATTRIBUTE_ARCHIVE = &H20
Private Const FILE_ATTRIBUTE_HIDDEN = &H2
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_ATTRIBUTE_READONLY = &H1
Private Const FILE_ATTRIBUTE_SYSTEM = &H4

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

Private Sub Form_Load()
  Dim Retval As Long, SA As SECURITY_ATTRIBUTES

  Retval = CreateDirectory("C:\TempPath1", SA)
  If Retval <> 0 Then
    MsgBox "New directory path is ""C:\TempPath1"""
    Retval = SetFileAttributes("C:\TempPath1", FILE_ATTRIBUTE_HIDDEN Or FILE_ATTRIBUTE_ARCHIVE)
    If Retval <> 0 Then
      MsgBox "Directory is now hidden ""C:\TempPath1"""
    End If
  End If

  With SA
    .nLength = Len(SA)
    .lpSecurityDescriptor = 0
    .bInheritHandle = 1  'Standardhandle ist 1
  End With

  Retval = CreateDirectoryEx("C:\TempPath1", "C:\TempPath2", SA)
  If Retval <> 0 Then
    MsgBox "New directory ""C:\TempPath2"" created using attributes of C:\TempPath2"
  End If

  If Retval = vbOK Then
    RemoveDirectory "C:\TempPath1"
    RemoveDirectory "C:\TempPath2"

    MsgBox "TempPath1 and TempPath2 both deleted"
  End If
End Sub

The NewDirectory wrapper function is declared with Private scope because it is not the routine we want to access directly in code. The reason for this is that it lacks two essential components, directory name validation and descriptive error messages. Instead, we access the APIMakeDirectory function that encapsulates both EvalFileName and NewDirectory. Because APIMakeDirectory must be able to identify the meaning of the error codes returned by NewDirectory, it also encapsulates the APIErrorMessage, which a wrapper of the FormatMessage API function. The complete code of the APIMakeDirectory function - provided below - offers an additional feature that allows renaming of the new directory if it already exists in the destination path:

Click here to copy the following block

' 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

In conclusion, I would like to point out that although RAD is a