Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) 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 GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare PtrSafe Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As String) As LongPtr
Private Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
Private Declare PtrSafe Function GetDlgItem Lib "user32" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr
#Else
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA"(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA"(ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String,ByVal lpsz2 As String) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA"(ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long
Private Declare 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 Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wFlag As Long) As Long
Private Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
#End If
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 GW_CHILD = 5
Sub LockVBA()
Dim xlAp As Object, oWb As Object, hwndSysTab As LongPtr, sPassword, hCurrentDlg As LongPtr, wbLock
Set xlAp = CreateObject("Excel.Application")
Set oWb = xlAp.Workbooks.Add
Dim myModule As Object
Set myModule = oWb.VBProject.VBComponents.Add(1)
myModule.CodeModule.AddFromString ("Private Sub MyNewSub()" & vbNewLine & " Cells(1, 1) = 1" & vbNewLine & "End Sub")
xlAp.VBE.CommandBars(1).FindControl(ID:=2578, recursive:=True).Execute
sPassword = "1"
hCurrentDlg = FindWindow(vbNullString, "VBAProject - Project Properties")
If hCurrentDlg <> 0 Then
hwndSysTab = FindWindowEx(hCurrentDlg, 0, "SysTabControl32", vbNullString)
Call SendMessage(hwndSysTab, TCM_SETCURFOCUS, 1, 0)
Call SendMessage(hwndSysTab, TCM_SETCURSEL, 1, 0)
If SendMessage(GetDlgItem(GetNextWindow(hCurrentDlg, GW_CHILD), &H1557), BM_GETCHECK, 0, 0) = 0 Then
Call SendMessage(GetDlgItem(GetNextWindow(hCurrentDlg, GW_CHILD), &H1557), BM_SETCHECK, BST_CHECKED, 0)
Call SendMessage(GetDlgItem(GetNextWindow(hCurrentDlg, GW_CHILD), &H1555), WM_SETTEXT, 0, sPassword)
Call SendMessage(GetDlgItem(GetNextWindow(hCurrentDlg, GW_CHILD), &H1555), EM_SETMODIFY, True, 0)
Call SendMessage(GetDlgItem(GetNextWindow(hCurrentDlg, GW_CHILD), &H1556), WM_SETTEXT, 0, sPassword)
Call SendMessage(GetDlgItem(GetNextWindow(hCurrentDlg, GW_CHILD), &H1556), EM_SETMODIFY, True, 0)
End If
DoEvents
Call SendMessage(GetDlgItem(hCurrentDlg, &H1), BM_CLICK, 0, 0)
DoEvents
oWb.SaveAs Filename:=Environ("Temp") & "\1.xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
oWb.Close 0
xlAp.Quit
Else
MsgBox "VBAProject Window VBAProject - Project Properties was not Found"
End If
Set wbLock = Workbooks.Open(Filename:=Environ("Temp") & "\1.xlsm")
'wbLock.IsAddin = True
End Sub |
