Ever tried to open another workbook call a macro in it from your VBA code?
Easy, if the sub or function is declared 'public' at workbook level and is visible as a method of the workbook object. If it isn't (and, sometimes, even if it is) and the VB Project is locked, you'll need to go into the VBE editor and unlock it yourself.
In short: manual intervention is required.
For obvious reasons, there's no Project.Unprotect(sPassword) function: obvious, but not good,and definitely not convenient when you've been asked to re-run all the reports in a month of separate daily workbooks.
We'll gloss over that your office should probably be handling the data and the daily reporting process in a more efficient way: sometimes you get this kind of job and the rest s up to you.
We'll assume that you know the password and have the right to open and run these files... now what?
There's code out there to unlock a project using a truly horrible combination of SendKeys() strings. THIS code is marginally better, but not miraculously so: it works on identifying the windows and the handles of the controls, and sending Windows messages using the API functions.
Most of the time the messages work... More often, anyway, than Sendkeys does. And, as we're in a slightly better environment than a keystroke-passer, we can read the results and retry the messages when they fail.
Here's the function:
fUnlockProject(wbk As Excel.Workbook, strPwd As String) As Boolean
I'm assuming that you know how to open a workbook in VBA: if you can't, then this code sample probably isn't for you. Not only is at an advanced topic - API calls and window messages - but we're doing something that VBA really isn't designed to do.
On top of that, Blogger's HTML editor (whatever RSS feed you're viewing the blog post in!) will have munged at least one of the line breaks and, while I've succeeded in getting thhe code below to copy-and-paste into a new VBA module, I suspect that some of you will get at least one syntax error when you try.
Finally: read the comments below the function header. There's stuff in there that you need to know about the return value, and a hint about passing the workbook object.
Option Explicit
Option Private Module
' Requires a reference to the library :
' Microsoft Visual Basic for Applications Extensibility (v5.3)
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _
ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long _
) As Long
Private Declare Function SendMessageStr Lib "user32.dll" Alias "SendMessageA" ( _
ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String _
) As Long
Private Declare Function PostMessage Lib "user32.dll" Alias "PostMessageA" ( _
ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long _
) As Long
' SetText params for SendMessage and PostMessage:
' ms-help://MS.VSCC.v80/MS.MSDN.v80/MS.WIN32COM.v10.en/winui/winui/windowsuserinterface/windowing/windows/windowreference/windowmessages/wm_settext.htm
' wParam: This parameter is not used.
' lParam: Pointer to a null-terminated string that is the window text.
' Return Value: The return value is TRUE if the text is set.
' API Window Message Constants are documented here:
' ms-help://MS.VSCC.v80/MS.MSDN.v80/MS.WIN32COM.v10.en/winui/winui/windowsuserinterface/windowing/windows/windowreference/windowmessages/wm_close.htm
' ms-help://MS.VSCC.v80/MS.MSDN.v80/MS.WIN32COM.v10.en/shellcc/platform/commctls/buttons/buttonreference/buttonmessages/bm_click.htm
Private Declare Function GetWindowTextApi Lib "user32.dll" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetClassNameApi Lib "user32.dll" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Const WM_SETTEXT As Long = &HC
Private Const WM_CLOSE As Long = &H10
Private Const BM_CLICK = &HF5
Private Const SW_HIDE = 0
Private Const BM_SETCHECK As Long = &HF1&
Private Const BST_UNCHECKED = &H0&
Private Const BST_CHECKED As Long = &H1&
Private Const BST_INDETERMINATE = &H2&
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&
' Default Dialog control IDs
Private Const IDOK As Long = 1
Private Const IDCANCEL As Long = 2
' Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function SetFocus Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _
ByVal lpClassName As String, ByVal lpWindowName As String _
) As Long
' ms-help:'MS.VSCC.v80/MS.MSDN.v80/MS.WIN32COM.v10.en/winui/winui/windowsuserinterface/windowing/dialogboxes/dialogboxreference/dialogboxfunctions/getdlgitem.htm
' Retrieves the handle to a control in the specified dialog box.
' hDlg : [in] Handle to the dialog box that contains the control.
' nIDDlgItem: [in] Specifies the identifier of the control to be retrieved.
' returns : The window handle of the specified control indicates success. NULL indicates failure due to an invalid dialog box handle or a nonexistent control.
Private Declare Function GetDlgItem Lib "user32.dll" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
' ms-help://MS.VSCC.v80/MS.MSDN.v80/MS.WIN32COM.v10.en/winui/winui/windowsuserinterface/windowing/windows/windowreference/windowfunctions/setforegroundwindow.htm
' If the window was brought to the foreground, the return value is nonzero.
' If the window was not brought to the foreground, the return value is zero.
Private Declare Function SetForegroundWindow Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
Private Declare Function CharLower Lib "user32.dll" Alias "CharLowerA" (ByVal lpsz As String) As String
Private Declare Function CharUpper Lib "user32.dll" Alias "CharUpperA" (ByVal lpsz As String) As String
' Password windows caption suffix
Private Const DLG_PWD_CAP_SUFFIX As String = " Password"
' Project properties dialog caption suffix
Private Const DLG_PRJPROP_CAP_SUFFIX As String = " - Project properties"
' Project properties dialog hWnd
Private hWndProjectProperties As Long
' Caption of the dialog when a bad password is inserted
Private Const DLG_BADPWD_CAP As String = "Project Locked"
' Caption of the generic VBA error
Public Const DLG_VBERROR_CAP As String = "Microsoft Visual Basic"
' Dialog class
Private Const DIALOG_CLS As String = "#32770"
' Password dialog textfield control ID
Private Const PWD_DLG_EDIT_ID As Long = &H155E&
' Wait time for the windows search
Private Const WAIT_TIME As Long = 500
'
Public Function fUnlockProject(wbk As Excel.Workbook, strPwd As String) As Boolean
On Error Resume Next
' Unlock a VB project using a known password.
' You are advised to pass a wbk parameter that's opened in another Excel Application session.
' This one will probably crash if you try it locally.
' Returns True if all the dialog boxes were closed (indicating that the app can be safely closed).
' To know if the document project was unlocked successfully, use the .VBProject.Protection property.
' This code works by manipulating the windows of the VBE password dialogue in VBA.
' It's a step above the widely-published 'SendKeys' code. But that's faint praise:
' it's messy, and you'll soon find out why I use all those 'GoTo ...iRetry' blocks.
Dim appExcel As Excel.Application
Dim vbpProject As VBIDE.VBProject
Dim vbEditor As VBIDE.VBE
Dim i As Long
Dim lStart As Long
Dim sPPDlgCaption As String ' Project Properties dialog caption
Dim hDlgProjectProps As Long ' Project Properties dialog handle
Dim sPwdDlgCaption As String ' password dialog caption
Dim hDlgPassword As Long ' password dialog handle
Dim hPwdField As Long ' password dialog textbox handle
Dim hDlgBadPassword As Long ' a 'Bad Password' dialog handle
Dim iRetry As Long
' Menu bar
' \ Tools (msoControlPopup, ID:30007)
' \ Properties of
Dim cbMenuBar As CommandBar
Dim cbpTools As CommandBarPopup
Dim cbbProperties As CommandBarButton
Dim bDialogsCleared As Boolean
bDialogsCleared = True
'Application.EnableCancelKey = xlDisabled
Set appExcel = wbk.Application
Set vbEditor = appExcel.VBE
Set vbpProject = wbk.VBProject
' show Visual Basic Editor?
' If appExcel.VBE.MainWindow.visible = True Then
' appExcel.VBE.MainWindow.visible = False
' End If
' set the VBE active project
Set vbEditor.ActiveVBProject = vbpProject
' construct the password dialog caption
sPwdDlgCaption = vbpProject.Name & DLG_PWD_CAP_SUFFIX
' construct the 'project properties' dialog caption
sPPDlgCaption = vbpProject.Name & DLG_PRJPROP_CAP_SUFFIX
' Note that this could be structured as nested IF... THEN blocks, avoiding the use of 'GOTO'
' But 'drop-through or exit' is easier to follow when we use a 'go-back-and-retry' structure
' Try to acquire the menu bar
iRetry = 0
RetryGetMenuBar:
iRetry = iRetry + 1
If Not fGetMenuBar(vbEditor, cbMenuBar) Then
' Failed, retry 3 times
Call Sleep(32 * iRetry)
If iRetry < 4 Then
GoTo RetryGetMenuBar
Else
Debug.Print vbpProject.Name & vbTab & "fUnlockProject() - Menubar not found : " & Err.Description
GoTo ExitFunction
End If
End If ' menu bar successfully acquired
' try to find the 'Tools' menu
iRetry = 0
RetryGetToolsMenu:
iRetry = iRetry + 1
Set cbpTools = cbMenuBar.FindControl(ID:="30007")
If (cbpTools Is Nothing) Then
' Failed, retry 3 times
Call Sleep(32 * iRetry)
If iRetry < 4 Then
GoTo RetryGetToolsMenu
Else
Debug.Print vbpProject.Name & vbTab & "fUnlockProject() - Tools menu not found : " & Err.Description
GoTo ExitFunction
End If
End If
' try to get the 'project properties' menu item
iRetry = 0
RetryGetProjProps:
iRetry = iRetry + 1
Call fGetPopupItem(cbpTools, "2578", cbbProperties)
CloseNamedDialog DLG_VBERROR_CAP
If (cbbProperties Is Nothing) Then
'Failed, Retry 3 times
Call Sleep(32 * iRetry)
If iRetry < 4 Then
GoTo RetryGetProjProps
Else
Debug.Print vbpProject.Name & vbTab & "fUnlockProject() : Properties menu item not found."
GoTo ExitFunction
End If
End If
' Execute the 'project properties' menu item action
Call cbbProperties.Execute
' Test an unlikely outcome: the project properties window
' opened up straightaway, indicating there was no password:
hDlgProjectProps = 0
hDlgProjectProps = FindWindow(DIALOG_CLS, sPPDlgCaption)
If hDlgProjectProps <> 0 Then
GoTo ExitFunction
End If
' Get the password dialog's window handle:
hDlgPassword = 0
hDlgPassword = FindWindow(DIALOG_CLS, sPwdDlgCaption)
' Test the password dialog exists, retry if it does not:
iRetry = 0
RetryGetPwdDialog:
iRetry = iRetry + 1
If hDlgPassword = 0 And iRetry < 3 Then
' Close any 'bad password' or VB Error windows
CloseNamedDialog DLG_VBERROR_CAP
CloseNamedDialog DLG_BADPWD_CAP
' Try getting the hWnd of the password dialog again:
hDlgPassword = FindWindow(DIALOG_CLS, sPwdDlgCaption)
If hDlgPassword = 0 Then
Call Sleep(32 * iRetry)
End If
If hDlgPassword = 0 Then
GoTo RetryGetPwdDialog
End If
End If
If hDlgPassword = 0 And iRetry < 4 Then
CloseNamedDialog DLG_VBERROR_CAP
CloseNamedDialog DLG_BADPWD_CAP
' Try reopening the dialog from the menu, then get the hwnd:
Call cbbProperties.Execute
Call Sleep(32 * iRetry)
hDlgPassword = (FindWindow(DIALOG_CLS, sPwdDlgCaption))
If hDlgPassword = 0 Then
Call Sleep(32 * iRetry)
End If
If hDlgPassword = 0 Then
GoTo RetryGetPwdDialog
End If
End If
If hDlgPassword = 0 Then
Debug.Print vbpProject.Name & vbTab & "fUnlockProject(): cannot open the password dialog."
GoTo ExitFunction
End If
' Get the password textbox
hPwdField = 0
hPwdField = GetDlgItem(hDlgPassword, PWD_DLG_EDIT_ID)
' Test the password textbox exists, retry if it does not:
iRetry = 0
RetryGetPwdTextbox:
iRetry = iRetry + 1
If hPwdField = 0 And iRetry < 4 Then
CloseNamedDialog DLG_VBERROR_CAP
CloseNamedDialog DLG_BADPWD_CAP
hPwdField = GetDlgItem(hDlgPassword, PWD_DLG_EDIT_ID)
If hPwdField = 0 Then
Call Sleep(32 * iRetry)
End If
If hPwdField = 0 Then
GoTo RetryGetPwdTextbox
End If
End If
If hPwdField = 0 Then
Debug.Print vbpProject.Name & vbTab & "fUnlockProject(): cannot find the password textbox."
bDialogsCleared = CloseWindow(hDlgPassword)
GoTo ExitFunction
End If
'Fill in the password text:
iRetry = 0
RetrySetText:
iRetry = iRetry + 1
If SendMessageStr(hPwdField, WM_SETTEXT, 0&, strPwd) = 0 Then
' zero return indicates a failed set-text operation
Call Sleep(32 * iRetry)
Select Case iRetry
Case Is < 4
GoTo RetrySetText
Case Is < 5
CloseNamedDialog DLG_VBERROR_CAP
CloseNamedDialog DLG_BADPWD_CAP
hDlgPassword = (FindWindow(DIALOG_CLS, sPwdDlgCaption))
hPwdField = GetDlgItem(hDlgPassword, PWD_DLG_EDIT_ID)
GoTo RetrySetText
Case Is < 6
CloseNamedDialog DLG_VBERROR_CAP
CloseNamedDialog DLG_BADPWD_CAP
CloseWindow hDlgPassword
GoTo RetryGetPwdDialog
Case Else
Debug.Print vbpProject.Name & vbTab & "fUnlockProject() : Unable to enter password '" & strPwd & "' into the textbox."
bDialogsCleared = CloseWindow(hDlgPassword)
GoTo ExitFunction
End Select
End If
' Click the 'Ok' button
iRetry = 0
RetryClickOK:
iRetry = iRetry + 1
' PostMessage returns the results of the 'click': nonzero indicates success
If PostMessage(GetDlgItem(hDlgPassword, IDOK), BM_CLICK, 0&, 0&) = 0 Then
Select Case iRetry
Case Is < 4
Call Sleep(32 * iRetry)
GoTo RetryClickOK
Case 4
CloseNamedDialog DLG_BADPWD_CAP
CloseNamedDialog DLG_VBERROR_CAP
Call SetForegroundWindow(hDlgPassword)
GoTo RetryClickOK
Case Else
Debug.Print vbpProject.Name & vbTab & "fUnlockProject() : Unable to click 'OK' for this password."
bDialogsCleared = CloseWindow(hDlgPassword)
GoTo ExitFunction
End Select
End If ' fClickButton failed
' fClickButton returned true, telling us that control
' has returned to the OK button's parent dialog.
' However, that could also mean that the button wasn't clicked at all:
hDlgPassword = 0
hDlgPassword = FindWindow(DIALOG_CLS, sPwdDlgCaption)
If hDlgPassword <> 0 Then
Select Case iRetry
Case Is < 4
Call Sleep(32 * iRetry)
GoTo RetryClickOK
Case 4
CloseNamedDialog DLG_BADPWD_CAP
CloseNamedDialog DLG_VBERROR_CAP
Call SetForegroundWindow(hDlgPassword)
GoTo RetryClickOK
Case Else
Debug.Print vbpProject.Name & vbTab & "fUnlockProject() : Unable to click 'OK' for this password."
bDialogsCleared = CloseWindow(hDlgPassword)
GoTo ExitFunction
End Select
End If
bDialogsCleared = False
' Inspect the results of the click
' No retry block here: retrying Window-open operations, clicks and SetTexts is fine
' - or rather, a messy necessity - but the password itself either worked or failed.
' Two possible outcomes: 1 Password success opened a 'project properties' dialog
' 2 Password failure opened a 'bad password' dialog
If CloseNamedDialog(DLG_BADPWD_CAP) = 0 Then ' no 'bad password' dialog to close
hDlgProjectProps = 0
hDlgProjectProps = FindWindow(DIALOG_CLS, sPPDlgCaption)
If hDlgProjectProps = 0 Then
Call Sleep(250)
End If
If hDlgProjectProps <> 0 Then
' Opened the 'Properties' screen, which means: PASSWORD SUCCESSFUL!
Debug.Print "PASSWORD: " & strPwd & vbTab & wbk.FullName
'Close the project properties dialog: try the OK button first
bDialogsCleared = fClickButton(hDlgProjectProps, IDOK)
End If 'successful password
Else
' Bad password dialog detected & closed... Our password Failed
End If
ExitFunction:
CloseNamedDialog DLG_BADPWD_CAP
CloseNamedDialog DLG_VBERROR_CAP
hDlgProjectProps = FindWindow(DIALOG_CLS, sPPDlgCaption)
bDialogsCleared = bDialogsCleared And CloseWindow(hDlgPassword) And CloseWindow(hDlgProjectProps)
If (bDialogsCleared) Then
' all the dialog boxes were closed
fUnlockProject = True
End If
Set cbbProperties = Nothing
Set cbpTools = Nothing
Set cbMenuBar = Nothing
vbEditor.MainWindow.Close
Set vbEditor = Nothing
Set appExcel = Nothing
End Function
Private Function fGetDialogHnd(sCaption, hDlg As Long) As Boolean
' Get the handle of the dialog whose the caption is specified.
' Return True if the dialog was found.
hDlg = (FindWindow(DIALOG_CLS, sCaption))
fGetDialogHnd = (hDlg <> 0)
End Function
Private Function fClickButton(hDlg As Long, lButtonID As Long) As Boolean
' Programmatically click on a button in a command bar or menu, specified by ID
' Return False if the button owner was not activated or the 'click' failed
Dim hButton As Long
' get the button handle
hButton = GetDlgItem(hDlg, lButtonID)
' active the dialog box (hDlg) and click on the button
If PostMessage(hButton, BM_CLICK, 0&, 0&) <> 0 Then
fClickButton = True
End If
End Function
Private Function fGetMenuBar(oContainer As Object, cb As CommandBar) As Boolean
' Get the menu bar of the specified container:
' oContainer can be any object which has a CommandBars collection.
' Return True if the menu bar was found.
Dim i As Long
On Error Resume Next
For i = 1 To oContainer.CommandBars.Count
Set cb = oContainer.CommandBars(i)
If (cb.Type = msoBarTypeMenuBar) Then
fGetMenuBar = True
Exit For
End If
Next i
On Error GoTo 0
End Function
Private Function fGetPopupItem(cbp As CommandBarPopup, sControlID As String, cbc As CommandBarControl) As Boolean
' Get a control from a commandbar or menu, by specifying the control's ID
Dim i As Long
For i = 1 To cbp.Controls.Count
Set cbc = cbp.Controls(i)
If (cbc.ID = sControlID) Then
fGetPopupItem = True
Exit For
End If
Next i
End Function
Private Function TrimNulls(ByVal sString As String) As String
' Trims trailing nulls
Dim iPos As Integer
iPos = InStr(sString, Chr$(0))
Select Case iPos
Case 0
TrimNulls = sString
Case 1
TrimNulls = ""
Case Else ' iPos > 1
TrimNulls = left$(sString, iPos - 1)
End Select
End Function
Private Function fUCase(ByVal sString As String) As String
If (Len(sString) >= 2) Then
fUCase = CharUpper(left$(sString, 1)) & _
CharLower(right$(sString, Len(sString) - 1))
Else
fUCase = sString
End If
End Function
Private Function IsArrayEmpty(va As Variant) As Boolean
' Incorporates fix from Torsten Rendelmann (MVPS - Hardcore VB)
Dim i As Long
On Error Resume Next
i = LBound(va, 1)
IsArrayEmpty = (Err.Number <> 0)
On Error GoTo 0 ' Err.Clear
End Function
Private Function CloseWindow(hWnd As Long) As Boolean
Dim iRetry As Integer
CloseWindow = False
RetryCloseWindow:
iRetry = iRetry + 1
If SendMessage(hWnd, WM_CLOSE, 0&, 0&) = 0& Then
CloseWindow = True
Else
CloseWindow = False
CloseNamedDialog DLG_VBERROR_CAP
Call Sleep(32 * iRetry)
If iRetry < 4 Then
GoTo RetryCloseWindow
End If
End If
End Function
Public Function CloseNamedDialog(sDialogCaption As String) As Long
'Returns window handle of last-closed window
On Error Resume Next
Dim iCount As Integer
Dim hwnDialog As Long
Err.Clear
CloseNamedDialog = 1
hwnDialog = FindWindow(DIALOG_CLS, sDialogCaption)
Do Until hwnDialog = 0
iCount = iCount + 1
SendMessage hwnDialog, WM_CLOSE, 0&, 0&
CloseNamedDialog = hwnDialog
hwnDialog = FindWindow(DIALOG_CLS, sDialogCaption)
If iCount > 1 Then
Sleep 10 * iCount
SetFocus hwnDialog
End If
If iCount > 3 Then
' something's stopping us closing the window
Exit Do
End If
Loop
End Function
Public Sub CloseGenericError()
On Error Resume Next
CloseNamedDialog DLG_VBERROR_CAP
Application.OnTime EarliestTime:=Now() + (1# / 24# / 1200#), Procedure:="CloseGenericError"
End Sub
Private Function ClickButton(hWndOwner As Long, hWndButton As Long) As Boolean
On Error Resume Next
SetForegroundWindow hWndOwner
SetFocus hWndButton
PostMessage hWndButton, BM_CLICK, 0&, 0&
End Function
Private Function GetWindowText(ByVal hWnd As Long) As String
Dim sBuffer As String
Dim lBufferLen As Long
sBuffer = String$(512, 0)
lBufferLen = GetWindowTextApi(hWnd, sBuffer, Len(sBuffer))
GetWindowText = left$(sBuffer, lBufferLen)
End Function
Private Function GetClassName(ByVal hWnd As Long) As String
Dim sBuffer As String
Dim lBufferLen As Long
sBuffer = String$(512, 0)
lBufferLen = GetClassNameApi(hWnd, sBuffer, Len(sBuffer))
GetClassName = left$(sBuffer, lBufferLen)
End Function
No comments:
Post a Comment