我经常能够在用户的硬盘驱动器或网络驱动器上创建文件夹来存储文件。但是,问题之一是,如果父文件夹还不存在,则内置函数MkDir的标准将失败。 因此,我做了一个自定义函数,该函数将循环遍历并根据需要创建目录。 如果创建成功,它将返回True。 我确信还有改进的空间,因此,如果有人要添加一些内容,请继续。
用法示例:
If MakeDir("C:\MyAppWorkfolder\2012\January") Then
'Proceed to export file
End If
这是代码:
Public Function MakeDir(ByVal strPath As String) As Boolean
'****************************************************************************************
'* Function: MakeDir
'*
'* Author: TheSmileyCoder
'* Version: 1.0, Dated: 2012-03-01
'* Input: Full path to directory desired. For example: "C:\Program Files\MyTool\
'*
'* Output: True/False indicating whether or not creation was succesfull.
'****************************************************************************************
'* Known issues
' * No error handling for cases such as network drives,
' with restricted permissions to create folders.
' * No input validation
On Error GoTo err_Handler
'Check if rightmost char is a \
If Right(strPath, 1) = "\" Then
'Strip it
strPath = Left(strPath, Len(strPath) - 1)
End If
'Check if each individual directory exists, and if not, create it
Dim strSplitPath() As String
strSplitPath = Split(strPath, "\")
Dim intI As Integer
Dim strCombined As String
'Loop through, creating each directory if needed
For intI = 0 To UBound(strSplitPath)
If intI <> 0 Then
strCombined = strCombined & "\"
End If
strCombined = strCombined & strSplitPath(intI)
If Dir(strCombined, vbDirectory) = "" Then
MkDir strCombined
End If
Next
'Code ran to end without errors, so creation was succesfull
MakeDir = True
Exit Function
'**************************************
'* Error Handler
'**************************************
err_Handler:
MakeDir = False
MsgBox "Error " & Err.Number & " occured." & vbNewLine & Err.Description
End Function
From: https://bytes.com/topic/access/insights/933852-create-folder-using-vba