我正在尝试共享一个Excel工作簿,但是只能访问几个可见的工作表。由于Excel的安全漏洞和工作表的密码保护,事实证明,这比最初预期的要难得多。
我的问题是由于某些隐藏的工作表需要保持隐藏并且无法访问内容,但是如果结果显示在可见的工作表中,则需要进行计算。
到目前为止,我已经尝试在VBA窗口中“超级隐藏”图纸并锁定VBA项目。这样的想法是,如果没有VBA项目密码,用户将无法取消隐藏“超级隐藏”工作表。我曾尝试添加其他VBA代码来应对某些“攻击”,但我仍会回到一个已知的漏洞,该漏洞会绕过我的所有努力:
步骤1:保存或确保Excel工作簿另存为.xlsx或.xlsm
步骤2:从其他工作簿或您的personal.xlsb运行以下代码,该代码从工作表和结构保护中删除密码(我应该链接到找到代码的帖子,但现在找不到它...)。
Sub RemoveProtection()
Dim dialogBox As FileDialog
Dim sourceFullName As String
Dim sourceFilePath As String
Dim SourceFileName As String
Dim sourceFileType As String
Dim newFileName As Variant
Dim tempFileName As String
Dim zipFilePath As Variant
Dim oApp As Object
Dim FSO As Object
Dim xmlSheetFile As String
Dim xmlFile As Integer
Dim xmlFileContent As String
Dim xmlStartProtectionCode As Double
Dim xmlEndProtectionCode As Double
Dim xmlProtectionString As String
'Open dialog box to select a file
Set dialogBox = Application.FileDialog(msoFileDialogFilePicker)
dialogBox.AllowMultiSelect = False
dialogBox.Title = "Select file to remove protection from"
If dialogBox.show = -1 Then
sourceFullName = dialogBox.SelectedItems(1)
Else
Exit Sub
End If
'Get folder path, file type and file name from the sourceFullName
sourceFilePath = Left(sourceFullName, InStrRev(sourceFullName, "\"))
sourceFileType = Mid(sourceFullName, InStrRev(sourceFullName, ".") + 1)
SourceFileName = Mid(sourceFullName, Len(sourceFilePath) + 1)
SourceFileName = Left(SourceFileName, InStrRev(SourceFileName, ".") - 1)
'Use the date and time to create a unique file name
tempFileName = "Temp" & Format(Now, " dd-mmm-yy h-mm-ss")
'Copy and rename original file to a zip file with a unique name
newFileName = sourceFilePath & tempFileName & ".zip"
On Error Resume Next
FileCopy sourceFullName, newFileName
If Err.Number <> 0 Then
MsgBox "Unable to copy " & sourceFullName & vbNewLine _
& "Check the file is closed and try again"
Exit Sub
End If
On Error GoTo 0
'Create folder to unzip to
zipFilePath = sourceFilePath & tempFileName & "\"
MkDir zipFilePath
'Extract the files into the newly created folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(zipFilePath).CopyHere oApp.Namespace(newFileName).Items
'loop through each file in the \xl\worksheets folder of the unzipped file
xmlSheetFile = Dir(zipFilePath & "\xl\worksheets\*.xml*")
Do While xmlSheetFile <> ""
'Read text of the file to a variable
xmlFile = FreeFile
Open zipFilePath & "xl\worksheets\" & xmlSheetFile For Input As xmlFile
xmlFileContent = Input(LOF(xmlFile), xmlFile)
Close xmlFile
'Manipulate the text in the file
xmlStartProtectionCode = 0
xmlStartProtectionCode = InStr(1, xmlFileContent, "<sheetProtection")
If xmlStartProtectionCode > 0 Then
xmlEndProtectionCode = InStr(xmlStartProtectionCode, _
xmlFileContent, "/>") + 2 '"/>" is 2 characters long
xmlProtectionString = Mid(xmlFileContent, xmlStartProtectionCode, _
xmlEndProtectionCode - xmlStartProtectionCode)
xmlFileContent = Replace(xmlFileContent, xmlProtectionString, "")
End If
'Output the text of the variable to the file
xmlFile = FreeFile
Open zipFilePath & "xl\worksheets\" & xmlSheetFile For Output As xmlFile
Print #xmlFile, xmlFileContent
Close xmlFile
'Loop to next xmlFile in directory
xmlSheetFile = Dir
Loop
'Read text of the xl\workbook.xml file to a variable
xmlFile = FreeFile
Open zipFilePath & "xl\workbook.xml" For Input As xmlFile
xmlFileContent = Input(LOF(xmlFile), xmlFile)
Close xmlFile
'Manipulate the text in the file to remove the workbook protection
xmlStartProtectionCode = 0
xmlStartProtectionCode = InStr(1, xmlFileContent, "<workbookProtection")
If xmlStartProtectionCode > 0 Then
xmlEndProtectionCode = InStr(xmlStartProtectionCode, _
xmlFileContent, "/>") + 2 ''"/>" is 2 characters long
xmlProtectionString = Mid(xmlFileContent, xmlStartProtectionCode, _
xmlEndProtectionCode - xmlStartProtectionCode)
xmlFileContent = Replace(xmlFileContent, xmlProtectionString, "")
End If
'Manipulate the text in the file to remove the modify password
xmlStartProtectionCode = 0
xmlStartProtectionCode = InStr(1, xmlFileContent, "<fileSharing")
If xmlStartProtectionCode > 0 Then
xmlEndProtectionCode = InStr(xmlStartProtectionCode, xmlFileContent, _
"/>") + 2 ''"/>" is 2 characters long
xmlProtectionString = Mid(xmlFileContent, xmlStartProtectionCode, _
xmlEndProtectionCode - xmlStartProtectionCode)
xmlFileContent = Replace(xmlFileContent, xmlProtectionString, "")
End If
'Output the text of the variable to the file
xmlFile = FreeFile
Open zipFilePath & "xl\workbook.xml" & xmlSheetFile For Output As xmlFile
Print #xmlFile, xmlFileContent
Close xmlFile
'Create empty Zip File
Open sourceFilePath & tempFileName & ".zip" For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
'Move files into the zip file
oApp.Namespace(sourceFilePath & tempFileName & ".zip").CopyHere _
oApp.Namespace(zipFilePath).Items
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(sourceFilePath & tempFileName & ".zip").Items.count = _
oApp.Namespace(zipFilePath).Items.count
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
'Delete the files & folders created during the sub
Set FSO = CreateObject("scripting.filesystemobject")
FSO.deletefolder sourceFilePath & tempFileName
'Rename the final file back to an xlsx file
Name sourceFilePath & tempFileName & ".zip" As sourceFilePath & SourceFileName _
& "_" & Format(Now, "dd-mmm-yy h-mm-ss") & "." & sourceFileType
'Show message box
MsgBox "The workbook and worksheet protection passwords have been removed.", _
vbInformation + vbOKOnly, Title:="Password protection"
End Sub
步骤3:运行以下代码以取消隐藏所有工作表
Sub UnhideAllSheets()
For Each Worksheet In ActiveWorkbook.Sheets
Worksheet.Visible = -1
Next Worksheet
End Sub
该工作簿现在清除了工作表上的密码和结构保护,并且通过将工作簿另存为.xlsx文件,所有“反” VBA代码都消失了。
我已经考虑过添加一个用户定义的函数,该函数检查工作簿文件的扩展名是否为“ .xlsb”。如果扩展名是“ .xlsb”,该函数将返回“ 1”,然后将其乘以重要的值。如果将工作簿另存为其他内容,或者将VBA项目完全删除以另存为.xlsx,这将导致计算失败。但是,我不喜欢这种方法,因为我认为这不是一个长期解决方案...
因此,我的问题是:有没有一种方法可以安全地共享Excel工作簿,而只能访问几个工作表,而又不会冒着用户可以访问隐藏的工作表和/或不需要的内容的风险?