我想用密码保护vbaproject新添加的工作簿并关闭工作簿。我正在使用 Excel 2021。
我找到了如何以编程方式设置密码 vba 项目的代码。
Option Explicit
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0& To 7&) As Byte
End Type
#If VBA7 Then
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hMod As LongPtr, ByVal dwThreadId As Long) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hhk As LongPtr) As Long
Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare PtrSafe Function GetDlgItem Lib "user32" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hwnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As Long
Private Declare PtrSafe Function SendMessageByString Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As String) As Long
Private Declare PtrSafe Function SetFocus Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare PtrSafe Function SetActiveWindow Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Sub SetLastError Lib "Kernel32.dll" (ByVal dwErrCode As Long)
Private Declare PtrSafe Function DispCallFunc Lib "OleAut32.dll" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
Private Declare PtrSafe Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByRef lpiid As Any) As Long
Private Declare PtrSafe Function CoCreateInstance Lib "ole32" (ByRef rclsid As GUID, ByVal pUnkOuter As LongPtr, ByVal dwClsContext As Long, ByRef riid As GUID, ByRef ppv As LongPtr) As Long
Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal OleStringCLSID As LongPtr, ByRef cGUID As Any) As Long
#Else
Private Enum LongPtr
[_]
End Enum
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hMod As LongPtr, ByVal dwThreadId As Long) As LongPtr
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hhk As LongPtr) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function GetDlgItem Lib "user32" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr
Private Declare Function GetActiveWindow Lib "user32" () As LongPtr
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hwnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As Long
Private Declare Function SetFocus Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function SetActiveWindow Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare Sub SetLastError Lib "Kernel32.dll" (ByVal dwErrCode As Long)
Private Declare Function DispCallFunc Lib "OleAut32.dll" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByRef lpiid As Any) As Long
Private Declare Function CoCreateInstance Lib "ole32" (ByRef rclsid As GUID, ByVal pUnkOuter As LongPtr, ByVal dwClsContext As Long, ByRef riid As GUID, ByRef ppv As LongPtr) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal OleStringCLSID As LongPtr, ByRef cGUID As Any) As Long
#End If
Private lHook As LongPtr, oProject As Object, sWinClassName As String, _
sWorkbookName As String, sPassword As String, bNotify As Boolean, bHooked As Boolean
Public Property Let LockVBProject( _
ByVal WorkbookName As String, _
ByVal Password As String, _
Optional ByVal NotifyUser As Boolean, _
ByVal bLock As Boolean _
)
Const WH_CBT = 5&
Dim hwnd As LongPtr
If bHooked Then Exit Property
hwnd = GetActiveWindow: bNotify = NotifyUser: bHooked = True
On Error GoTo ErrHandler
With Application.VBE
Set .ActiveVBProject = Application.Workbooks(WorkbookName).VBProject
Set oProject = .ActiveVBProject
If bLock Then
If .ActiveVBProject.Protection = 0 Then
sWinClassName = "VBAProject - Project Properties"
sWorkbookName = WorkbookName
Else
MsgBox "VBProect already locked.": Exit Property
End If
Else
If .ActiveVBProject.Protection Then
sWinClassName = "VBAProject Password"
Else
MsgBox "VBProect already unlocked.": Exit Property
End If
End If
End With
sPassword = Password
lHook = SetWindowsHookEx(WH_CBT, AddressOf Catch_DlgBox_Activation, 0, GetCurrentThreadId)
Application.VBE.CommandBars(1&).FindControl(ID:=2578, recursive:=True).Execute
bHooked = False
Exit Property
ErrHandler:
Call UnHook
bHooked = False
MuteSpeakers False
If Err.Number = 9 Then
MsgBox "Error : " & Err.Number & vbNewLine & vbNewLine & "Invalid Project Name.", vbExclamation
Else
MsgBox "Runtime Error : " & Err.Number & vbCr & vbCr & Err.Description, vbExclamation
End If
End Property
Private Function Catch_DlgBox_Activation( _
ByVal idHook As Long, _
ByVal wParam As LongPtr, _
ByVal lParam As LongPtr _
) As LongPtr
Const HCBT_ACTIVATE = 5, SWP_HIDEWINDOW = &H80
Dim sBuff As String * 256, lRet As Long
Dim hwnd As LongPtr
If idHook = HCBT_ACTIVATE Then
lRet = GetClassName(wParam, sBuff, 256&)
If Left(sBuff, lRet) = "#32770" Then
sBuff = ""
lRet = GetWindowText(wParam, sBuff, 256&)
If Left(sBuff, lRet) = sWinClassName Then
Call UnHook
SetWindowPos wParam, 0, 0&, 0&, 0&, 0&, SWP_HIDEWINDOW
Call SetTimer(Application.hwnd, wParam, 0, AddressOf Protect_UnProtect_Routine)
End If
End If
End If
Catch_DlgBox_Activation = CallNextHookEx(lHook, idHook, ByVal wParam, ByVal lParam)
End Function
Private Sub UnHook()
Call UnhookWindowsHookEx(lHook)
End Sub
Private Sub UnHook2()
Call UnHook
MuteSpeakers False
If bNotify Then
If IsProjectUnLocked Then
MsgBox "Project successfully unlocked!", vbInformation
Else
MsgBox "Failed to unlock the VBProject!" & vbNewLine & vbNewLine & _
"Passwords are Case-Sensitive ... Make sure the provided Password is correct.", vbExclamation
End If
End If
End Sub
Private Function IsProjectUnLocked() As Boolean
IsProjectUnLocked = CBool(oProject.Protection = 0)
End Function
Private Sub Protect_UnProtect_Routine( _
ByVal hwnd As LongPtr, _
ByVal uMsg As Long, _
ByVal nIDEvent As LongPtr, _
ByVal dwTimer As Long _
)
Const TCM_FIRST = &H1300
Const TCM_SETCURSEL = (TCM_FIRST + 12&)
Const TCM_SETCURFOCUS = (TCM_FIRST + 48&)
Const EM_SETMODIFY = &HB9
Const BM_SETCHECK = &HF1
Const BST_CHECKED = &H1
Const BM_GETCHECK = &HF0
Const BM_CLICK = &HF5
Const WM_SETTEXT = &HC
Const WH_CBT = 5&
Const GW_CHILD = 5&
Dim hCurrentDlg As LongPtr, hwndSysTab As LongPtr
Dim sBuff As String * 256, lRet As Long
On Error GoTo ErrHandler
Call KillTimer(Application.hwnd, nIDEvent)
hCurrentDlg = nIDEvent
If sWinClassName = "VBAProject - Project Properties" Then
hwndSysTab = FindWindowEx(hCurrentDlg, 0, "SysTabControl32", vbNullString)
Call SendMessage(hwndSysTab, TCM_SETCURFOCUS, 1, ByVal 0&)
Call SendMessage(hwndSysTab, TCM_SETCURSEL, 1, ByVal 0&)
Call SendMessage(GetDlgItem(GetNextWindow(hCurrentDlg, GW_CHILD), &H1557), BM_SETCHECK, BST_CHECKED, ByVal 0&)
Call SendMessageByString(GetDlgItem(GetNextWindow(hCurrentDlg, GW_CHILD), &H1555), WM_SETTEXT, 0, sPassword)
Call SendMessage(GetDlgItem(GetNextWindow(hCurrentDlg, GW_CHILD), &H1555), EM_SETMODIFY, True, ByVal 0&)
Call SendMessageByString(GetDlgItem(GetNextWindow(hCurrentDlg, GW_CHILD), &H1556), WM_SETTEXT, 0, sPassword)
Call SendMessage(GetDlgItem(GetNextWindow(hCurrentDlg, GW_CHILD), &H1556), EM_SETMODIFY, True, ByVal 0&)
Call SendMessage(GetDlgItem(hCurrentDlg, &H1), BM_CLICK, 0, ByVal 0&)
Call Application.OnTime(Now, "SaveVBProjectChanges")
ElseIf sWinClassName = "VBAProject Password" Then
MuteSpeakers True 'temporarly mute the system sounds\speakers to avoid awful sound when running Catch_DlgBox_Creation
If SendMessageByString(GetDlgItem(hCurrentDlg, &H155E), WM_SETTEXT, 0, sPassword) Then
Call SendMessage(GetDlgItem(hCurrentDlg, &H155E), EM_SETMODIFY, True, ByVal 0&)
lHook = SetWindowsHookEx(WH_CBT, AddressOf Catch_DlgBox_Creation, 0, GetCurrentThreadId)
lRet = GetWindowText(GetActiveWindow, sBuff, 256&)
If Left(sBuff, lRet) = "VBAProject Password" Then
Call SendMessage(GetDlgItem(hCurrentDlg, &H1), BM_CLICK, 0, ByVal 0&)
Call SendMessage(GetDlgItem(GetActiveWindow, &H2), BM_CLICK, 0, ByVal 0&)
Else
Call SendMessage(GetDlgItem(hCurrentDlg, &H1), BM_CLICK, 0, ByVal 0&)
End If
Call Application.OnTime(Now + TimeSerial(0, 0, 3), "UnHook2") 'wait 3 secs before unmuting the speakers.
End If
End If
Exit Sub
ErrHandler:
Call UnHook2
MsgBox "Runtime Error : " & Err.Number & vbCr & vbCr & Err.Description, vbExclamation
End Sub
Private Function Catch_DlgBox_Creation( _
ByVal idHook As Long, _
ByVal wParam As LongPtr, _
ByVal lParam As LongPtr _
) As LongPtr
Const HCBT_CREATEWND = 3&
Dim sBuff As String * 256, lRet As Long
If idHook = HCBT_CREATEWND Then
lRet = GetClassName(wParam, sBuff, 256)
If Left(sBuff, lRet) = "#32770" Then
Catch_DlgBox_Creation = -1
Exit Function
End If
End If
Catch_DlgBox_Creation = CallNextHookEx(lHook, idHook, ByVal wParam, ByVal lParam)
End Function
Private Sub SaveVBProjectChanges()
On Error Resume Next
Application.EnableEvents = False
Workbooks(sWorkbookName).Save
Application.EnableEvents = True
End Sub
Private Sub MuteSpeakers(Optional ByVal bMute As Boolean = True)
Const CLSID_MMDeviceEnumerator = "{BCDE0395-E52F-467C-8E3D-C4579291692E}"
Const IID_IMMDeviceEnumerator = "{A95664D2-9614-4F35-A746-DE8DB63617E6}"
Const IID_IAudioEndpointVolume = "{5CDF2C82-841E-4546-9722-0CF74078229A}"
Const IID_NULL = "{00000000-0000-0000-0000-000000000000}"
Const CLSCTX_INPROC_SERVER = 1&
Const CC_STDCALL = 4&
#If Win64 Then
Const NULL_PTR = 0^
Const PTR_SIZE = 8&
#Else
Const NULL_PTR = 0&
Const PTR_SIZE = 4&
#End If
Dim tClsID As GUID, tIID As GUID
Dim pDeviceEnumerator As LongPtr, pdefaultDevice As LongPtr, pIAudioEndpointVolume As LongPtr
Dim eRender As Long, eMultimedia As Long
Dim lRet As Long
lRet = CLSIDFromString(StrPtr(CLSID_MMDeviceEnumerator), tClsID)
lRet = IIDFromString(StrPtr(IID_IMMDeviceEnumerator), tIID)
'Create an enumerator for the audio endpoint devices
lRet = CoCreateInstance(tClsID, NULL_PTR, CLSCTX_INPROC_SERVER, tIID, pDeviceEnumerator)
If lRet Then MsgBox "Failed to get IMMDeviceEnumerator.": Exit Sub
eRender = 0&: eMultimedia = 1&
'IMMDeviceEnumerator::GetDefaultAudioEndpoint Method.
lRet = vtblCall(pDeviceEnumerator, 4& * PTR_SIZE, vbLong, CC_STDCALL, eRender, eMultimedia, VarPtr(pdefaultDevice))
If lRet Then MsgBox "Failed to get IMMDevice.": Exit Sub
lRet = IIDFromString(StrPtr(IID_IAudioEndpointVolume), tIID)
'IMMDevice::Activate Method.
lRet = vtblCall(pdefaultDevice, 3& * PTR_SIZE, vbLong, CC_STDCALL, VarPtr(tIID), CLSCTX_INPROC_SERVER, 0&, VarPtr(pIAudioEndpointVolume))
If lRet Then MsgBox "Failed to get IAudioEndpointVolume.": Exit Sub
lRet = IIDFromString(StrPtr(IID_NULL), tIID)
lRet = vtblCall(pIAudioEndpointVolume, 14& * PTR_SIZE, vbLong, CC_STDCALL, CLng(Abs(bMute)), VarPtr(tIID))
'Release Interfaces.
lRet = vtblCall(pIAudioEndpointVolume, 2& * PTR_SIZE, vbLong, CC_STDCALL)
lRet = vtblCall(pdefaultDevice, 2& * PTR_SIZE, vbLong, CC_STDCALL)
lRet = vtblCall(pDeviceEnumerator, 2& * PTR_SIZE, vbLong, CC_STDCALL)
End Sub
Private Function vtblCall( _
ByVal InterfacePointer As LongPtr, _
ByVal VTableOffset As Long, _
ByVal FunctionReturnType As Long, _
ByVal CallConvention As Long, _
ParamArray FunctionParameters() As Variant _
) As Variant
Dim vParamPtr() As LongPtr
If InterfacePointer = 0& Or VTableOffset < 0& Then Exit Function
If Not (FunctionReturnType And &HFFFF0000) = 0& Then Exit Function
Dim pIndex As Long, pCount As Long
Dim vParamType() As Integer
Dim vRtn As Variant, vParams() As Variant
vParams() = FunctionParameters()
pCount = Abs(UBound(vParams) - LBound(vParams) + 1&)
If pCount = 0& Then
ReDim vParamPtr(0& To 0&)
ReDim vParamType(0& To 0&)
Else
ReDim vParamPtr(0& To pCount - 1&)
ReDim vParamType(0& To pCount - 1&)
For pIndex = 0& To pCount - 1&
vParamPtr(pIndex) = VarPtr(vParams(pIndex))
vParamType(pIndex) = VarType(vParams(pIndex))
Next
End If
pIndex = DispCallFunc(InterfacePointer, VTableOffset, CallConvention, FunctionReturnType, pCount, _
vParamType(0&), vParamPtr(0&), vRtn)
If pIndex = 0& Then
vtblCall = vRtn
Else
SetLastError pIndex
End If
End Function
Sub ProtectVBProj(ByRef WB As Workbook, ByVal Pwd As String)
Dim vbProj As Object
Set vbProj = WB.VBProject
If vbProj.Protection = 1 Then Exit Sub ' already protected
Set Application.VBE.ActiveVBProject = vbProj
SendKeys "%TE+{TAB}{RIGHT}%V%P" & Pwd & "%C" & Pwd & "{TAB}{ENTER}"
End Sub
两种方法都可以在以下代码中正常工作，无需关闭工作簿，即没有行 xWB.Close savechanges:=True:
如果没有关闭工作簿的行，密码将保存在新添加的工作簿中。现有工作簿中不会保存密码。
但是，当该行关闭工作簿时，密码将不会保存在新添加的工作簿中。密码将保存在现有工作簿中。
Public Sub exportWB()
Const sFFPath As String = "D:\A.xlsm"
Dim xWB As Workbook
Set xWB = Workbooks.Add
'LockVBProject(WorkbookName:=xWB.name, Password:="1234") = True
ProtectVBProj xWB, "1234"
xWB.SaveAs Filename:=sFFPath, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, _
ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges
xWB.Close savechanges:=True 'The line with problem
End Sub
有办法解决吗？预先感谢。
感谢 Jaafar Tribak，解决方法是使用 Application.OnTime，如下所示。谢谢贾法尔·特里巴克。
Sub exportWB()
Const sFFPath As String = "D:\A.xlsm"
Dim xWB As Workbook
Set xWB = Workbooks.Add
LockVBProject(WorkbookName:=xWB.Name, Password:="password") = True
xWB.VBProject.VBComponents.Add (1) 'vbext_ct_StdModule
xWB.SaveAs Filename:=sFFPath, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, _
ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges
Application.OnTime Now, "'SaveNow """ & xWB.Name & "'"
Set xWB = Nothing
End Sub
Sub SaveNow(ByVal sWbkName As String)
Workbooks(sWbkName).Close savechanges:=True
End Sub