'*******************************************************************************
'* *
'* Please leave any trademarks or credits in place. *
'* *
'* This code, Overload MkDir, by ChrisO via: - *
'* http://www.access-programmers.co.uk/forums/ *
'* Original posting date: 9-Mar-2010 *
'* *
'*******************************************************************************
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) As Boolean
' Author : ChrisO (http://www.access-programmers.co.uk/forums/)
' Date : 9-Mar-2010
' Revision : None
' Contributors : KPD-Team 2000 (URL: http://www.allapi.net/)
Dim lngPos As Long
Dim strChr As String
Dim blnSuccess As Boolean
' Check for Null or ZLS.
If Len(vntPath) Then
' Set the initial return valve.
blnSuccess = True
' The standard MkDir works with a '/', the API does not.
vntPath = Replace(vntPath, "/", "\")
' Scan the Path for invalid characters.
For lngPos = 1 To Len(vntPath)
Select Case Mid$(vntPath, lngPos, 1)
Case "*", "?", Chr$(34), "<", ">", "|"
' Set the return value to not valid.
blnSuccess = False
MsgBox "Character '" & Mid$(vntPath, lngPos, 1) & "' not allowed in Directory name." & vbNewLine & _
"Directory was not created.", _
vbCritical + vbOKOnly, _
"Create Directory Failure"
' Check for ':' other than following the drive letter.
Case ":"
If lngPos <> 2 Then
' Set the return value to not valid.
blnSuccess = False
MsgBox "Character ':' only allowed after Drive letter." & vbNewLine & _
"Directory was not created.", _
vbCritical + vbOKOnly, _
"Create Directory Failure"
End If
' Check if ':' is followed by '\'
If lngPos <> Len(vntPath) Then
If Mid$(vntPath, lngPos + 1, 1) <> "\" Then
' Set the return value to not valid.
blnSuccess = False
MsgBox "Character '\' required after Drive letter and ':'" & vbNewLine & _
"Directory was not created.", _
vbCritical + vbOKOnly, _
"Create Directory Failure"
End If
End If
End Select
' Exit loop on not valid.
If Not (blnSuccess) Then Exit For
Next lngPos
' If valid so far.
If (blnSuccess) Then
' Add last '\' if not supplied.
If Right(vntPath, 1) <> "\" Then vntPath = vntPath & "\"
' Check if Drive letter specified and path length is NOT correct.
If InStr(vntPath, ":") And Len(vntPath) < 4 Then
' Set the return value to not valid.
blnSuccess = False
MsgBox "Incorrect Directory length after Drive letter." & vbNewLine & _
"Directory was not created.", _
vbCritical + vbOKOnly, _
"Create Directory Failure"
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.
blnSuccess = Not (MakeSureDirectoryPathExists(vntPath) = 0)
End If
End If
End If
' Return the result.
MkDir = blnSuccess
End Function
#End If
MkDir "C:\Tom\Test\Test\ slkjfsklf ' lkjdljalsd"
Call MkDir("C:\Tom\Test\Test\ slkjfsklf ' lkjdljalsd")
Assign return status:
Me.txtMakeDirectoryStatus = MkDir("C:\Tom\Test\Test\ slkjfsklf ' lkjdljalsd")
Me.txtMakeDirectoryStatus = MkDir(Me.txtDirectoryName)
function mymkdir(newdir as string; optional oldmethod as boolean = false) as boolean
if oldmethod then
mkdir(newdir)
exit function
end if
... otherwsir do your new thing
end function
function mymkdir(newdir as string; optional oldmethod as boolean = false) as boolean
if oldmethod then
mkdir(newdir)
exit function
end if
... otherwsir do your new thing
end function
Subclassing wouldn't be an easy job at all. It's the referencing that's the difficult bit. I may look into that at some point just for the sake of it. Yes, it would require a new thread if I get to doing it.How were you thinking of sub-classing the MkDir Statement?
I have no knowledge of sub-classing internal Access Statements but if you can do it then go for it. However, if it’s substantially different from overloading then it would become an entirely new subject and not replace the overloading which, so far as tested, already works.
So, to me, a new subject would equate to a new thread.
(This site has been slow in the last hour…must be provider backup time. If it doesn’t get better soon I’ll kiss you goodnight. That reminds me of a movie ‘The Long Kiss Goodnight’)
Stuff it; it’s too slow to be usable…goodnight.
function massage(dstrg as string) as string
'these variables used to massage folder string, and strip out all embedded leading/trailing spaces - note the exit function is where it is, because I originally included this as a gosub/return.
Dim pos As Long
Dim startfrom As Long
Dim lseg As String
Dim mseg As String
Dim rseg As String
'parse the string and clear out leading/trailing spaces in each folder
'so "c:\ some folder \ some folder 2 \
'becomes
'so "c:\some folder\some folder 2\
'this is a bit verbose because instr works slightly differently if starting form position 0
'I also ended up treating the string as three segments as the compiler was objecting to doing it all in one line - the trim(mid) usage I think, but maybe I 'had the syntax off slightly
'the left segment upto the first \ we are checking
'the middle segment which is the current folder
'the right segment after the second \ we are checking
startfrom = 0
While True
If startfrom = 0 Then
pos = InStr(dstrg, "\")
Else
pos = InStr(startfrom, dstrg, "\")
End If
If pos > 0 Then
If startfrom = 0 Then
lseg = ""
Else
lseg = Trim(Left(dstrg, startfrom - 1))
End If
If startfrom = 0 Then
mseg = Left(dstrg, pos - 1)
Else
mseg = Trim(Mid(dstrg, startfrom, pos - startfrom))
End If
rseg = Trim(Mid(dstrg, pos))
dstrg = lseg & mseg & rseg
pos = InStr(startfrom + 1, dstrg, "\")
Else
If startfrom = 0 Then
lseg = ""
Else
lseg = Trim(Left(dstrg, startfrom))
End If
rseg = Trim(Mid(dstrg, startfrom + 1))
dstrg = lseg & rseg
[COLOR="Red"] massage = dstrg
exit function[/COLOR]
End If
startfrom = pos + 1
Wend
end function