问使用VBA保护VBAProject

EN

' 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