Судя по комментариям, это не столько проблема безопасности, сколько проблема удобства.Поэтому имейте в виду, что при внедрении этого в ваш проект это легко сломать, если есть злонамеренное намерение получить несанкционированный доступ.
Во-первых, я бы рекомендовал общая зона посадки .Основной рабочий лист, который отображается сразу после открытия рабочей книги.Для этого мы будем использовать событие 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 1
Вы можете дополнительно защитить случайное удаление кода VBA, ограничив тип сохранения файла.Это можно сделать с помощью события Workbook_BeforeSave().Причина, по которой это является потенциальной проблемой, заключается в том, что сохранение как рабочей книги без макросов сотрет код, что предотвратит использование функций защиты паролем, которые вы только что реализовали.
Во-первых, нам нужно проверить, является ли этоSave или SaveAs.Вы можете сделать это, используя логическое свойство SaveAsUI, которое включено в само событие.Если это значение True, то это событие SaveAs - это означает, что нам нужно выполнить дополнительные проверки, чтобы гарантировать, что тип файла не был случайно изменен из диалогового окна сохранения.Если значение False, то это обычное сохранение, и мы можем обойти эти проверки, потому что мы знаем, что рабочая книга будет сохранена как тип .xlsm.
После этой начальной проверки мы отобразимдиалоговое окно с использованием Application.FileDialog().Show.
Затем мы проверим, отменил ли пользователь операцию .SelectedItems.Count = 0 или нажал Сохранить .Если пользователь нажал кнопку «Отмена», то мы просто установили Cancel = True, и рабочая книга не будет сохранена.
Мы приступаем к проверке типа расширения, выбранного пользователем с помощью этой строки:
If Split(fileName, ".")(UBound(Split(fileName, "."))) <> "xlsm" Then
Это разделит путь к файлу на период . и захватит последний экземпляр периода (UBound(Split(fileName, "."))) в том случае, если имя файла может содержать дополнительные периоды.Если расширение не соответствует xlsm, то мы прекращаем операцию сохранения.
Наконец, после всех проверок вы можете сохранить документ:
Me.SaveAs .SelectedItems(1), 52
Поскольку мы уже сохранили егос помощью приведенной выше строки мы можем установить Cancel = True и выйти из подпрограммы.
Полный код (для размещения в модуле 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
1 Привет PatricK за предложение