在创建文件夹之前检查 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

但我不确定这是否是处理此问题的最佳方法。我使用“On Error Resume Next”，这样如果由于文件夹（已经存在）的权限不足而发生错误，它将忽略它。有什么更好的方法来处理这个问题？谢谢。

我还检查了以下链接：

• 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
• Check Folder Permissions Before Save 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

我使用以下函数递归地创建完整路径（如果需要）并返回一个指示成功或失败的值。它也适用于 UNC。

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:\toto\test\test") Then debug.print "OK"
'updated 20130422 to handle UNC paths correctly ("\\MyServer\MyShare\MyFolder")

    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 脚本运行时的引用

Dim fso As FileSystemObject

 Dim fil As File
 Set fso = New Scripting.FileSystemObject

 If fso.FileExists("\\serverName\folderName\fileName.txt") Then
   'code execution here
 Else
   MsgBox "File and/or Path cannot be found", vbCritical, "File Not Found"
 End If