Option Explicit
' http://www.cpearson.com/excel/vbe.aspx ' other vbe code
' http://www.vbaexpress.com/forum/showthread.php?p=277605 ' unlock project
' http://www.standards.com/Office/SetV...tPassword.html
Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" ( _
ByVal hwndParent As Long, ByVal hwndChildAfter As Long, _
ByVal lpszClass As String, ByVal lpszWindow As String) As Long
Declare Function GetWindow Lib "user32" ( _
ByVal hwnd As Long, ByVal uCmd As Long) As Long
Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Declare Function GetDlgItem Lib "user32" ( _
ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
Declare Function GetDesktopWindow Lib "user32" () As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
ByVal hwnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Declare Function SetFocusAPI Lib "user32" Alias "SetFocus" ( _
ByVal hwnd As Long) As Long
Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
' Added 3 functions - Kenneth Hobson
Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Public Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function SendMessageLong& Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long)
Private Declare Function GetForegroundWindow Lib "user32" () As Long
' Dialog Box Command IDs
Public Const IDOK = 1
Public Const IDCANCEL = 2
Public Const IDABORT = 3
Public Const IDRETRY = 4
Public Const IDIGNORE = 5
Public Const IDYES = 6
Public Const IDNO = 7
Public Const WM_CLOSE = &H10
Public Const WM_GETTEXT = &HD
Public Const EM_REPLACESEL = &HC2
Public Const EM_SETSEL = &HB1
Public Const BM_CLICK = &HF5&
Public Const TCM_SETCURFOCUS = &H1330&
Private Const TimeoutSecond = 2
Private g_ProjectName As String
Private g_Password As String
Private g_hwndVBE As Long
Private g_Result As Long
Private g_hwndPassword As Long
Public Function UnlockTimerProc(ByVal hwnd As Long, ByVal uMsg As Long, _
ByVal idEvent As Long, ByVal dwTime As Long) As Long
Dim hwndProjectProp As Long, hwndProjectProp2 As Long
Dim hwndTab As Long, hwndLockProject As Long, hwndPassword As Long
Dim hwndConfirmPassword As Long, hwndOK As Long
Dim hWndTmp As Long, lRet As Long
Dim IDTab As Long, IDLockProject As Long, IDPassword As Long
Dim IDConfirmPassword As Long, IDOK As Long
Dim sCaption As String
Dim timeout As Date, timeout2 As Date
Dim pwd As String
On Error GoTo ErrorHandler
KillTimer 0, idEvent
IDTab = &H3020&
IDLockProject = &H1557&
IDPassword = &H155E&
IDConfirmPassword = &H1556&
IDOK = &H1&
sCaption = " Password"
'for the japanese version
Select Case Application.LanguageSettings.LanguageID(msoLanguageIDUI)
Case 1041
sCaption = ChrW(&H30D7) & ChrW(&H30ED) & ChrW(&H30B8) & _
ChrW(&H30A7) & ChrW(&H30AF) & ChrW(&H30C8) & _
ChrW(&H20) & ChrW(&H30D7) & ChrW(&H30ED) & _
ChrW(&H30D1) & ChrW(&H30C6) & ChrW(&H30A3)
End Select
sCaption = g_ProjectName & sCaption
timeout = Now() + TimeSerial(0, 0, TimeoutSecond)
Do While Now() < timeout
hwndPassword = 0
hwndOK = 0
hWndTmp = 0
Do
hWndTmp = FindWindowEx(0, hWndTmp, vbNullString, sCaption)
If hWndTmp = 0 Then Exit Do
Loop Until GetParent(hWndTmp) = g_hwndVBE
If hWndTmp = 0 Then GoTo Continue
Debug.Print "found window"
lRet = SendMessage(hWndTmp, TCM_SETCURFOCUS, 1, ByVal 0&)
hwndPassword = GetDlgItem(hWndTmp, IDPassword)
Debug.Print "hwndpassword: " & hwndPassword
hwndOK = GetDlgItem(hWndTmp, IDOK)
Debug.Print "hwndOK: " & hwndOK
If (hWndTmp _
And hwndOK) = 0 Then GoTo Continue
lRet = SetFocusAPI(hwndPassword)
lRet = SendMessage(hwndPassword, EM_SETSEL, 0, ByVal -1&)
lRet = SendMessage(hwndPassword, EM_REPLACESEL, 0, ByVal g_Password)
pwd = String(260, Chr(0))
lRet = SendMessage(hwndPassword, WM_GETTEXT, Len(pwd), ByVal pwd)
pwd = Left(pwd, InStr(1, pwd, Chr(0), 0) - 1)
If pwd <> g_Password Then GoTo Continue
lRet = SetTimer(0, 0, 100, AddressOf ClosePropertiesWindow)
lRet = SetFocusAPI(hwndOK)
lRet = SendMessage(hwndOK, BM_CLICK, 0, ByVal 0&)
g_Result = 1
Exit Do
Continue:
DoEvents
Sleep 100
Loop
Exit Function
ErrorHandler:
If hwndPassword <> 0 Then SendMessage hwndPassword, WM_CLOSE, 0, ByVal 0&
LockWindowUpdate 0
End Function
Function UnlockProject(ByVal Project As Object, ByVal Password As String) As Long
Dim timeout As Date
Dim lRet As Long
On Error GoTo ErrorHandler
UnlockProject = 1
If Project.Protection <> vbext_pp_locked Then
UnlockProject = 2
Exit Function
End If
g_ProjectName = Project.Name
g_Password = Password
' LockWindowUpdate GetDesktopWindow()
Application.VBE.MainWindow.Visible = True
g_hwndVBE = Application.VBE.MainWindow.hwnd
g_Result = 0
lRet = SetTimer(0, 0, 100, AddressOf UnlockTimerProc)
If lRet = 0 Then
Debug.Print "error setting timer"
GoTo ErrorHandler
End If
Set Application.VBE.ActiveVBProject = Project
If Not Application.VBE.ActiveVBProject Is Project Then
GoTo ErrorHandler
End If
Application.VBE.CommandBars.FindControl(ID:=2578).Execute
timeout = Now() + TimeSerial(0, 0, TimeoutSecond)
Do While g_Result = 0 And Now() < timeout
DoEvents
Loop
If g_Result Then
UnlockProject = 0
End If
AppActivate Application.Caption
LockWindowUpdate 0
Exit Function
ErrorHandler:
AppActivate Application.Caption
LockWindowUpdate 0
End Function
Sub Test_UnlockProject()
Select Case UnlockProject(ActiveWorkbook.VBProject, "myPassword")
Case 0: MsgBox "The project was unlocked."
Case 2: MsgBox "The active project was already unlocked."
Case Else: MsgBox "Error or timeout."
End Select
End Sub
Function ClosePropertiesWindow(ByVal hwnd As Long, ByVal uMsg As Long, _
ByVal idEvent As Long, ByVal dwTime As Long) As Long
Dim timeout As Date
Dim hWndTmp As Long
Dim hwndOK As Long
Dim lRet As Long
Dim sCaption As String
sCaption = g_ProjectName & " - Project Properties"
Debug.Print sCaption
On Error GoTo ErrorHandler
KillTimer 0, idEvent
timeout = Now() + TimeSerial(0, 0, TimeoutSecond)
Do While Now() < timeout
hWndTmp = 0
Do
hWndTmp = FindWindowEx(0, hWndTmp, vbNullString, sCaption)
If hWndTmp = 0 Then Exit Do
Loop Until GetParent(hWndTmp) = g_hwndVBE
If hWndTmp = 0 Then GoTo Continue
Debug.Print "found properties window"
lRet = SendMessage(hWndTmp, TCM_SETCURFOCUS, 1, ByVal 0&)
hwndOK = GetDlgItem(hWndTmp, IDOK)
Debug.Print "hwndOK: " & hwndOK
If (hWndTmp _
And hwndOK) = 0 Then GoTo Continue
lRet = SetFocusAPI(hwndOK)
lRet = SendMessage(hwndOK, BM_CLICK, 0, ByVal 0&)
g_Result = 1
Exit Do
Continue:
DoEvents
Sleep 100
Loop
Exit Function
ErrorHandler:
Debug.Print Err.Number
LockWindowUpdate 0
End Function
Project locked for viewing - SendKeys?
Reply With Quote
Originally Posted by theta
