Option Explicit
Option Compare Text
' Set to False if you do NOT want to
' overload the Access MkDir statment.
#Const conOverloadMkDir = True
' KPD-Team 2000
' URL: http://www.allapi.net/
' E-Mail: KPDTeam@Allapi.net
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long
#If conOverloadMkDir Then
Public Function MkDir(ByVal vntPath As Variant, _
Optional intErrorMode As Integer = 0) As Variant
' Author : ChrisO (URL: http://www.access-programmers.co.uk/forums/)
' Date : 11-Mar-2010
' Revisions : 13-Mar-2010 (Push back to Access 97)
' Contributors : KPD-Team 2000 (URL: http://www.allapi.net/)
' Error Modes : 0 = Silent (No internal messages)
' : Return Integer Success or Failure (-1=Success/True) (0=Failure/False)
' : 1 = Silent (No internal messages)
' : Return Error Description
' : 2 = Display internal messages
' : Return Integer Success or Failure (-1=Success/True) (0=Failure/False)
' : 3 = Display internal messages
' : Return Error Description
' :
' User Revisions : If you modify this code please do so in a way that Access97 users can use it.
' : Please test it under different Regional Settings.
' : Please bear in mind non-English version users.
Dim intSuccess As Integer ' A Boolean could interfere with non-English versions of Access.
Dim lngPos As Long ' Position of character in Path during parse.
Dim lngErrorNumber As Long ' Copy of VBA.Err.Number for error handling.
Dim strDescription As String ' Copy of VBA.Err.Description for error handling.
Dim strChr As String ' Character used in parsing.
Dim strTemp As String ' Temporary string for parsing.
On Error GoTo ErrorHandler
' Set the default return valve.
intSuccess = False
' Check for Null or ZLS.
If VBA.Len(vntPath) Then
' Set the initial return valve.
intSuccess = True
' The standard MkDir works with a '/', the API does not.
For lngPos = 1 To VBA.Len(vntPath)
strChr = VBA.Mid$(vntPath, lngPos, 1)
If strChr = "/" Then strChr = "\"
strTemp = strTemp & strChr
Next lngPos
vntPath = strTemp
strTemp = ""
' Remove all sequences of Space and \
For lngPos = 1 To VBA.Len(vntPath) - 1
strChr = VBA.Mid$(vntPath, lngPos, 2)
If strChr = " \" Then
strTemp = strTemp & "\"
Else
strTemp = strTemp & strChr
lngPos = lngPos + 1
End If
Next lngPos
vntPath = strTemp
' If the last character is a '\' or a space then remove it.
While VBA.Right$(vntPath, 1) = "\" Or VBA.Right$(vntPath, 1) = " "
vntPath = VBA.Left$(vntPath, VBA.Len(vntPath) - 1)
Wend
' Add a last '\'.
vntPath = vntPath & "\"
' Scan the Path for invalid characters.
For lngPos = 1 To VBA.Len(vntPath)
Select Case VBA.Mid$(vntPath, lngPos, 1)
Case "*", "?", VBA.Chr$(34), "<", ">", "|"
' Set the return value to not valid.
intSuccess = False
If intErrorMode = 1 Or intErrorMode = 2 Then
VBA.MsgBox "Character '" & VBA.Mid$(vntPath, lngPos, 1) & "' is not allowed in Directory name." & VBA.vbNewLine & _
"Directory was not created.", _
VBA.vbCritical + VBA.vbOKOnly, _
"Create Directory Failure"
End If
' Check for ':' other than following the drive letter.
Case ":"
If lngPos <> 2 Then
' Set the return value to not valid.
intSuccess = False
If intErrorMode = 1 Or intErrorMode = 2 Then
VBA.MsgBox "Character ':' is only allowed after Drive letter." & VBA.vbNewLine & _
"Directory was not created.", _
VBA.vbCritical + VBA.vbOKOnly, _
"Create Directory Failure"
End If
End If
' Check if ':' is followed by '\'
If lngPos <> VBA.Len(vntPath) Then
If VBA.Mid$(vntPath, lngPos + 1, 1) <> "\" Then
' Set the return value to not valid.
intSuccess = False
If intErrorMode = 1 Or intErrorMode = 2 Then
VBA.MsgBox "Character '\' is required after Drive letter and ':'" & VBA.vbNewLine & _
"Directory was not created.", _
VBA.vbCritical + VBA.vbOKOnly, _
"Create Directory Failure"
End If
End If
End If
End Select
' Exit loop on not valid.
If Not (intSuccess) Then Exit For
Next lngPos
' If valid so far then...
If (intSuccess) Then
' Check if Drive letter specified but path length is NOT correct.
If VBA.InStr(vntPath, ":") And VBA.Len(vntPath) < 4 Then
' Set the return value to not valid.
intSuccess = False
If intErrorMode = 1 Or intErrorMode = 2 Then
VBA.MsgBox "Incorrect Directory length after Drive letter." & VBA.vbNewLine & _
"Directory was not created.", _
VBA.vbCritical + VBA.vbOKOnly, _
"Create Directory Failure"
End If
Else
' Try creating the directory and return the result.
' If Drive letter is not specified,
' create the directory relative to current directory.
' A return value of 0 from the API is a failure.
intSuccess = Not (MakeSureDirectoryPathExists(vntPath) = 0)
End If
End If
End If
' Return the result depending on passed Error Mode.
Select Case intErrorMode
Case 0, 2
MkDir = intSuccess
Case 1, 3
' If error description = ZLS return description 'None'
MkDir = VBA.IIf(VBA.Err.Description = "", "None", VBA.Err.Description)
Case Else
' Out of range argument passed.
' They get what they deserve.
MkDir = False
End Select
ExitProcedure:
Exit Function
ErrorHandler:
' Make copy of the VBA.Err Data.
lngErrorNumber = VBA.Err.Number
strDescription = VBA.Err.Description
' No more errors please.
On Error Resume Next
' Should the error be displayed?
If intErrorMode = 2 Or intErrorMode = 3 Then
VBA.MsgBox "Error in MkDir() in Module mdlOverloadMkDir" & VBA.vbNewLine & _
"Error Number : " & lngErrorNumber & VBA.vbNewLine & _
"Error Description: " & strDescription, _
VBA.vbCritical + VBA.vbOKOnly, _
"Error in MkDir Overload"
End If
' What do we want to return?
If intErrorMode = 1 Or intErrorMode = 3 Then
MkDir = strDescription
Else
MkDir = False
End If
' Clear any error but do NOT Resume.
VBA.Err.Clear
GoTo ExitProcedure
End Function
#End If
