使用 VBA 保护 VBAProject

Question

我有一个包含很多 VBA 的主工作簿，它从其他工作簿收集数据，操作这些数据，最后将数据输出写入一个本身包含一些 VBA 的新工作簿。此输出工作簿发送给许多人应该不能够更改或查看 VBA。 因此我必须从查看中锁定 VBAProject。由于我的主要工作簿的用户根本没有 VBA 技能，我不会让他们锁定 VBAProject（在 VBA 编辑器中：菜单工具/VBAProject 属性.../保护/锁定项目以供查看/等）。我宁愿使用 VBA 锁定 VBAProject。 我已经看到几个 SendKeys 做到了这一点。但是，我不喜欢使用 SendKeys。相反，我更喜欢“真正的”VBA - 但是如何做到这一点？也许通过使用一些 Windows API 函数？ - 我一点也不熟悉，但如果我只需要复制/粘贴一些代码就可以使用。 ;-)

Answer 1

最后，我提出了如下所示的解决方案。它将在 Excel 64 位上运行，但可能很容易更改为 32 位（请参阅代码中的建议）。我已经在 Excel 2016 上对其进行了测试。

' Helge V. Larsen (MSc, PhD)
' Helge@Engfred.dk
' HELA Consulting
' January 2022.

' Regarding Windows API: Very much inspired by the late Howard Kaikow:
' http://www.standards.com/Office/SetVBAProjectPassword.html
'
' Author: Howard Kaikow
' URL   : http://www.standards.com/
' Email : kaikow@standards.com
' Date  : April 2005

' This will run in Excel 64 bit.
' It will probably run in Excel 32 bit
' if you remove all "PtrSafe" and change all "LongPtr" to "Long".
' (I cannot test it since I do not have access to Exccel 32 bit.)
'
' Alternatively, you could use compiler directives
'     #If VBA7 Then
'     #Else
'     #End If
' to make it run in Excel 32 and 64 bit    .

Option Explicit

' API constants
Private Const BM_CLICK As Long = &HF5&
Private Const BM_SETCHECK As Long = &HF1&
Private Const BST_CHECKED As Long = &H1&
Private Const EM_REPLACESEL As Long = &HC2&
Private Const HWND_TOPMOST As Long = -1
Private Const SWP_NOACTIVATE As Long = &H10&
Private Const SWP_NOMOVE As Long = &H2&
Private Const SWP_NOSIZE As Long = &H1&
Private Const SWP_SHOWWINDOW As Long = &H40&
Private Const TCM_SETCURFOCUS As Long = &H1330&

' API functions and subs
Private Declare PtrSafe Function EnumChildWindows Lib "user32" _
    (ByVal hWndParent As LongPtr, ByVal lpEnumFunc As LongPtr, ByVal lParam As Long) As Long
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
    (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function GetDlgItem Lib "user32.dll" _
    (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As Long
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" _
    (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare PtrSafe Function SetFocusAPI Lib "user32" Alias "SetFocus" _
    (ByVal hWnd As Long) As Long
Private Declare PtrSafe Sub SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, _
    ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long)

Private hWndProjectProperties As LongPtr

Sub HVL_Lock_VBProject()
    
    ' Protect VBProject in workbook.
    ' The workbook is opened in another instance of Excel.
    
    Dim appExcel As Excel.Application
    Dim wbkExcel As Excel.Workbook
    
    Dim aFile As String
    Dim Pass  As String
    
    aFile = HVL_GetFile_Dialog("Browse for Excel workbook", ThisWorkbook.Path, "Excel files, *.xl*,")
    If aFile = vbNullString Then Exit Sub
    
    Set appExcel = New Excel.Application
    appExcel.Visible = False
    
    Set wbkExcel = appExcel.Workbooks.Open(aFile)
    
    If wbkExcel.VBProject.Protection = vbext_pp_none Then
       Pass = HVL_Get_PassWord
       If Pass = vbNullString Then GoTo Exit_Sub
       SetPassword wbkExcel.VBProject, Pass
    Else ' vbext_pp_locked
       MsgBox "The VBproject in" & vbCr & _
              aFile & vbCr & _
              "is protected." & vbCr & vbCr & _
              "Cannot change Project Password.", _
              vbInformation, _
              "Information"
       GoTo Exit_Sub
    End If
    
    wbkExcel.Save
    wbkExcel.Close False
    
    MsgBox "The VBproject in" & vbCr & _
           aFile & vbCr & _
           "has been locked.", _
           vbInformation, _
           "Information"
    
Exit_Sub:

    appExcel.Quit
    
    Set appExcel = Nothing
    Set wbkExcel = Nothing

End Sub

Sub SetPassword(ByRef aVBProject As VBProject, ByVal strPassword As String)

    ' Author: Howard Kaikow
    ' URL   : http://www.standards.com/
    ' Email : kaikow@standards.com
    ' Date  : April 2005
    ' spy++ was used to find the Control IDs in Project Properties dialog
    
    ' Changed by Helge V. Larsen.

    Const ControlIDConfirmPassword As Long = &H1556&
    Const ControlIDLockProject As Long = &H1557&
    Const ControlIDOK As Long = &H1&
    Const ControlIDPassword As Long = &H1555&
    Const ControlIDSysTabControl32 As Long = &H3020&
    
    Dim Ctrl As Office.CommandBarControl
    Dim hWnd As Long
    Dim hWndLockProject As Long
    Dim hWndPassword As Long
    Dim hWndConfirmPassword As Long
    Dim hWndOK As Long
    Dim hWndSysTabControl32 As Long
    Dim strCaption As String
    
    With aVBProject
        strCaption = .Name & " - Project Properties"
        With .VBE
            ' Find Project Properties dialog
            Set Ctrl = .CommandBars.FindControl(ID:=2578)
            ' Display Project Properties dialog
            Ctrl.Execute
            Set Ctrl = Nothing
        End With
    End With
    
    ' Get hWnd for Project Properties dialog
    hWndProjectProperties = FindWindow(vbNullString, strCaption)
    If hWndProjectProperties = 0 Then
        Exit Sub
    End If

    ' Get hWnd for OK button in Project Properties dialog
    hWndOK = GetDlgItem(hWndProjectProperties, ControlIDOK)
    
    ' Get hWnd for Tab Control in Project Properties dialog
    hWndSysTabControl32 = GetDlgItem(hWndProjectProperties, ControlIDSysTabControl32)

    'Move to Protection tab
    SendMessage hWndSysTabControl32, TCM_SETCURFOCUS, 1, ByVal 0&

    ' Must reset hWndProjectProperties probably because tab changed.
    EnumChildWindows ByVal hWndProjectProperties, AddressOf EnumChildProc, ByVal 0
    
    ' Get hWnd for Password Edit control in Project Properties dialog
    hWndPassword = GetDlgItem(hWndProjectProperties, ControlIDPassword)
    
    ' Get hWnd for Confirm Password Edit control in Project Properties dialog
    hWndConfirmPassword = GetDlgItem(hWndProjectProperties, ControlIDConfirmPassword)
    
    ' Get hWnd for Lock Project checkbox control in Project Properties dialog
    hWndLockProject = GetDlgItem(hWndProjectProperties, ControlIDLockProject)

    ' Lock project for &viewing
    SendMessage hWndLockProject, BM_SETCHECK, BST_CHECKED, 0

    ' &Password
    SendMessage hWndPassword, EM_REPLACESEL, vbTrue, ByVal strPassword

    ' &Confirm password
    SendMessage hWndConfirmPassword, EM_REPLACESEL, vbTrue, ByVal strPassword

    'OK button
    SetFocusAPI hWndOK
    SendMessage hWndOK, BM_CLICK, 0&, 0&
    
End Sub

Function EnumChildProc(ByVal hWnd As LongPtr, ByVal lParam As Long) As Long
    hWndProjectProperties = hWnd
    ' Do not recurse
    EnumChildProc = 0
End Function

Function HVL_GetFile_Dialog(Optional DialogTitle As String, _
                            Optional InitDirectory As String, _
                            Optional Filter As String, _
                            Optional InitView As Office.MsoFileDialogView = msoFileDialogViewDetails) As String

    ' Filter: e.g. "Data bases, *.mdb; *.accdb"

    Dim Filter_Arr As Variant
    Dim ViewType   As Office.MsoFileDialogView

    With Application.FileDialog(msoFileDialogFilePicker)
        .InitialView = InitView
        .AllowMultiSelect = False
         
         If DialogTitle <> vbNullString Then .Title = DialogTitle
         
         If Dir(InitDirectory, vbDirectory) <> vbNullString Then
           .InitialFileName = InitDirectory
         Else
           .InitialFileName = CurDir
         End If
         
         If Filter <> vbNullString Then
            Filter_Arr = Split(Filter, ",")
           .Filters.Add Trim(Filter_Arr(0)), Trim(Filter_Arr(1)), 1
         End If
         
         If .Show = True Then
             HVL_GetFile_Dialog = .SelectedItems(1)
         Else
             HVL_GetFile_Dialog = vbNullString
         End If
         
    End With

End Function

Function HVL_Get_PassWord()

    Dim Pass1 As String
    Dim Pass2 As String

    Pass1 = InputBox("Enter VBproject password:", "Lock VBroject")
    If Pass1 = vbNullString Then GoTo No_Password
    
    Pass2 = InputBox("Caution: If you loose or forget the password," & vbCr & _
                     "it cannot be recovered. It is advisable to keep" & vbCr & _
                     "a list of passwords and their corresponding" & vbCr & _
                     "workbook names in a safe place." & vbCr & _
                     "(Remember that passwords are case-sensitive.)" & vbCr & vbCr & _
                     "Confirm VBproject password:", _
                     "Lock VBproject")
    If Pass2 = vbNullString Then GoTo No_Password
    
    If Pass1 <> Pass2 Then
       MsgBox "Confirmation password is not identical!", vbCritical, "Error"
       GoTo No_Password
    End If
    
    HVL_Get_PassWord = Pass1
    
    Exit Function
    
No_Password:
    HVL_Get_PassWord = vbNullString
    
End Function