保存VBA之前检查文件夹权限

Question

我已经创建了一个用户窗体，该窗体将打开一个excel文件并打开并隐藏excel。 关闭用户表单时，将保存并关闭Excel文件。 但是，excel文件有两种类型的用户。

1. 编辑器-将数据输入文件的人员
2. 查看者-查看文件的人。

具有excel文件的文件夹仅允许“编辑器”保存。 （其他人没有写权限）。 因此，如果用户对文件夹没有权限，则必须避免保存部分。 有任何想法吗？ 我的用户表单关闭事件代码在这里。

Private Sub UserForm_QueryClose (Cancel As Integer, CloseMode As Integer)

If CloseMode = vbFormControlMenu Then

If ws.AutoFilterMode Then ws.AutoFilterMode = False
ws.Columns("F:H").Copy
ws.Activate
ws.Range("F1").Select
Application.DisplayAlerts = False
Selection.PasteSpecial Paste:=xlPasteValues
Application.DisplayAlerts = True
Application.CutCopyMode = False
Application.Visible = True
ActiveWorkbook.CheckCompatibility = False
ThisWorkbook.Close savechanges:=True
ActiveWorkbook.CheckCompatibility = True
End If
End Sub

Ws表示工作表的声明名称。

编辑

我已经尝试并找到了另一种方法来克服这种情况。 但是，这不是解决方案，并且是获取结果的肮脏方法。 请参见下面的代码。

Private Sub UserForm_QueryClose (Cancel As Integer, CloseMode As Integer)
On Error Resume Next
If CloseMode = vbFormControlMenu Then
If ws.AutoFilterMode Then ws.AutoFilterMode = False
ws.Columns("F:H").Copy
ws.Activate
ws.Range("F1").Select
Application.DisplayAlerts = False
Selection.PasteSpecial Paste:=xlPasteValues
Application.DisplayAlerts = True
Application.CutCopyMode = False
Application.Visible = True
ActiveWorkbook.CheckCompatibility = False
ThisWorkbook.Save
ThisWorkbook.Close savechanges:=False
ActiveWorkbook.CheckCompatibility = True
End If

End Sub

在上面的代码中，我已经跟踪了查看器保存过程中生成的错误，并通过使用on error resume next跳转到下一行。

Answer 1

上面来自Macro Man的回答虽然简洁实用，但在由用户组而不是用户名管理文件夹访问的环境中将不起作用。 由于许多公司环境（包括我自己的环境）都使用此方法来管理文件夹访问，因此我在下面发布了一种解决方案，该解决方案将评估用户对文件夹的实际权限。 无论已授予用户个人或组对文件夹的访问权限，此功能都将起作用。

Private Function TestWriteAccess(ByVal StrPath As String) As Boolean

Dim StrName As String, iFile As Integer, iCount As Integer, BExists As Boolean

'Set the initial output to False
TestWriteAccess = False

'Ensure the file path has a trailing slash
If Right(StrPath, 1) <> "\" Then StrPath = StrPath & "\"

'Ensure the path exists and is a folder
On Error Resume Next
BExists = (GetAttr(StrPath) And vbDirectory) = vbDirectory
If Not BExists Then GoTo Exit_TestWriteAccess 'Folder does not exist
'Set error handling - return False if we encounter an error (folder does not exist or file cannot be created)
On Error GoTo Exit_TestWriteAccess

'Get the first available file name
Do
    StrName = StrPath & "TestWriteAccess" & iCount & ".tmp"
    iCount = iCount + 1
Loop Until Dir(StrName) = vbNullString

'Attempt to create a test file
iFile = FreeFile()

Open StrName For Output As #iFile
Write #iFile, "Testing folder access"
Close #iFile

TestWriteAccess = True

'Delete our test file
Kill StrName

Exit_TestWriteAccess:
End Function

在研究文件访问时，我还偶然发现了FreeVBcode.com上的Segey Merzlikin所检查的NTFS卷上对文件/目录的访问权限 。 此解决方案对于我（和OP）的需求而言是过大的，但是会返回用户对特定文件的确切访问权限。

Answer 2

这将检查工作簿文件夹的访问列表，以查看用户名是否出现在列表中。 如果是这样，则保存文件。

If Instr(1, Environ("USERNAME"), CreateObject("WScript.Shell").Exec("CMD /C ICACLS """ & _
ThisWorkbook.Path & """").StdOut.ReadAll) > 0 Then ThisWorkbook.Save

它通过打开命令提示符，通过它运行ICACLS命令并读取该命令的输出来执行此操作。 然后，它使用InStr（）方法查看用户名是否出现在该输出中。