vba编程控制excel输入不同的密码显示不同的sheet_excel vba制作登录界面不同的账户登录显示不同的sheet-CSDN博客

本文链接：https://blog.csdn.net/wltsysterm/article/details/89438414

都说office，似乎大家都知道office，甚至可以说都懂得office。真的懂嘛？

其实，我们只是用了office的1%不到的功能，

这不，扫地僧最近应公司同事的需求，帮他设计一份现有的excel表格的权限。大概实现的效果如下：

1、打开的时候，只显示默认的home-sheet，并提示请输入密码，根据不同的密码显示不同的sheet
2、vba编程入口需要口令才能进入
3、基于口令打开，再关闭excel之后，重新打开，要跟要求1的效果一样
4、跨软件打开要求实现一样的效果，比如用wps打开，如果不能输入口令，那么也不能展示其他的sheet

乍一看，不难呀！

其实这里头的道道还是挺多的。

先说下我是怎么实现的吧。

1、套路一：基于vba编程

上面的功能，没得说，一定得通过vba编程，那么什么是vba，小白同学请自行百度。

直接上代码：

Private Sub Workbook_Open()
    On Error Resume Next
    Dim psw$, YN$, sht As Worksheet
    ActiveWindow.DisplayWorkbookTabs = False
Line1:
    psw = InputBox("请输入你的密码：", "密码输入框")
    If psw = "shanghai1" Then
        Sheet10.Visible = xlSheetVisible
        Sheet10.Activate
        ActiveWindow.DisplayWorkbookTabs = True
        For Each sht In Worksheets
            If sht.CodeName <> "Sheet10" Then sht.Visible = xlSheetVeryHidden
        Next
    ElseIf psw = "shanxi2" Then
        Sheet11.Visible = xlSheetVisible
        Sheet11.Activate
        ActiveWindow.DisplayWorkbookTabs = True
        For Each sht In Worksheets
            If sht.CodeName <> "Sheet11" Then sht.Visible = xlSheetVeryHidden
        Next
    ElseIf psw = "1234567890" Then
        Sheet1.Visible = xlSheetVisible
        Sheet1.Activate
        ActiveWindow.DisplayWorkbookTabs = True
        For Each sht In Worksheets
            If sht.CodeName <> "Sheet1" Then sht.Visible = xlSheetVisible
        Next
    Else
        YN = MsgBox("密码错误！是否重新输入？", vbYesNo)
        If YN = vbYes Then GoTo Line1 Else ThisWorkbook.Close 0
    End If
    Sheet1.Visible = xlSheetVisible
End Sub

上面的代码实现的功能大概如下：

1）打开页面的时候，隐藏sheet栏。同时弹出窗口，提醒请输入你的密码。

2）当输入密码shanghai1的时候：显示sheet10这个sheet，同时显示sheet1。

3）当输入密码shanxi2的时候：显示sheet11这个sheet，同时显示sheet1。

4）当输入密码1234567890的时候：显示所有sheet。

5）否则，提示密码错误！是否重新输入？，如果选择是，那么回到1），否则直接关闭sheet栏

遗留问题

乍一看，好像已经满足要求了。但是细心的人经过测试会提出一个问题：

如果我输入密码shanghai1,这个时候点击关闭，同时选择保存。然后再重新打开，会出现，sheet1和sheet10同时都显示了，如果这个时候用wps打开，发现查看sheet10的内容根本不需要密码。

2、套路2：关闭时候复位

1的遗留问题，其实只需要在关闭的时候设置复位即可，怎么做呢，更简单了，直接上代码：

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    On Error Resume Next
    Dim sht As Worksheet
    For Each sht In Worksheets
       If sht.CodeName <> "Sheet1" Then sht.Visible = xlSheetVeryHidden
    Next
    Sheet1.Visible = xlSheetVisible
End Sub

这段代码的意思就是：在点击关闭之前，隐藏除了sheet1之外的所有sheet。

3、总结

经过上述总结大家知道怎么做了不。附上完整的vba代码:

Private Sub Workbook_Open()
    On Error Resume Next
    Dim psw$, YN$, sht As Worksheet
    ActiveWindow.DisplayWorkbookTabs = False
Line1:
    psw = InputBox("请输入你的密码：", "密码输入框")
    If psw = "shanghai1" Then
        Sheet10.Visible = xlSheetVisible
        Sheet10.Activate
        ActiveWindow.DisplayWorkbookTabs = True
        For Each sht In Worksheets
            If sht.CodeName <> "Sheet10" Then sht.Visible = xlSheetVeryHidden
        Next
    ElseIf psw = "shanxi2" Then
        Sheet11.Visible = xlSheetVisible
        Sheet11.Activate
        ActiveWindow.DisplayWorkbookTabs = True
        For Each sht In Worksheets
            If sht.CodeName <> "Sheet11" Then sht.Visible = xlSheetVeryHidden
        Next
    ElseIf psw = "1234567890" Then
        Sheet1.Visible = xlSheetVisible
        Sheet1.Activate
        ActiveWindow.DisplayWorkbookTabs = True
        For Each sht In Worksheets
            If sht.CodeName <> "Sheet1" Then sht.Visible = xlSheetVisible
        Next
    Else
        YN = MsgBox("密码错误！是否重新输入？", vbYesNo)
        If YN = vbYes Then GoTo Line1 Else ThisWorkbook.Close 0
    End If
    Sheet1.Visible = xlSheetVisible
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    On Error Resume Next
    Dim sht As Worksheet
    For Each sht In Worksheets
       If sht.CodeName <> "Sheet1" Then sht.Visible = xlSheetVeryHidden
    Next
    Sheet1.Visible = xlSheetVisible
End Sub

扫地僧测试使用的文件下载：测试.xls

================================================================

破解篇章（20200721）

上面已经讲解了如何按需访问sheet，但是扫地僧为了安全起见对vba入口进行设置密码了，因此有些人就问我，密码多少，时间过去太久了，我也忘记了。这边分享下针对这种情况如何去暴力破解密码的方式。

1. 新建一个excel，打开vba，然后在sheet1模块里头输入如下代码：

'移除VBA编码保护
Sub MoveProtect()
Dim FileName As String
FileName = Application.GetOpenFilename("Excel文件（*.xls & *.xla）,*.xls;*.xla", , "VBA破解")
If FileName = CStr(False) Then
Exit Sub
Else
VBAPassword FileName, False
End If
End Sub
'设置VBA编码保护
Sub SetProtect()
Dim FileName As String
FileName = Application.GetOpenFilename("Excel文件（*.xls & *.xla）,*.xls;*.xla", , "VBA破解")
If FileName = CStr(False) Then
Exit Sub
Else
VBAPassword FileName, True
End If
End Sub
Private Function VBAPassword(FileName As String, Optional Protect As Boolean = False)
If Dir(FileName) = "" Then
Exit Function
Else
FileCopy FileName, FileName & ".bak"
End If
Dim GetData As String * 5
Open FileName For Binary As #1
Dim CMGs As Long
Dim DPBo As Long
For i = 1 To LOF(1)
Get #1, i, GetData
If GetData = "CMG=""" Then CMGs = i
If GetData = "[Host" Then DPBo = i - 2: Exit For
Next
If CMGs = 0 Then
MsgBox "请先对VBA编码设置一个保护密码...", 32, "提示"
Exit Function
End If
If Protect = False Then
Dim St As String * 2
Dim s20 As String * 1
'取得一个0D0A十六进制字串
Get #1, CMGs - 2, St
'取得一个20十六制字串
Get #1, DPBo + 16, s20
'替换加密部份机码
For i = CMGs To DPBo Step 2
Put #1, i, St
Next
'加入不配对符号
If (DPBo - CMGs) Mod 2 <> 0 Then
Put #1, DPBo + 1, s20
End If
MsgBox "文件解密成功......", 32, "提示"
Else
Dim MMs As String * 5
MMs = "DPB="""
Put #1, CMGs, MMs
MsgBox "对文件特殊加密成功......", 32, "提示"
End If
Close #1
End Function

2. 执行上面的宏。再弹窗里头选择：