Login | Register   
Twitter
RSS Feed
Download our iPhone app
TODAY'S HEADLINES  |   ARTICLE ARCHIVE  |   FORUMS  |   TIP BANK
Browse DevX
Sign up for e-mail newsletters from DevX


Tip of the Day
Language: VB6
Expertise: Intermediate
Nov 25, 2002

Using the CreateDirectory API function

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:

' 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
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:

' 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 great concept, the most obvious solution is not always the most effective one. You will often need to go the extra mile in order to create reliable applications.

Click here to visit the author's website.

Pan Polychronopoulos
 
Comment and Contribute

 

 

 

 

 


(Maximum characters: 1200). You have 1200 characters left.

 

 

Sitemap