如何检查用户是否对文件夹具有写权限？

Question

I am trying to check all of the permissions that I can so that people can choose any file and before it fails later on in the program they can get an error message that directly responds to why they cannot save to that location. The two that work right now that I have covered are "No Folder Selected," and "This File does NOT exist". Saying that it is readonly is not working and if anyone has any helpful tips that would be greatly appreciated or any ideas of more checks that I could do about the files. I am testing it using the program files file on my computer.

Sub CreateFile()

    Dim BaseDirectory As String
    Dim FS As FileSystemObject
    Set FS = New FileSystemObject

    BaseDirectory = GetFolder()

    If (BaseDirectory = vbNullString) Then
       MsgBox "No Folder Selected", vbExclamation, "Error"
       GoTo EndProgram
    End If

   'Not Working
    With FS.GetFolder(BaseDirectory)
        If (.Attributes And ReadOnly) Then
        MsgBox .Name & " is readonly!"
        GoTo EndProgram
        End If
    End With

    If Len(Dir(BaseDirectory)) = 0 Then
       MsgBox "This file does NOT exist."
       GoTo EndProgram
    End If

EndProgram:
End Sub

Function GetFolder() As String

    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)

    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
            sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing
End Function

I'm expecting this to say .Name is readonly!, but it does not work at .attributes and readonly. It just says This file does NOT exist

Answer 1

Here is a function that checks if the current user has write access to a folder. It works by creating a temp file in that folder for writing, if it's able to create it then it will return true. Otherwise, this function will return false.

'CHECK TO SEE IF CURRENT USER HAS WRITE ACCESS TO FOLDER
Public Function HasWriteAccessToFolder(ByVal FolderPath As String) As Boolean

    '@example: HasWriteAccessToFolder("C:\Program Files") -> True || False

    'MAKE SURE FOLDER EXISTS, THIS FUNCTION RETURNS FALSE IF IT DOES NOT
    Dim Fso As Scripting.FileSystemObject
    Set Fso = New Scripting.FileSystemObject
    If Not Fso.FolderExists(FolderPath) Then
        Exit Function
    End If

    'GET UNIQUE TEMP FilePath, DON'T WANT TO OVERWRITE SOMETHING THAT ALREADY EXISTS
    Do
        Dim Count As Integer
        Dim FilePath As String

        FilePath = Fso.BuildPath(FolderPath, "TestWriteAccess" & Count & ".tmp")
        Count = Count + 1
    Loop Until Not Fso.FileExists(FilePath)

    'ATTEMPT TO CREATE THE TMP FILE, ERROR RETURNS FALSE
    On Error GoTo Catch
    Fso.CreateTextFile(FilePath).Write ("Test Folder Access")
    Kill FilePath

    'NO ERROR, ABLE TO WRITE TO FILE; RETURN TRUE!
    HasWriteAccessToFolder = True

Catch:

End Function

Answer 2

Leverage the function? I'm using VBS (not VBA) but someone may still find this a useful observation. If you run the fso commands on a path that doesn't exist or perms issue it will return the function and error code, use that to determine if the user has access to that folder:

'VBS Example:

Function TestDirectory(FullDirPath)
'Purpose: test creation, if path doesn't exist or permissions issue, function will return error code
    strDir = fso.GetAbsolutePathName(FullDirPath)
    strDir = strDir & "\_randfoldercrtplsdelthis"
    fso.CreateFolder strDir
    If fso.FolderExists(strDir) Then
        fso.DeleteFolder strDir, TRUE
    End If
End Function

On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
Set Shell = CreateObject("WScript.Shell")

FilePath = "C:\Restricted Start Menu Locked\"
If TestDirectory(FilePath) <> 0 Then
    WScript.Echo "Folder Access Denied? Error = " & Err.Number
Else
    WScript.Echo "Woot!"
End If