启用分组时保留现有的Excel工作表保护 [英] Retaining Existing Excel Worksheet Protection When Enabling Grouping

问题描述

我正在尝试允许在工作表中进行分组(EnableOutlining).下面是一个允许它的典型示例，但它也会按照指定的方式重置所有保护属性.不幸的是，我不知道现有的属性是什么.设置分组属性时，是否有一种简单的方法来保留现有保护属性?

I'm trying to allow grouping in worksheets (EnableOutlining). Below is a typical example that allows it but it also resets all of the protection attributes as specified. Unfortunately I don't know what the existing attributes are. Is there a simple way of retaining the existing protection attributes when I set the grouping attribute?

Private Sub Workbook_Open()
' Modified from http://www.clickconsulting.com/forum/excel-support/grouping-protected-worksheet
' NOTE: It is not necessary to unprotect a worksheet to change the protection settings.
' Reference: https://exceloffthegrid.com/vba-code-worksheet-protection/
' https://stackoverflow.com/questions/37419714/unprotect-sheet-prompt-for-pw-only-when-allowfiltering-true?rq=1

Dim pw As String

pw = "Secret"
For Each ws In Sheets
   With ws
        If .ProtectContents = True Then
           .Protect Password:=pw, UserInterfaceOnly:=True
           .EnableOutlining = True
       End If
    End With
Next ws

End Sub

如何保留现有设置而不是覆盖它们?

How do I retain existing settings rather than overwrite them?

.Protect Password:=pw, _
DrawingObjects:=False, _
Contents:=True, _
Scenarios:=False, _
UserInterfaceOnly:=True, _
AllowFormattingCells:=True, _
AllowFormattingColumns:=True, _
AllowFormattingRows:=True, _
AllowInsertingColumns:=True, _
AllowInsertingRows:=True, _
AllowInsertingHyperlinks:=True, _
AllowDeletingColumns:=True, _
AllowDeletingRows:=True, _
AllowSorting:=True, _
AllowFiltering:=True, _
AllowUsingPivotTables:=True

我也欢迎任何有关如何管理硬编码密码的评论.

I'd welcome any comments on how to manage a hard-coded password too.

推荐答案

这有点麻烦，但是使用了一个函数来收集字典中的当前保护属性，然后在再次锁定时使用这些字典设置来设置保护.我没有为所有条件编写代码(在底部列出).可以对其进行修订，以生成字典词典，以捕获不同的工作表或在循环中部署函数.我欢迎您提供有关如何改进此问题的反馈.

This is a little long winded but uses a function to collect the current protection properties in a dictionary and then uses those dictionary settings to set the protection when locking again. I haven't code for all conditions (listed at bottom). This could be revised to produce a dictionary of dictionaries to capture for the different sheets or deploy the function in a loop. I would welcome feedback on how to improve this.

Option Explicit

Public myDict As Scripting.Dictionary

Sub test()

    Dim wb As Workbook
    Dim ws As Worksheet

    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Sheet2")

    Set myDict = WorksheetProtectionSettings(ws)

    ws.Unprotect Password:="password"

    ws.Protect Password:="password", DrawingObjects:=myDict("ProtectDrawingObjects"), Contents:=myDict("ProtectContents") 'ToDo: extend with other arguments.......

End Sub

Private Function WorksheetProtectionSettings(ByVal ws As Worksheet) As Dictionary
'tools > references > ms scripting runtime library

Set myDict = New Scripting.Dictionary

With ws

    If .ProtectDrawingObjects = True Then
        myDict.Add "ProtectDrawingObjects", True
    Else
        myDict.Add "ProtectDrawingObjects", False
    End If

    If .ProtectContents = True Then
        myDict.Add "ProtectContents", True
    Else
        myDict.Add "ProtectContents", False
    End If

    'ToDo: Add other conditions.......

End With

Set WorksheetProtectionSettings = myDict

End Function

'https://msdn.microsoft.com/en-us/vba/excel-vba/articles/worksheet-protect-method-excel
'Password
'Worksheet.ProtectDrawingObjects
'Worksheet.ProtectContents
'Worksheet.ProtectScenarios
'Worksheet.ProtectionMode
'Protection.AllowFormattingCells
'Protection.AllowFormattingColumns
'Protection.AllowFormattingRows
'Protection.AllowInsertingColumns
'Protection.AllowInsertingRows
'Protection.AllowInsertingHyperlinks
'Protection.AllowDeletingColumns
'Protection.AllowDeletingRows
'Protection.AllowSorting
'Protection.AllowFiltering
'Protection.AllowUsingPivotTables

由于@TimWilliams，看来我还可以通过

Thanks to @TimWilliams it seems I can also access those properties commencing with "Protect" via then CallByName function:

Dim result As Boolean
result = CallByName(ws, "ProtectDrawingObjects", VbGet)
MsgBox result

在Tim对我的问题的回答中给出了更多信息

More info given on this in Tim's answer to my question here.

这篇关于启用分组时保留现有的Excel工作表保护的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！