在创建文件夹之前，请检查VBA Access中目录的权限

Question

我正试图使用VBA在Microsoft Access数据库中实现某个功能，因此当按下某个按钮时，它将首先检查服务器中文件夹的可用性。如果文件夹不存在，将创建相应的文件夹。但是，文件夹具有附加的权限，这意味着只有某些用户可以访问它，因此只有某些用户应该创建/访问文件夹。我尝试过以下几种：

on error resume next
If Dir("Server/Data/Celes", vbDirectory) = "Celes" Then
Else
MkDir ("Server/Data/Celes")
End If

但我不确定这是否是处理这个问题的最佳方法。我使用"错误时继续下一步"，这样，如果由于对文件夹(已存在(缺乏权限而发生错误，它将忽略它。有什么更好的方法来处理此问题？非常感谢。

我还检查了以下链接：

• https://social.msdn.microsoft.com/Forums/office/en-US/a79054cb-52cf-48fd-955b-aa38fd18dc1f/vba-verify-if-user-has-permission-to-directory-before-saveas-attempt?forum=exceldev
• 保存VBA前检查文件夹权限

但两者都关心保存文件，而不是创建文件夹。

Answer 1

经过几天的失败，我终于找到了解决方案：

Private function canAccess(path as string) as boolean
Dim oShell As Object
Set oShell = CreateObject("WScript.Shell")
Dim result As Integer
Dim command As String
command = "icacls " & """" & pfad & """"
result = oShell.Run(command, 0, True)
'Check privilege; file can be accessed if error code is 0.
'Else, errors are encountered, and error code > 0.
If result <> 5 and result <> 6 Then
KannAufDateiZugreifen = True
Else
KannAufDateiZugreifen = False
End If
end function
private sub button_click()
if canAccess ("Server/Data/Celes") then
If Dir("Server/Data/Celes", vbDirectory) = "Celes" Then
Else
MkDir ("Server/Data/Celes")
end if
End If
end sub

函数"canAccess"将模拟Windows shell的运行，并执行"icacls"来查看是否可以访问该文件。如果函数返回true，则表示"icacls"命令成功，表示可以访问文件夹。否则，文件/文件夹将无法访问。

我确信这是可以改进的，但就目前而言，它是有效的。

Answer 2

我使用下面的函数，该函数递归地创建完整路径(如果需要(并返回一个指示成功或失败的值。它还与联合国国家工作队合作。

Private Function CreateFolder(ByVal sPath As String) As Boolean
'by Patrick Honorez - www.idevlop.com
'checks for existence of a folder and create it at once, if required
'returns False if folder does not exist and could NOT be created, True otherwise
'sample usage: If CreateFolder("C:tototesttest") Then debug.print "OK"
'updated 20130422 to handle UNC paths correctly ("\MyServerMyShareMyFolder")
Dim fs As Object
Dim FolderArray
Dim Folder As String, i As Integer, sShare As String
If Right(sPath, 1) = "" Then sPath = Left(sPath, Len(sPath) - 1)
Set fs = CreateObject("Scripting.FileSystemObject")
'UNC path ? change 3 "" into 3 "@"
If sPath Like "\**" Then
sPath = Replace(sPath, "", "@", 1, 3)
End If
'now split
FolderArray = Split(sPath, "")
'then set back the @ into  in item 0 of array
FolderArray(0) = Replace(FolderArray(0), "@", "", 1, 3)
On Error GoTo hell
'start from root to end, creating what needs to be
For i = 0 To UBound(FolderArray) Step 1
Folder = Folder & FolderArray(i) & ""
If Not fs.FolderExists(Folder) Then
fs.CreateFolder (Folder)
End If
Next
CreateFolder = True
hell:
End Function

Answer 3

'必须设置对Microsoft Scripting Runtime 的引用

Dim fso As FileSystemObject
Dim fil As File
Set fso = New Scripting.FileSystemObject
If fso.FileExists("\serverNamefolderNamefileName.txt") Then
'code execution here
Else
MsgBox "File and/or Path cannot be found", vbCritical, "File Not Found"
End If