限制对Excel工作表的查看访问权限

Question

我认为这将是Excel中一个易于使用的功能,但实现一个简单的过程来限制对较大工作簿中的特定工作表的访问是非常困难的.

有一些方法可以提示初始密码来打开同一工作簿的各种版本.但我想让所有用户都保持相同的工作簿,但限制访问某些工作表.当然有密码保护功能,要求用户输入密码才能查看表格.而不是基于不同的用户创建同一工作簿的多个版本.

我尝试了以下但它没有提示密码来访问工作表

Private Sub Workbook_SheetActivate(ByVal Sh As Object)

Dim MySheets As String, Response As String
Dim MySheet As Worksheet
MySheet = "COMMUNICATION"
If ActiveSheet.Name = MySheet Then
ActiveSheet.Visible = False
    Response = InputBox("Enter password to view sheet")
        If Response = "MyPass" Then
            Sheets(MySheet).Visible = True
            Application.EnableEvents = False
            Sheets(MySheet).Select
            Application.EnableEvents = True
        End If
End If
Sheets(MySheet).Visible = True
End Sub

我这样做了吗？

Answer 1

听起来根据评论,这不是一个安全问题,因为它是一个方便的问题.因此,在考虑将此项实施到您的项目中时,请牢记如果有任何恶意意图未经授权访问,这很容易破解.

首先,我建议一个共同的着陆区.打开工作簿后立即显示的主工作表.为此,我们将使用该Workbook_Open()事件并从那里激活工作表.

如果需要,这可以是隐藏的工作表,这将取决于您.

Option Explicit

Private lastUsedSheet As Worksheet

Private Sub Workbook_Open()

    Set lastUsedSheet = Me.Worksheets("MainSheet")
    Application.EnableEvents = False
    lastUsedSheet.Activate
    Application.EnableEvents = True

End Sub

接下来,我们应该决定在尝试访问新工作表时应该发生什么.在下面的方法中,一旦工作表被激活,它将自动将用户重定向回最后使用的工作表,直到成功完成密码尝试.

我们可以跟踪模块范围变量中最后使用的工作表,在此示例中将对其进行命名lastUsedSheet.每当成功更改工作表时,此变量将自动设置为该工作表 - 这样当有人试图访问另一个工作表时,它会将它们重定向回到先前工作表,直到成功输入密码.

Private Sub Workbook_SheetActivate(ByVal Sh As Object)

    On Error GoTo SafeExit

    Application.EnableEvents = False

    ' Error protection in case lastUsedSheet is nothing
    If lastUsedSheet Is Nothing Then
        Set lastUsedSheet = Me.Worksheets("MainSheet")
    End If

    ' Allow common sheets to be activated without PW
    If Sh.Name = "MainSheet" Then
        Set lastUsedSheet = Sh
        Sh.Activate
        GoTo SafeExit
    Else
        ' Temporarily send the user back to last sheet until
        ' Password has been successfully entered
        lastUsedSheet.Activate
    End If

    ' Set each sheet's password
    Dim sInputPW As String, sSheetPW As String

    Select Case Sh.Name
    Case "Sheet1"
        sSheetPW = "123456"
    Case "Sheet2"
        sSheetPW = "987654"
    End Select

    ' Create a loop that will keep prompting password
    '   until successful pw or empty string entered
    Do

        sInputPW = InputBox("Please enter password for the " & _
                "worksheet: " & Sh.Name & ".")

        If sInputPW = "" Then GoTo SafeExit

    Loop While sInputPW <> sSheetPW

    Set lastUsedSheet = Sh
    Sh.Activate

SafeExit:

    Application.EnableEvents = True
    If Err.Number <> 0 Then
        Debug.Print Time; Err.Description
        MsgBox Err.Description, Title:="Error # " & Err.Number
    End If

End Sub

旁注,禁用事件是必要的,因为Workbook_SheetActivate事件将在成功更换工作表后继续触发.

在¹期间防止文件类型更改SaveAs

您可以通过限制文件保存类型来进一步保护意外删除VBA代码.这可以使用该Workbook_BeforeSave()事件来完成.这是一个潜在问题的原因是,保存为非宏启用的工作簿将删除代码,这将阻止您刚才实现的密码保护功能.

首先,我们需要检查,如果这是一个Save或SaveAs.您可以使用SaveAsUI事件本身包含的Boolean属性来完成此操作.如果这个值是True,则它是一个SaveAs事件 - 这意味着我们需要执行额外的检查以确保不会从保存对话框中意外更改文件类型.如果值为False,则这是正常保存,我们可以绕过这些检查,因为我们知道工作簿将保存为类型.xlsm.

初步检查后,我们将使用显示对话框Application.FileDialog().Show.

之后,我们将检查用户是否取消了操作.SelectedItems.Count = 0或点击了Save.如果用户点击取消,那么我们只需设置Cancel = True,工作簿将无法保存.

我们继续使用此行检查用户选择的扩展类型:

If Split(fileName, ".")(UBound(Split(fileName, "."))) <> "xlsm" Then

这将按周期拆分文件路径.,并(UBound(Split(fileName, ".")))在文件名可能包含其他句点的情况下获取句点的最后一个实例.如果扩展名不匹配xlsm,则我们中止保存操作.

最后,在所有检查通过后,您可以保存文档:

Me.SaveAs .SelectedItems(1), 52

由于我们已经使用上面的行保存了它,我们可以继续设置Cancel = True并退出例程.

完整代码(将放在Worksheet obj模块中):

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

    On Error GoTo SafeExit

    If SaveAsUI Then
        With Application.FileDialog(msoFileDialogSaveAs)
            .Show
            If .SelectedItems.Count = 0 Then
                Cancel = True
            Else
                Dim fileName$
                fileName = .SelectedItems(1)
                If Split(fileName, ".")(UBound(Split(fileName, "."))) <> "xlsm" Then
                    MsgBox "You must save this as an .xlsm document. Document has " & _
                                "NOT been saved", vbCritical
                    Cancel = True
                Else
                    Application.EnableEvents = False
                    Application.DisplayAlerts = False
                    Me.SaveAs .SelectedItems(1), 52
                    Cancel = True
                End If
            End If
        End With
    Else
        Exit Sub
    End If

SafeExit:

    Application.EnableEvents = True
    Application.DisplayAlerts = True

    If Err.Number <> 0 Then
        Debug.Print Time; Err.Description
        MsgBox Err.Description, Title:="Error # " & Err.Number
    End If

End Sub

_{¹向ShtricK致敬,寻求建议}