VBA Power Point equivilant of xlveryhidden - vba

Power Point 2016
I want to hide a shape, but I don't want the user to be able to unhide it except for programmatically essentially
shape.visible = xlVeryHidden

It is possible to do this programmatically using PowerPoint events to detect the selection of your 'marked' shape, hide it and then unselect it. I have used this mechanism in several of my PowerPoint add-in products before and it works very well. It requires the following elements:
VBA code in class module for PowerPoint app events
VBA code in standard module
Initialisation of app events via the ribbon onLoad callback
Identification mechanism for the shape(s) you want to hide. Tags work best but you could also use the simpler .Name property
Use of Win API timer to trigger a check for shapes unhidden using the Selection Pane
Solution code contained within either a macro-enabled PowerPoint file (.pptm, .potm, .ppsm) or a PowerPoint application add-in (.ppam)
Here is tested code: (not production quality, for example, doesn't handle non-slide views)
In a class module called "clsAppEvents":
' Source code provided by youpresent.co.uk
Option Explicit
Public WithEvents App As Application
Private Sub App_WindowSelectionChange(ByVal Sel As Selection)
Debug.Print "Event : App_WindowSelectionChange"
If Sel.Type = ppSelectionShapes Then CheckSelection
End Sub
Private Sub App_PresentationClose(ByVal Pres As Presentation)
StopTimer
End Sub
In a standard module called "Main":
' Source code provided by youpresent.co.uk
Option Explicit
'Create a new event handler object from the event class
Public oEH As New clsAppEvents
' Ribbon callback to initialise PowerPoint events
Public Sub OnLoadRibbon(ribbon As IRibbonUI)
Set oEH.App = Application
Debug.Print "PowerPoint App Events Initialised"
StartTimer
End Sub
' Timer initiated check to see if Very Hidden shapes have been unhidden using the Selection Pane
Public Sub CheckShapes()
Dim lCurSlide As Long
Dim oShp As Shape
Dim bFound As Boolean
lCurSlide = ActiveWindow.View.Slide.SlideIndex
For Each oShp In ActivePresentation.Slides(lCurSlide).Shapes
If oShp.Name = "VeryHidden" Then oShp.Visible = msoFalse
Next
End Sub
' Selection change event initialised check to see if selection is Very Hidden
Public Sub CheckSelection()
Dim oShp As Shape
Dim bFound As Boolean
StopTimer
For Each oShp In ActiveWindow.Selection.ShapeRange
If oShp.Name = "VeryHidden" Then
oShp.Visible = msoFalse
bFound = True
End If
Next
If bFound Then ActiveWindow.Selection.Unselect
StartTimer
End Sub
In a standard module called "WinTimer":
' Source code provided by youpresent.co.uk
Option Explicit
Public TimerID As Long
Public TimerCycles As Long
' Source : https://support.microsoft.com/kb/180736?wa=wsignin1.0
#If VBA7 Then
Private Declare PtrSafe Function SetTimer Lib "user32" _
(ByVal hwnd As LongPtr, _
ByVal nIDEvent As LongPtr, _
ByVal uElapse As LongPtr, _
ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare Function KillTimer Lib "user32" _
(ByVal hwnd As LongPtr, _
ByVal nIDEvent As LongPtr) As LongPtr
#Else
Private Declare Function SetTimer Lib "user32" _
(ByVal hwnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" _
(ByVal hwnd As Long, _
ByVal nIDEvent As Long) As Long
#End If
' Starts the time with uElapse time-out period in milliseconds
Public Function StartTimer()
TimerID = SetTimer(0, 0, 100, AddressOf TimerProc)
If TimerID = 0 Then Debug.Print "Timer not created.": Exit Function
Debug.Print "Timer " & TimerID & " started at : " & Now
End Function
Private Function TimerProc(ByVal hwnd As Long, _
ByVal uMsg As Long, _
ByVal idEvent As Long, _
ByVal dwTime As Long)
TimerCycles = TimerCycles + 1
If TimerCycles Mod 10 = 0 Then Debug.Print "Timer " & TimerID & " running : " & TimerCycles
CheckShapes
End Function
Public Function StopTimer()
Dim tmpTimerID As Long
tmpTimerID = TimerID
' If the KillTimer function succeeds, the return value is nonzero.
' If the KillTimer function fails, the return value is zero.
TimerID = KillTimer(0, TimerID)
If TimerID = 0 Then
Debug.Print "Couldn't kill the timer"
Else
Debug.Print "Timer " & tmpTimerID & " stopped at : " & Now & " with " & TimerCycles & " cycles"
End If
TimerCycles = 0
TimerID = 0
End Function
And finally, add this ribbon XML to the macro-enabled pptm/ppam/ppsm/potm file:
<customUI onLoad="OnLoadRibbon" xmlns="http://schemas.microsoft.com/office/2006/01/customui"/>
Now, if you open the macro-enabled file and add a shape to any slide with a name "VeryHidden" you shouldn't be able to unhide it via the PowerPoint UI. Of course, tags should be used instead of names but this is just to prove the concept.

There is no such equivalent in PowerPoint. Any hidden shape can be made visible from the selection pane.

Related

How to put data in the blank field of the dialog box

I created a tool that clicks an item on a webpage in IE, then the webpage dialog box pops up, I need to put data in the blank field of the dialog box using VBA.
I can't view the source code of the dialog box manually (right click). The webpage and URL are confidential, so I can't share that. I am using FindWindow function to find a webpage dialog box, and it returns the HWND value successfully. Here is my code:
Sub FindWebDialog()
Dim hwnd As Long
hwnd = FindWindow(vbNullString, "Live Payments -- Webpage Dialog")
If hwnd <> 0 Then
'get the htmldocument
Else
MsgBox "no dialog found"
End If
End Sub
I think that if I get the return value of the FindWindow, from there I can retrieve the source code of the webpage dialog box, then use it to find the exact location of the blank field. I would like to know how to get the source code of the webpage dialog box using the HWND.
It's not clear what actually is that dialog box. Is it a part of the webpage document, or opened within new IE popup window? Is it modal?
Please make a screenshot of the dialog box, so that both the webpage and the dialog box titles will be visible. You may scrub the sensitive characters on the screenshot (e. g. in paint), and then upload it.
Also try to examine opened IE windows using the below code:
Option Explicit
Sub Test()
Dim oWnd As Object
For Each oWnd In CreateObject("Shell.Application").Windows
On Error Resume Next
If TypeName(oWnd.Document) = "HTMLDocument" Then
Wait oWnd
Debug.Print "URL = " & oWnd.Document.Location
Debug.Print "HWND = " & oWnd.Hwnd
Debug.Print "Title = " & oWnd.Document.Title
Debug.Print "Error = " & Err.Number
Debug.Print
End If
Next
Debug.Print "Completed"
End Sub
Sub Wait(oIE As Object)
Do While oIE.Busy Or oIE.readyState <> 4
DoEvents
Loop
Do While oIE.Document.readyState <> "complete"
DoEvents
Loop
End Sub
Do the following steps: make actions the dialog box to appear, find HWND using the code you posted in the question, then run the code shown above and share the output.
Both of them, the screenshot and the output listing + FindWindow's HWND, should make things clearer.
Sorry not responding to you questions above, been searching other sites for help.
Using the code above, did not find the dialog box, the IE dialog box is opened when a link was click inside the IE parent window and it is modal. The problem is only findwindow can find the dialog box and findwindow only returns HWND(windows handle which is a Long Integer). I found some code getting the htmldocument of the dialog box using HWND as the reference. (below)
Private Type UUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Declare Function GetClassName Lib "user32" _
Alias "GetClassNameA" ( _
ByVal hWnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) As Long
Private Declare Function EnumChildWindows Lib "user32" ( _
ByVal hWndParent As Long, _
ByVal lpEnumFunc As Long, _
lParam As Long) As Long
Private Declare Function RegisterWindowMessage Lib "user32" _
Alias "RegisterWindowMessageA" ( _
ByVal lpString As String) As Long
Private Declare Function SendMessageTimeout Lib "user32" _
Alias "SendMessageTimeoutA" ( _
ByVal hWnd As Long, _
ByVal msg As Long, _
ByVal wParam As Long, _
lParam As Any, _
ByVal fuFlags As Long, _
ByVal uTimeout As Long, _
lpdwResult As Long) As Long
Private Const SMTO_ABORTIFHUNG = &H2
Private Declare Function ObjectFromLresult Lib "oleacc" ( _
ByVal lResult As Long, _
riid As UUID, _
ByVal wParam As Long, _
ppvObject As Any) As Long
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Public Function IEDOMFromhWnd(ByVal hWnd As Long) As IHTMLDocument
Dim IID_IHTMLDocument As UUID
Dim hWndChild As Long
Dim lRes As Long
Dim lMsg As Long
Dim hr As Long
If hWnd <> 0 Then
If Not IsIEServerWindow(hWnd) Then
' Find a child IE server window
EnumChildWindows hWnd, AddressOf EnumChildProc, hWnd
End If
If hWnd <> 0 Then
' Register the message
lMsg = RegisterWindowMessage("WM_HTML_GETOBJECT")
' Get the object pointer
Call SendMessageTimeout(hWnd, lMsg, 0, 0, _
SMTO_ABORTIFHUNG, 1000, lRes)
If lRes Then
' Initialize the interface ID
With IID_IHTMLDocument
.Data1 = &H626FC520
.Data2 = &HA41E
.Data3 = &H11CF
.Data4(0) = &HA7
.Data4(1) = &H31
.Data4(2) = &H0
.Data4(3) = &HA0
.Data4(4) = &HC9
.Data4(5) = &H8
.Data4(6) = &H26
.Data4(7) = &H37
End With
' Get the object from lRes
hr = ObjectFromLresult(lRes, IID_IHTMLDocument, 0, IEDOMFromhWnd)
End If
End If
End If
End Function
Public Function IsIEServerWindow(ByVal hWnd As Long) As Boolean
Dim lRes As Long
Dim sClassName As String
'Initialize the buffer
sClassName = String$(100, 0)
'Get the window class name
lRes = GetClassName(hWnd, sClassName, Len(sClassName))
sClassName = Left$(sClassName, lRes)
IsIEServerWindow = StrComp(sClassName, _
"Internet Explorer_Server", _
vbTextCompare) = 0
End Function
And use it this code to retrieve the htmldocument so I can search for the corresponding element of a text field that I need.
Sub HtmlDocFromHandle()
Dim myHandle As Long, iHtml2 As IHTMLDocument2
Dim ieobj As Object
myHandle = FindWindow(vbNullString, "TITLE OF THE WINDOW")
If myHandle <> 0 Then
Set ihtml2 = IEDOMFromhWnd(hForm)
Set ieobj = ihtml2.activeElement
Debug.Print ieobj.document
Else
MsgBox "Window not found"
End If
End Function

Unlock password protected VBE project, run code then lock again [duplicate]

How can i unprotect my VB project from a vb macro ?
i have found this code:
Sub UnprotectVBProject(ByRef WB As Workbook, ByVal Password As String)
Dim VBProj As Object
Set VBProj = WB.VBProject
Application.ScreenUpdating = False
'Ne peut procéder si le projet est non-protégé.
If VBProj.Protection <> 1 Then Exit Sub
Set Application.VBE.ActiveVBProject = VBProj
'Utilisation de "SendKeys" Pour envoyer le mot de passe.
SendKeys Password & "~"
SendKeys "~"
'MsgBox "Après Mot de passe"
Application.VBE.CommandBars(1).FindControl(ID:=2578, recursive:=True).Execute
Application.Wait (Now + TimeValue("0:00:1"))
End Sub
But this solution doesn't work for Excel 2007. It display the authentification's window and print password in my IDE.
Then, my goal is to unprotect my VBproject without displaying this window.
Thanks for any help.
EDIT:
Converted this to a BLOG post for VBA and VB.Net.
I have never been in favor of Sendkeys. They are reliable in some case but not always. I have a soft corner for API's though.
What you want can be achieved, however you have to ensure that workbook for which you want to un-protect the VBA has to be opened in a separate Excel Instance.
Here is an example
Let's say we have a workbook who's VBA project looks like this currently.
LOGIC:
Find the Handle of the "VBAProject Password" window using FindWindow
Once that is found, find the handle of the Edit Box in that window using FindWindowEx
Once the handle of the Edit Box is found, simply use SendMessage to write to it.
Find the handle of the Buttons in that window using FindWindowEx
Once the handle of the OK button is found, simply use SendMessage to click it.
RECOMMENDATION:
For API's THIS is the best link I can recommend.
If you wish to become good at API's like FindWindow, FindWindowEx and SendMessage then get a tool that gives you a graphical view of the system’s processes, threads, windows, and window messages. For Ex: uuSpy or Spy++.
Here is what Spy++ will show you for "VBAProject Password" window
TESTING:
Open a new Excel instance and paste the below code in a module.
CODE:
I have commented the code so you shouldn't have any problem understanding it.
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
Dim Ret As Long, ChildRet As Long, OpenRet As Long
Dim strBuff As String, ButCap As String
Dim MyPassword As String
Const WM_SETTEXT = &HC
Const BM_CLICK = &HF5
Sub UnlockVBA()
Dim xlAp As Object, oWb As Object
Set xlAp = CreateObject("Excel.Application")
xlAp.Visible = True
'~~> Open the workbook in a separate instance
Set oWb = xlAp.Workbooks.Open("C:\Sample.xlsm")
'~~> Launch the VBA Project Password window
'~~> I am assuming that it is protected. If not then
'~~> put a check here.
xlAp.VBE.CommandBars(1).FindControl(ID:=2578, recursive:=True).Execute
'~~> Your passwword to open then VBA Project
MyPassword = "Blah Blah"
'~~> Get the handle of the "VBAProject Password" Window
Ret = FindWindow(vbNullString, "VBAProject Password")
If Ret <> 0 Then
'MsgBox "VBAProject Password Window Found"
'~~> Get the handle of the TextBox Window where we need to type the password
ChildRet = FindWindowEx(Ret, ByVal 0&, "Edit", vbNullString)
If ChildRet <> 0 Then
'MsgBox "TextBox's Window Found"
'~~> This is where we send the password to the Text Window
SendMess MyPassword, ChildRet
DoEvents
'~~> Get the handle of the Button's "Window"
ChildRet = FindWindowEx(Ret, ByVal 0&, "Button", vbNullString)
'~~> Check if we found it or not
If ChildRet <> 0 Then
'MsgBox "Button's Window Found"
'~~> Get the caption of the child window
strBuff = String(GetWindowTextLength(ChildRet) + 1, Chr$(0))
GetWindowText ChildRet, strBuff, Len(strBuff)
ButCap = strBuff
'~~> Loop through all child windows
Do While ChildRet <> 0
'~~> Check if the caption has the word "OK"
If InStr(1, ButCap, "OK") Then
'~~> If this is the button we are looking for then exit
OpenRet = ChildRet
Exit Do
End If
'~~> Get the handle of the next child window
ChildRet = FindWindowEx(Ret, ChildRet, "Button", vbNullString)
'~~> Get the caption of the child window
strBuff = String(GetWindowTextLength(ChildRet) + 1, Chr$(0))
GetWindowText ChildRet, strBuff, Len(strBuff)
ButCap = strBuff
Loop
'~~> Check if we found it or not
If OpenRet <> 0 Then
'~~> Click the OK Button
SendMessage ChildRet, BM_CLICK, 0, vbNullString
Else
MsgBox "The Handle of OK Button was not found"
End If
Else
MsgBox "Button's Window Not Found"
End If
Else
MsgBox "The Edit Box was not found"
End If
Else
MsgBox "VBAProject Password Window was not Found"
End If
End Sub
Sub SendMess(Message As String, hwnd As Long)
Call SendMessage(hwnd, WM_SETTEXT, False, ByVal Message)
End Sub
I know you've locked this for new answers but I had a few issues with the above code, principally that I'm working in Office 64-bit (VBA7). However I also made it so the code would work in the current instance of Excel and added a bit more error checking and formatted it up to be pasted into a separate module with only the method UnlockProject exposed.
For full disclosure I really started with the code in this post although it's a variant on a theme.
The code also shows conditional compilation constants so that it ought to be compatible with both 32-bit and 64-bit flavours of Excel at the same time. I used this page to help me with figuring this out.
Anyways here's the code. Hope someone finds it useful:
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hwndParent As LongPtr, ByVal hwndChildAfter As LongPtr, ByVal lpszClass As String, ByVal lpszWindow As String) As LongPtr
Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GetDlgItem Lib "user32" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr ' nIDDlgItem = int?
Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal Msg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare PtrSafe Function SetFocusAPI Lib "user32" Alias "SetFocus" (ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function LockWindowUpdate Lib "user32" (ByVal hWndLock As LongPtr) As Long
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 uIDEvent As LongPtr) As Long
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
Private 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
Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long ' nIDDlgItem = int?
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function SetFocusAPI Lib "user32" Alias "SetFocus" (ByVal hWnd As Long) As Long
Private Declare Function LockWindowUpdate Lib "user32" (ByVal hWndLock As Long) As Long
Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal uIDEvent As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
Private Const WM_CLOSE As Long = &H10
Private Const WM_GETTEXT As Long = &HD
Private Const EM_REPLACESEL As Long = &HC2
Private Const EM_SETSEL As Long = &HB1
Private Const BM_CLICK As Long = &HF5&
Private Const TCM_SETCURFOCUS As Long = &H1330&
Private Const IDPassword As Long = &H155E&
Private Const IDOK As Long = &H1&
Private Const TimeoutSecond As Long = 2
Private g_ProjectName As String
Private g_Password As String
Private g_Result As Long
#If VBA7 Then
Private g_hwndVBE As LongPtr
Private g_hwndPassword As LongPtr
#Else
Private g_hwndVBE As Long
Private g_hwndPassword As Long
#End If
Sub Test_UnlockProject()
Select Case UnlockProject(ActiveWorkbook.VBProject, "Test")
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
Public Function UnlockProject(ByVal Project As Object, ByVal Password As String) As Long
#If VBA7 Then
Dim lRet As LongPtr
#Else
Dim lRet As Long
#End If
Dim timeout As Date
On Error GoTo ErrorHandler
UnlockProject = 1
' If project already unlocked then no need to do anything fancy
' Return status 2 to indicate already unlocked
If Project.Protection <> vbext_pp_locked Then
UnlockProject = 2
Exit Function
End If
' Set global varaibles for the project name, the password and the result of the callback
g_ProjectName = Project.Name
g_Password = Password
g_Result = 0
' Freeze windows updates so user doesn't see the magic happening :)
' This is dangerous if the program crashes as will 'lock' user out of Windows
' LockWindowUpdate GetDesktopWindow()
' Switch to the VBE
' and set the VBE window handle as a global variable
Application.VBE.MainWindow.Visible = True
g_hwndVBE = Application.VBE.MainWindow.hWnd
' Run 'UnlockTimerProc' as a callback
lRet = SetTimer(0, 0, 100, AddressOf UnlockTimerProc)
If lRet = 0 Then
Debug.Print "error setting timer"
GoTo ErrorHandler
End If
' Switch to the project we want to unlock
Set Application.VBE.ActiveVBProject = Project
If Not Application.VBE.ActiveVBProject Is Project Then GoTo ErrorHandler
' Launch the menu item Tools -> VBA Project Properties
' This will trigger the password dialog
' which will then get picked up by the callback
Application.VBE.CommandBars.FindControl(ID:=2578).Execute
' Loop until callback procedure 'UnlockTimerProc' has run
' determine run by watching the state of the global variable 'g_result'
' ... or backstop of 2 seconds max
timeout = Now() + TimeSerial(0, 0, TimeoutSecond)
Do While g_Result = 0 And Now() < timeout
DoEvents
Loop
If g_Result Then UnlockProject = 0
ErrorHandler:
' Switch back to the Excel application
AppActivate Application.Caption
' Unfreeze window updates
LockWindowUpdate 0
End Function
#If VBA7 Then
Private Function UnlockTimerProc(ByVal hWnd As LongPtr, ByVal uMsg As Long, ByVal idEvent As LongPtr, ByVal dwTime As Long) As Long
#Else
Private Function UnlockTimerProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long) As Long
#End If
#If VBA7 Then
Dim hWndPassword As LongPtr
Dim hWndOK As LongPtr
Dim hWndTmp As LongPtr
Dim lRet As LongPtr
#Else
Dim hWndPassword As Long
Dim hWndOK As Long
Dim hWndTmp As Long
Dim lRet As Long
#End If
Dim lRet2 As Long
Dim sCaption As String
Dim timeout As Date
Dim timeout2 As Date
Dim pwd As String
' Protect ourselves against failure :)
On Error GoTo ErrorHandler
' Kill timer used to initiate this callback
KillTimer 0, idEvent
' Determine the Title for the password dialog
Select Case Application.LanguageSettings.LanguageID(msoLanguageIDUI)
' For the japanese version
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)
Case Else
sCaption = " Password"
End Select
sCaption = g_ProjectName & sCaption
' Set a max timeout of 2 seconds to guard against endless loop failure
timeout = Now() + TimeSerial(0, 0, TimeoutSecond)
Do While Now() < timeout
hWndPassword = 0
hWndOK = 0
hWndTmp = 0
' Loop until find a window with the correct title that is a child of the
' VBE handle for the project to unlock we found in 'UnlockProject'
Do
hWndTmp = FindWindowEx(0, hWndTmp, vbNullString, sCaption)
If hWndTmp = 0 Then Exit Do
Loop Until GetParent(hWndTmp) = g_hwndVBE
' If we don't find it then could be that the calling routine hasn't yet triggered
' the appearance of the dialog box
' Skip to the end of the loop, wait 0.1 secs and try again
If hWndTmp = 0 Then GoTo Continue
' Found the dialog box, make sure it has focus
Debug.Print "found window"
lRet2 = SendMessage(hWndTmp, TCM_SETCURFOCUS, 1, ByVal 0&)
' Get the handle for the password input
hWndPassword = GetDlgItem(hWndTmp, IDPassword)
Debug.Print "hwndpassword: " & hWndPassword
' Get the handle for the OK button
hWndOK = GetDlgItem(hWndTmp, IDOK)
Debug.Print "hwndOK: " & hWndOK
' If either handle is zero then we have an issue
' Skip to the end of the loop, wait 0.1 secs and try again
If (hWndTmp And hWndOK) = 0 Then GoTo Continue
' Enter the password ionto the password box
lRet = SetFocusAPI(hWndPassword)
lRet2 = SendMessage(hWndPassword, EM_SETSEL, 0, ByVal -1&)
lRet2 = SendMessage(hWndPassword, EM_REPLACESEL, 0, ByVal g_Password)
' As a check, get the text back out of the pasword box and verify it's the same
pwd = String(260, Chr(0))
lRet2 = SendMessage(hWndPassword, WM_GETTEXT, Len(pwd), ByVal pwd)
pwd = Left(pwd, InStr(1, pwd, Chr(0), 0) - 1)
' If not the same then we have an issue
' Skip to the end of the loop, wait 0.1 secs and try again
If pwd <> g_Password Then GoTo Continue
' Now we need to close the Project Properties window we opened to trigger
' the password input in the first place
' Like the current routine, do it as a callback
lRet = SetTimer(0, 0, 100, AddressOf ClosePropertiesWindow)
' Click the OK button
lRet = SetFocusAPI(hWndOK)
lRet2 = SendMessage(hWndOK, BM_CLICK, 0, ByVal 0&)
' Set the gloabal variable to success to flag back up to the initiating routine
' that this worked
g_Result = 1
Exit Do
' If we get here then something didn't work above
' Wait 0.1 secs and try again
' Master loop is capped with a longstop of 2 secs to terminate endless loops
Continue:
DoEvents
Sleep 100
Loop
Exit Function
' If we get here something went wrong so close the password dialog box (if we have a handle)
' and unfreeze window updates (if we set that in the first place)
ErrorHandler:
Debug.Print Err.Number
If hWndPassword <> 0 Then SendMessage hWndPassword, WM_CLOSE, 0, ByVal 0&
LockWindowUpdate 0
End Function
#If VBA7 Then
Function ClosePropertiesWindow(ByVal hWnd As LongPtr, ByVal uMsg As Long, ByVal idEvent As LongPtr, ByVal dwTime As Long) As Long
#Else
Function ClosePropertiesWindow(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long) As Long
#End If
#If VBA7 Then
Dim hWndTmp As LongPtr
Dim hWndOK As LongPtr
Dim lRet As LongPtr
#Else
Dim hWndTmp As Long
Dim hWndOK As Long
Dim lRet As Long
#End If
Dim lRet2 As Long
Dim timeout As Date
Dim sCaption As String
' Protect ourselves against failure :)
On Error GoTo ErrorHandler
' Kill timer used to initiate this callback
KillTimer 0, idEvent
' Determine the Title for the project properties dialog
sCaption = g_ProjectName & " - Project Properties"
Debug.Print sCaption
' Set a max timeout of 2 seconds to guard against endless loop failure
timeout = Now() + TimeSerial(0, 0, TimeoutSecond)
Do While Now() < timeout
hWndTmp = 0
' Loop until find a window with the correct title that is a child of the
' VBE handle for the project to unlock we found in 'UnlockProject'
Do
hWndTmp = FindWindowEx(0, hWndTmp, vbNullString, sCaption)
If hWndTmp = 0 Then Exit Do
Loop Until GetParent(hWndTmp) = g_hwndVBE
' If we don't find it then could be that the calling routine hasn't yet triggered
' the appearance of the dialog box
' Skip to the end of the loop, wait 0.1 secs and try again
If hWndTmp = 0 Then GoTo Continue
' Found the dialog box, make sure it has focus
Debug.Print "found properties window"
lRet2 = SendMessage(hWndTmp, TCM_SETCURFOCUS, 1, ByVal 0&)
' Get the handle for the OK button
hWndOK = GetDlgItem(hWndTmp, IDOK)
Debug.Print "hwndOK: " & hWndOK
' If either handle is zero then we have an issue
' Skip to the end of the loop, wait 0.1 secs and try again
If (hWndTmp And hWndOK) = 0 Then GoTo Continue
' Click the OK button
lRet = SetFocusAPI(hWndOK)
lRet2 = SendMessage(hWndOK, BM_CLICK, 0, ByVal 0&)
' Set the gloabal variable to success to flag back up to the initiating routine
' that this worked
g_Result = 1
Exit Do
' If we get here then something didn't work above
' Wait 0.1 secs and try again
' Master loop is capped with a longstop of 2 secs to terminate endless loops
Continue:
DoEvents
Sleep 100
Loop
Exit Function
' If we get here something went wrong so unfreeze window updates (if we set that in the first place)
ErrorHandler:
Debug.Print Err.Number
LockWindowUpdate 0
End Function
#James Macadie's answer (above) is the best I found (I'm running 32-bit Excel 365/2019)
Note: I found that you must have Application.ScreenUpdating = True in order to call James' method via a different sub or function. Otherwise, you may get an Invalid procedure call or argument error (if running outside of debug-mode).
This solution appears superior to both of the following:
http://www.siddharthrout.com/index.php/2019/01/20/unprotect-vbproject-from-vb-code/. creates a separate Excel Application instance to run the unlock process which didn't work for my use case
https://www.mrexcel.com/board/threads/lock-unlock-vbaprojects-programmatically-without-sendkeys.1136415/. unstable and would fail if run sequentially for multiple workbooks, I think due to a lack of the timer/waiting loops implemented in James' solution - I didn't thoroughly debug the problem

How to programmatically change conditional compilation properties of a VBA project

I'm currently working on a VBA code generator/injector that adds VBA functionality to Excel workbooks by using the VBA Extensibility. This all works fine.
However, the original code that is injected uses conditional compilation, referring to some global conditional compilation arguments:
Is there any way I can programmatically modify/add the conditional compilation arguments of a VBA project?
I checked all properties of the VBProject but couldn't find anything.
Inspired by this approach, shown by SiddharthRout, I managed to find the following solution using SendMessage and FindWindow:
Option Explicit
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
Const WM_SETTEXT = &HC
Const BM_CLICK = &HF5
Public Sub subSetconditionalCompilationArguments()
Dim strArgument As String
Dim xlApp As Object
Dim wbTarget As Object
Dim lngHWnd As Long, lngHDialog As Long
Dim lngHEdit As Long, lngHButton As Long
strArgument = "PACKAGE_1 = 1"
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
Set wbTarget = xlApp.Workbooks.Open("C:\Temp\Sample.xlsb")
'Launch the VBA Project Properties Dialog
xlApp.VBE.CommandBars(1).FindControl(ID:=2578, recursive:=True).Execute
'Get the handle of the "VBAProject" Window
lngHWnd = FindWindow("#32770", vbNullString)
If lngHWnd = 0 Then
MsgBox "VBAProject Property Window not found!"
GoTo Finalize
End If
'Get the handle of the dialog
lngHDialog = FindWindowEx(lngHWnd, ByVal 0&, "#32770", vbNullString)
If lngHDialog = 0 Then
MsgBox "VBAProject Property Window could not be accessed!"
GoTo Finalize
End If
'Get the handle of the 5th edit box
lngHEdit = fctLngGetHandle("Edit", lngHDialog, 5)
If lngHEdit = 0 Then
MsgBox "Conditional Compilation Arguments box could not be accessed!"
GoTo Finalize
End If
'Enter new argument
SendMessage lngHEdit, WM_SETTEXT, False, ByVal strArgument
DoEvents
'Get the handle of the second button box (=OK button)
lngHButton = fctLngGetHandle("Button", lngHWnd)
If lngHButton = 0 Then
MsgBox "Could not find OK button!"
GoTo Finalize
End If
'Click the OK Button
SendMessage lngHButton, BM_CLICK, 0, vbNullString
Finalize:
xlApp.Visible = True
'Potentially save the file and close the app here
End Sub
Private Function fctLngGetHandle(strClass As String, lngHParent As Long, _
Optional Nth As Integer = 1) As Long
Dim lngHandle As Long
Dim i As Integer
lngHandle = FindWindowEx(lngHParent, ByVal 0&, strClass, vbNullString)
If Nth = 1 Then GoTo Finalize
For i = 2 To Nth
lngHandle = FindWindowEx(lngHParent, lngHandle, strClass, vbNullString)
Next
Finalize:
fctLngGetHandle = lngHandle
End Function
For Access 2000 I used:
Application.GetOption("Conditional Compilation Arguments")
for getting,
Application.SetOption("Conditional Compilation Arguments", "<arguments>")
for setting.
That's all.
The only way to affect anything in that dialog box is through SendMessage API functions, or maybe Application.SendKeys. You'd be better off declaring the constants in code, like this:
#Const PACKAGE_1 = 0
And then have your code modify the CodeModule of all your VBA components:
Dim comp As VBComponent
For Each comp In ThisWorkbook.VBProject.VBComponents
With comp.CodeModule
Dim i As Long
For i = 1 To .CountOfLines
If Left$(.Lines(i, 1), 18) = "#Const PACKAGE_1 =" Then
.ReplaceLine i, "#Const PACKAGE_1 = 1"
End If
Next i
End With
Next comp
This is how to get and set multiple arguments in Access after 2010:
To set them this is the code:
application.SetOption "Conditional Compilation Arguments","A=4:B=10"
To get them:
Application.GetOption("Conditional Compilation Arguments")
They are printed like this:
A = 4 : B = 10
That is how to test it:
Sub TestMe()
#If A = 1 Then
Debug.Print "a is 1"
#Else
Debug.Print "a is not 1"
#End If
End Sub

MsgBox not big enough for text

I have a string (msg) that is pretty much a very long list of items. I need to put this in a msgbox but it is not long enough to show the whole text. Is there an alternative to this?
Thank you!
The Message Box function is a built-in function of VBA and cannot exceed 1024 Characters. You are limited to creating your own UserForm or some other alternative... Such as opening and writing to an unsaved instance of notepad...
An ALL API solution to open Notepad and Write your message to it...
NOTE: If your running VBA 7.0 (Office 2010) then you'll have to add PtrSafe just after each Declare Statement...
At the top of your module paste the API Declarations and Global Variables
Option Explicit
Public Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessID As Long
dwThreadID As Long
End Type
Public Type STARTUPINFO
cb As Long
lpReserved As String
lpDesktop As String
lpTitle As String
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
'Miscellaneous API Constants
Public Const NORMAL_PRIORITY_CLASS As Long = &H20&
Public Const INFINITE As Long = -1&
'Window Message Constants
Public Const WM_GETTEXT = &HD
Public Const WM_GETTEXTLENGTH = &HE
Public Const WM_SETTEXT As Long = &HC
'GetWindow Constants
Public Const GW_CHILD = 5
Public Const GW_HWNDFIRST = 0
Public Const GW_HWNDLAST = 1
Public Const GW_HWNDNEXT = 2
Public Const GW_HWNDPREV = 3
Public Const GW_OWNER = 4
'Keybd_event Constants
Public Enum enumKBE
KBE_KeyDown = 0
KBE_KeyUp = 2
KBE_ExtKeyDown = 1
KBE_ExtKeyUp = 3
End Enum
'Keyboard Control Key Constants
Public Const VK_CONTROL = &H11
Public Const VK_HOME = &H24
'Keyboard Control Action Constants
Public Const WM_KEYDOWN = &H100
Public Const WM_KEYUP = &H101
'Create a new process
Public Declare Function CreateProcessA _
Lib "kernel32.dll" _
(ByVal lpApplicationName As String, _
ByVal lpCommandLine As String, _
ByVal lpProcessAttributes As Long, _
ByVal lpThreadAttributes As Long, _
ByVal bInheritHandles As Long, _
ByVal dwCreationFlags As Long, _
ByVal lpEnvironment As Long, _
ByVal lpCurrentDirectory As String, _
ByRef lpStartupInfo As STARTUPINFO, _
ByRef lpProcessInformation As PROCESS_INFORMATION) As Long
'Waits until the specified process has finished processing its initial input
'and is waiting for user input with no input pending, or until the time-out
'interval has elapsed.
Public Declare Function WaitForInputIdle _
Lib "user32.dll" (ByVal hProcess As Long, ByVal dwMilliseconds As Long) As Long
'Closes Handles Created and referenced from the CreateProcess API
Public Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
'Returns the Window Handle of the Window that is accepting User input.
Public Declare Function GetForegroundWindow Lib "user32.dll" () As Long
'Desktop Window handle
Public Declare Function GetDesktopWindow Lib "user32.dll" () As Long
'Retrieves Window handle
Public Declare Function GetWindow Lib "user32.dll" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
'Get the length of a Window's caption
Public Declare Function GetWindowTextLength Lib "user32.dll" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long
'Get the caption of a Window as a string
Public Declare Function GetWindowText Lib "user32.dll" Alias "GetWindowTextA" _
(ByVal hwnd As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
'Returns the Class or catagory name of an Window handle
Public Declare Function GetClassName Lib "user32.dll" Alias "GetClassNameA" _
(ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
'You can use the GetDlgItem function with any parent-child window pair, not just with
'dialog boxes. As long as the hDlg (hWnd) parameter specifies a parent window and the
'child window has a unique identifier (as specified by the hMenu parameter in the
'CreateWindow or CreateWindowEx function that created the child window),
'GetDlgItem returns a valid handle to the child window.
Public Declare Function GetDlgItem Lib "user32.dll" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
'Send messages to windows
Public Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
'Finds a window with the name, returns the handle.
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'Gets a controls window handle. The form window handle must be specified to get a decent control.
Public 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
'Translates (maps) a virtual-key code into a scan code or character value
Public Declare Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" (ByVal wCode As Long, ByVal wMapType As Long) As Long
'Synthesizes a keystroke. The system can use such a synthesized keystroke to generate a WM_KEYUP or WM_KEYDOWN message.
Public Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
'Sets Keyboard control and focus to the provided Window handle
Public Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
'Computer will wait for x number of milliseconds
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Write2Notepad function opens a new instance of Notepad and writes to it. If it succeeds, then it will return the Process ID of the Notepad instance.
Public Function Write2Notepad(strInText As String) As Long
Const nEditID = 15 'Identifier ID to Notepad's Edit Control
Dim PI As PROCESS_INFORMATION
Dim SI As STARTUPINFO
Dim RetVal As Long, hWndNote As Long, chWnd As Long, LngVal As Long, PID As Long
Dim strCaption As String, strClassName As String
'Initialize the STARTUPINFO structure
SI.cb = Len(SI)
'Start the application
RetVal = CreateProcessA(lpApplicationName:=vbNullString, _
lpCommandLine:="Notepad.exe", _
lpProcessAttributes:=0&, _
lpThreadAttributes:=0&, _
bInheritHandles:=1&, _
dwCreationFlags:=NORMAL_PRIORITY_CLASS, _
lpEnvironment:=0&, _
lpCurrentDirectory:=vbNullString, _
lpStartupInfo:=SI, _
lpProcessInformation:=PI)
'Wait for the application to finish loading
While WaitForInputIdle(PI.hProcess, INFINITE) <> 0
DoEvents
Wend
'Get the Process ID of the newly opened Notepad application
PID = PI.dwProcessID
'Close all Threads and handles for the Startup Process Information
' (This is not the Window Handle and is highly recommended)
Call CloseHandle(PI.hThread)
Call CloseHandle(PI.hProcess)
'Get the Active Application's Window Handle
'Note: when stepping through code in debugger this Will Return the VB Editor's Window Handle,
' Set a break point below GetForegroundWindow instead.
hWndNote = GetForegroundWindow()
If hWndNote = 0 Then '
'If the ForegroundWindow Handle isn't available Get the first Child Window to the Desktop
hWndNote = GetWindow(GetDesktopWindow, GW_CHILD)
End If
'Do While loop to verify the hWndNote Window Handle belongs to an Empty Untitled Notepad Window
Do
chWnd = 0
'Get Window Caption
LngVal = GetWindowTextLength(hWndNote) + 1
strCaption = String(LngVal, Chr$(0))
LngVal = GetWindowText(hWndNote, strCaption, LngVal)
strCaption = IIf(LngVal > 0, Left(strCaption, LngVal), "")
'Get the Window Class name
LngVal = GetWindowTextLength(hWndNote) + 1
strClassName = String(LngVal, Chr$(0))
LngVal = GetClassName(hWndNote, strClassName, LngVal)
strClassName = IIf(LngVal > 0, Left(strClassName, LngVal), "")
If strCaption Like "Untitled - Notepad" And strClassName = "Notepad" Then
'Get the window handle of the Edit Control which is a child window of Notepad
chWnd = GetDlgItem(hWndNote, nEditID)
'Get the character count of the notepad text to ensure it is empty (Should return 0)
If SendMessage(chWnd, WM_GETTEXTLENGTH, 0, 0) = 0 Then
Exit Do
End If
End If
'Get the next Window
hWndNote = GetWindow(hWndNote, GW_HWNDNEXT)
'Process Windows events.
DoEvents
Loop While hWndNote <> 0
If hWndNote = 0 Then
MsgBox "Cannot find Notepad's Window Handle."
Write2Notepad = 0
Exit Function
End If
If chWnd = 0 Then
'Returns child Window Hwnd - Similar to GetDlgItem
chWnd = FindWindowEx(hWndNote, ByVal 0&, vbNullString, vbNullString)
End If
DoEvents
'Sends the Text Value to Notepad
RetVal = SendMessage(chWnd, WM_SETTEXT, Len(strInText) + 1, ByVal strInText)
'To ensure the cursor position is at the top left the Keyboard Control forces the "Ctrl" Key is pressed
keybd_event VK_CONTROL, MapVirtualKey(VK_CONTROL, 0), KBE_KeyDown, 0
'Sends the "Home" input to Notepad (Simulates the CTRL + Home action to bring the cursor to the top of Notepad
SendMessage chWnd, WM_KEYDOWN, VK_HOME, 0
SendMessage chWnd, WM_KEYUP, VK_HOME, 0
'Simulates the Key up or unpressing of the "Ctrl" Key
keybd_event VK_CONTROL, MapVirtualKey(VK_CONTROL, 0), KBE_KeyUp, 0
'Ensures the Notepad window has the Cursor Focus
SetForegroundWindow (hWndNote)
'Returns the Process ID if the Value of the Settext SendMessage call equals a value of 1 (True) = successful
If CBool(RetVal) = True And PID > 0 Then
Write2Notepad = PID
Else
Write2Notepad = 0
End If
End Function
Routine to Test the Write2Notepad Function
Sub TestWriting2Notepad()
Dim strTestText As String
Dim lngProcID As Long
Dim oNotepad As Object
strTestText = "This" & vbCrLf & "is" & vbCrLf & "a Test" & vbCrLf & "to see if" & vbCrLf & "I can" & vbCrLf & _
vbCrLf & vbCrLf & "Write" & vbCrLf & vbCrLf & "2" & vbCrLf & vbCrLf & "Notepad!!!"
lngProcID = Write2Notepad(strTestText)
If lngProcID = 0 Then
Debug.Print "Something went wrong... It was probably your fault!"
Else
Debug.Print "You Successfully Wrote to Notepad... API Style!"
Do
DoEvents
Sleep 500
Set oNotepad = Nothing
On Error Resume Next
Set oNotepad = GetObject("winmgmts:root\cimv2:Win32_Process.Handle='" & lngProcID & "'")
On Error GoTo 0
Loop While Not oNotepad Is Nothing
' For Example only - Delete Below Line
MsgBox "You Closed Notepad"
End If
End Sub
The above code might look like a lot of trouble or more complicated but it will likely work much more reliably and efficiently then any other method.
The below function will copy your message to the clipboard using the MS clip tool, open notepad, and then paste the clipboard contents (your message) into Notepad... This way you don't have to save anything to a file and its easily closed... Or you can save it if you choose.
Option Explicit
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub Print2Notepad(strMessage)
Dim oShell As Object, oExec As Object, oIn As Object
Set oShell = CreateObject("WScript.Shell")
Set oExec = oShell.Exec("clip")
Set oIn = oExec.StdIn
oIn.WriteLine strMessage
oIn.Close
Do While oExec.Status = 0
Sleep 100
Loop
Set oIn = Nothing
Set oExec = Nothing
oShell.Run "Notepad", 1, False
Sleep 250
oShell.SendKeys "^v"
End Sub
Sub test()
Call Print2Notepad("This is a test message")
End Sub
You can also add an additional routine to "Sleep" while notepad is open to halt code if you need... See Below
Sub Print2Notepad_WaitTillClose(strMessage)
Dim oShell As Object, oExec As Object, oIn As Object
Dim iPID As Variant, oNotepad As Object
Set oShell = CreateObject("WScript.Shell")
Set oExec = oShell.Exec("clip")
Set oIn = oExec.StdIn
oIn.WriteLine strMessage
oIn.Close
Do While oExec.Status = 0
Sleep 100
Loop
Set oIn = Nothing
Set oExec = Nothing
iPID = oShell.Exec("Notepad").ProcessID
Sleep 500
oShell.SendKeys "^v"
Do
Sleep 500
Set oNotepad = Nothing
On Error Resume Next
Set oNotepad = GetObject("winmgmts:root\cimv2:Win32_Process.Handle='" & iPID & "'")
On Error GoTo 0
Loop While Not oNotepad Is Nothing
' For Example only - Delete Below Line
MsgBox "You Closed Notepad"
End Sub
EDIT:
I just realized that I wrote the above code to work for VBScript... Since this is Excel, if you want to look into other methods to copy contents to the Clipboard without using the WshShell.Exec method; you can also try:
Dim DataObj As New MSForms.DataObject
Dim S As String
S = "Hello World"
DataObj.SetText S
DataObj.PutInClipboard
To use the DataObject in your code, you must set a reference to the Microsoft Forms 2.0 Object Library. This can also be done by creating a UserForm and then Deleting it... The reference will remain (Excel 2007).
For additional Clipboard API's and code take a look at:
1) http://www.cpearson.com/excel/Clipboard.aspx
2) http://msdn.microsoft.com/en-us/library/office/ff192913.aspx
3) http://msdn.microsoft.com/en-us/library/windows/desktop/ms648709%28v=vs.85%29.aspx
There are other possible methods but I think these are the most stable and reliable. I will leave the code the way it is so that it will work for both VBA and VBScript
Use a TextBox. I know ActiveX TextBoxes can even be assigned scrollbars.

Unprotect VBProject from VB code

How can i unprotect my VB project from a vb macro ?
i have found this code:
Sub UnprotectVBProject(ByRef WB As Workbook, ByVal Password As String)
Dim VBProj As Object
Set VBProj = WB.VBProject
Application.ScreenUpdating = False
'Ne peut procéder si le projet est non-protégé.
If VBProj.Protection <> 1 Then Exit Sub
Set Application.VBE.ActiveVBProject = VBProj
'Utilisation de "SendKeys" Pour envoyer le mot de passe.
SendKeys Password & "~"
SendKeys "~"
'MsgBox "Après Mot de passe"
Application.VBE.CommandBars(1).FindControl(ID:=2578, recursive:=True).Execute
Application.Wait (Now + TimeValue("0:00:1"))
End Sub
But this solution doesn't work for Excel 2007. It display the authentification's window and print password in my IDE.
Then, my goal is to unprotect my VBproject without displaying this window.
Thanks for any help.
EDIT:
Converted this to a BLOG post for VBA and VB.Net.
I have never been in favor of Sendkeys. They are reliable in some case but not always. I have a soft corner for API's though.
What you want can be achieved, however you have to ensure that workbook for which you want to un-protect the VBA has to be opened in a separate Excel Instance.
Here is an example
Let's say we have a workbook who's VBA project looks like this currently.
LOGIC:
Find the Handle of the "VBAProject Password" window using FindWindow
Once that is found, find the handle of the Edit Box in that window using FindWindowEx
Once the handle of the Edit Box is found, simply use SendMessage to write to it.
Find the handle of the Buttons in that window using FindWindowEx
Once the handle of the OK button is found, simply use SendMessage to click it.
RECOMMENDATION:
For API's THIS is the best link I can recommend.
If you wish to become good at API's like FindWindow, FindWindowEx and SendMessage then get a tool that gives you a graphical view of the system’s processes, threads, windows, and window messages. For Ex: uuSpy or Spy++.
Here is what Spy++ will show you for "VBAProject Password" window
TESTING:
Open a new Excel instance and paste the below code in a module.
CODE:
I have commented the code so you shouldn't have any problem understanding it.
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
Dim Ret As Long, ChildRet As Long, OpenRet As Long
Dim strBuff As String, ButCap As String
Dim MyPassword As String
Const WM_SETTEXT = &HC
Const BM_CLICK = &HF5
Sub UnlockVBA()
Dim xlAp As Object, oWb As Object
Set xlAp = CreateObject("Excel.Application")
xlAp.Visible = True
'~~> Open the workbook in a separate instance
Set oWb = xlAp.Workbooks.Open("C:\Sample.xlsm")
'~~> Launch the VBA Project Password window
'~~> I am assuming that it is protected. If not then
'~~> put a check here.
xlAp.VBE.CommandBars(1).FindControl(ID:=2578, recursive:=True).Execute
'~~> Your passwword to open then VBA Project
MyPassword = "Blah Blah"
'~~> Get the handle of the "VBAProject Password" Window
Ret = FindWindow(vbNullString, "VBAProject Password")
If Ret <> 0 Then
'MsgBox "VBAProject Password Window Found"
'~~> Get the handle of the TextBox Window where we need to type the password
ChildRet = FindWindowEx(Ret, ByVal 0&, "Edit", vbNullString)
If ChildRet <> 0 Then
'MsgBox "TextBox's Window Found"
'~~> This is where we send the password to the Text Window
SendMess MyPassword, ChildRet
DoEvents
'~~> Get the handle of the Button's "Window"
ChildRet = FindWindowEx(Ret, ByVal 0&, "Button", vbNullString)
'~~> Check if we found it or not
If ChildRet <> 0 Then
'MsgBox "Button's Window Found"
'~~> Get the caption of the child window
strBuff = String(GetWindowTextLength(ChildRet) + 1, Chr$(0))
GetWindowText ChildRet, strBuff, Len(strBuff)
ButCap = strBuff
'~~> Loop through all child windows
Do While ChildRet <> 0
'~~> Check if the caption has the word "OK"
If InStr(1, ButCap, "OK") Then
'~~> If this is the button we are looking for then exit
OpenRet = ChildRet
Exit Do
End If
'~~> Get the handle of the next child window
ChildRet = FindWindowEx(Ret, ChildRet, "Button", vbNullString)
'~~> Get the caption of the child window
strBuff = String(GetWindowTextLength(ChildRet) + 1, Chr$(0))
GetWindowText ChildRet, strBuff, Len(strBuff)
ButCap = strBuff
Loop
'~~> Check if we found it or not
If OpenRet <> 0 Then
'~~> Click the OK Button
SendMessage ChildRet, BM_CLICK, 0, vbNullString
Else
MsgBox "The Handle of OK Button was not found"
End If
Else
MsgBox "Button's Window Not Found"
End If
Else
MsgBox "The Edit Box was not found"
End If
Else
MsgBox "VBAProject Password Window was not Found"
End If
End Sub
Sub SendMess(Message As String, hwnd As Long)
Call SendMessage(hwnd, WM_SETTEXT, False, ByVal Message)
End Sub
I know you've locked this for new answers but I had a few issues with the above code, principally that I'm working in Office 64-bit (VBA7). However I also made it so the code would work in the current instance of Excel and added a bit more error checking and formatted it up to be pasted into a separate module with only the method UnlockProject exposed.
For full disclosure I really started with the code in this post although it's a variant on a theme.
The code also shows conditional compilation constants so that it ought to be compatible with both 32-bit and 64-bit flavours of Excel at the same time. I used this page to help me with figuring this out.
Anyways here's the code. Hope someone finds it useful:
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hwndParent As LongPtr, ByVal hwndChildAfter As LongPtr, ByVal lpszClass As String, ByVal lpszWindow As String) As LongPtr
Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GetDlgItem Lib "user32" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr ' nIDDlgItem = int?
Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal Msg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare PtrSafe Function SetFocusAPI Lib "user32" Alias "SetFocus" (ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function LockWindowUpdate Lib "user32" (ByVal hWndLock As LongPtr) As Long
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 uIDEvent As LongPtr) As Long
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
Private 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
Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long ' nIDDlgItem = int?
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function SetFocusAPI Lib "user32" Alias "SetFocus" (ByVal hWnd As Long) As Long
Private Declare Function LockWindowUpdate Lib "user32" (ByVal hWndLock As Long) As Long
Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal uIDEvent As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
Private Const WM_CLOSE As Long = &H10
Private Const WM_GETTEXT As Long = &HD
Private Const EM_REPLACESEL As Long = &HC2
Private Const EM_SETSEL As Long = &HB1
Private Const BM_CLICK As Long = &HF5&
Private Const TCM_SETCURFOCUS As Long = &H1330&
Private Const IDPassword As Long = &H155E&
Private Const IDOK As Long = &H1&
Private Const TimeoutSecond As Long = 2
Private g_ProjectName As String
Private g_Password As String
Private g_Result As Long
#If VBA7 Then
Private g_hwndVBE As LongPtr
Private g_hwndPassword As LongPtr
#Else
Private g_hwndVBE As Long
Private g_hwndPassword As Long
#End If
Sub Test_UnlockProject()
Select Case UnlockProject(ActiveWorkbook.VBProject, "Test")
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
Public Function UnlockProject(ByVal Project As Object, ByVal Password As String) As Long
#If VBA7 Then
Dim lRet As LongPtr
#Else
Dim lRet As Long
#End If
Dim timeout As Date
On Error GoTo ErrorHandler
UnlockProject = 1
' If project already unlocked then no need to do anything fancy
' Return status 2 to indicate already unlocked
If Project.Protection <> vbext_pp_locked Then
UnlockProject = 2
Exit Function
End If
' Set global varaibles for the project name, the password and the result of the callback
g_ProjectName = Project.Name
g_Password = Password
g_Result = 0
' Freeze windows updates so user doesn't see the magic happening :)
' This is dangerous if the program crashes as will 'lock' user out of Windows
' LockWindowUpdate GetDesktopWindow()
' Switch to the VBE
' and set the VBE window handle as a global variable
Application.VBE.MainWindow.Visible = True
g_hwndVBE = Application.VBE.MainWindow.hWnd
' Run 'UnlockTimerProc' as a callback
lRet = SetTimer(0, 0, 100, AddressOf UnlockTimerProc)
If lRet = 0 Then
Debug.Print "error setting timer"
GoTo ErrorHandler
End If
' Switch to the project we want to unlock
Set Application.VBE.ActiveVBProject = Project
If Not Application.VBE.ActiveVBProject Is Project Then GoTo ErrorHandler
' Launch the menu item Tools -> VBA Project Properties
' This will trigger the password dialog
' which will then get picked up by the callback
Application.VBE.CommandBars.FindControl(ID:=2578).Execute
' Loop until callback procedure 'UnlockTimerProc' has run
' determine run by watching the state of the global variable 'g_result'
' ... or backstop of 2 seconds max
timeout = Now() + TimeSerial(0, 0, TimeoutSecond)
Do While g_Result = 0 And Now() < timeout
DoEvents
Loop
If g_Result Then UnlockProject = 0
ErrorHandler:
' Switch back to the Excel application
AppActivate Application.Caption
' Unfreeze window updates
LockWindowUpdate 0
End Function
#If VBA7 Then
Private Function UnlockTimerProc(ByVal hWnd As LongPtr, ByVal uMsg As Long, ByVal idEvent As LongPtr, ByVal dwTime As Long) As Long
#Else
Private Function UnlockTimerProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long) As Long
#End If
#If VBA7 Then
Dim hWndPassword As LongPtr
Dim hWndOK As LongPtr
Dim hWndTmp As LongPtr
Dim lRet As LongPtr
#Else
Dim hWndPassword As Long
Dim hWndOK As Long
Dim hWndTmp As Long
Dim lRet As Long
#End If
Dim lRet2 As Long
Dim sCaption As String
Dim timeout As Date
Dim timeout2 As Date
Dim pwd As String
' Protect ourselves against failure :)
On Error GoTo ErrorHandler
' Kill timer used to initiate this callback
KillTimer 0, idEvent
' Determine the Title for the password dialog
Select Case Application.LanguageSettings.LanguageID(msoLanguageIDUI)
' For the japanese version
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)
Case Else
sCaption = " Password"
End Select
sCaption = g_ProjectName & sCaption
' Set a max timeout of 2 seconds to guard against endless loop failure
timeout = Now() + TimeSerial(0, 0, TimeoutSecond)
Do While Now() < timeout
hWndPassword = 0
hWndOK = 0
hWndTmp = 0
' Loop until find a window with the correct title that is a child of the
' VBE handle for the project to unlock we found in 'UnlockProject'
Do
hWndTmp = FindWindowEx(0, hWndTmp, vbNullString, sCaption)
If hWndTmp = 0 Then Exit Do
Loop Until GetParent(hWndTmp) = g_hwndVBE
' If we don't find it then could be that the calling routine hasn't yet triggered
' the appearance of the dialog box
' Skip to the end of the loop, wait 0.1 secs and try again
If hWndTmp = 0 Then GoTo Continue
' Found the dialog box, make sure it has focus
Debug.Print "found window"
lRet2 = SendMessage(hWndTmp, TCM_SETCURFOCUS, 1, ByVal 0&)
' Get the handle for the password input
hWndPassword = GetDlgItem(hWndTmp, IDPassword)
Debug.Print "hwndpassword: " & hWndPassword
' Get the handle for the OK button
hWndOK = GetDlgItem(hWndTmp, IDOK)
Debug.Print "hwndOK: " & hWndOK
' If either handle is zero then we have an issue
' Skip to the end of the loop, wait 0.1 secs and try again
If (hWndTmp And hWndOK) = 0 Then GoTo Continue
' Enter the password ionto the password box
lRet = SetFocusAPI(hWndPassword)
lRet2 = SendMessage(hWndPassword, EM_SETSEL, 0, ByVal -1&)
lRet2 = SendMessage(hWndPassword, EM_REPLACESEL, 0, ByVal g_Password)
' As a check, get the text back out of the pasword box and verify it's the same
pwd = String(260, Chr(0))
lRet2 = SendMessage(hWndPassword, WM_GETTEXT, Len(pwd), ByVal pwd)
pwd = Left(pwd, InStr(1, pwd, Chr(0), 0) - 1)
' If not the same then we have an issue
' Skip to the end of the loop, wait 0.1 secs and try again
If pwd <> g_Password Then GoTo Continue
' Now we need to close the Project Properties window we opened to trigger
' the password input in the first place
' Like the current routine, do it as a callback
lRet = SetTimer(0, 0, 100, AddressOf ClosePropertiesWindow)
' Click the OK button
lRet = SetFocusAPI(hWndOK)
lRet2 = SendMessage(hWndOK, BM_CLICK, 0, ByVal 0&)
' Set the gloabal variable to success to flag back up to the initiating routine
' that this worked
g_Result = 1
Exit Do
' If we get here then something didn't work above
' Wait 0.1 secs and try again
' Master loop is capped with a longstop of 2 secs to terminate endless loops
Continue:
DoEvents
Sleep 100
Loop
Exit Function
' If we get here something went wrong so close the password dialog box (if we have a handle)
' and unfreeze window updates (if we set that in the first place)
ErrorHandler:
Debug.Print Err.Number
If hWndPassword <> 0 Then SendMessage hWndPassword, WM_CLOSE, 0, ByVal 0&
LockWindowUpdate 0
End Function
#If VBA7 Then
Function ClosePropertiesWindow(ByVal hWnd As LongPtr, ByVal uMsg As Long, ByVal idEvent As LongPtr, ByVal dwTime As Long) As Long
#Else
Function ClosePropertiesWindow(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long) As Long
#End If
#If VBA7 Then
Dim hWndTmp As LongPtr
Dim hWndOK As LongPtr
Dim lRet As LongPtr
#Else
Dim hWndTmp As Long
Dim hWndOK As Long
Dim lRet As Long
#End If
Dim lRet2 As Long
Dim timeout As Date
Dim sCaption As String
' Protect ourselves against failure :)
On Error GoTo ErrorHandler
' Kill timer used to initiate this callback
KillTimer 0, idEvent
' Determine the Title for the project properties dialog
sCaption = g_ProjectName & " - Project Properties"
Debug.Print sCaption
' Set a max timeout of 2 seconds to guard against endless loop failure
timeout = Now() + TimeSerial(0, 0, TimeoutSecond)
Do While Now() < timeout
hWndTmp = 0
' Loop until find a window with the correct title that is a child of the
' VBE handle for the project to unlock we found in 'UnlockProject'
Do
hWndTmp = FindWindowEx(0, hWndTmp, vbNullString, sCaption)
If hWndTmp = 0 Then Exit Do
Loop Until GetParent(hWndTmp) = g_hwndVBE
' If we don't find it then could be that the calling routine hasn't yet triggered
' the appearance of the dialog box
' Skip to the end of the loop, wait 0.1 secs and try again
If hWndTmp = 0 Then GoTo Continue
' Found the dialog box, make sure it has focus
Debug.Print "found properties window"
lRet2 = SendMessage(hWndTmp, TCM_SETCURFOCUS, 1, ByVal 0&)
' Get the handle for the OK button
hWndOK = GetDlgItem(hWndTmp, IDOK)
Debug.Print "hwndOK: " & hWndOK
' If either handle is zero then we have an issue
' Skip to the end of the loop, wait 0.1 secs and try again
If (hWndTmp And hWndOK) = 0 Then GoTo Continue
' Click the OK button
lRet = SetFocusAPI(hWndOK)
lRet2 = SendMessage(hWndOK, BM_CLICK, 0, ByVal 0&)
' Set the gloabal variable to success to flag back up to the initiating routine
' that this worked
g_Result = 1
Exit Do
' If we get here then something didn't work above
' Wait 0.1 secs and try again
' Master loop is capped with a longstop of 2 secs to terminate endless loops
Continue:
DoEvents
Sleep 100
Loop
Exit Function
' If we get here something went wrong so unfreeze window updates (if we set that in the first place)
ErrorHandler:
Debug.Print Err.Number
LockWindowUpdate 0
End Function
#James Macadie's answer (above) is the best I found (I'm running 32-bit Excel 365/2019)
Note: I found that you must have Application.ScreenUpdating = True in order to call James' method via a different sub or function. Otherwise, you may get an Invalid procedure call or argument error (if running outside of debug-mode).
This solution appears superior to both of the following:
http://www.siddharthrout.com/index.php/2019/01/20/unprotect-vbproject-from-vb-code/. creates a separate Excel Application instance to run the unlock process which didn't work for my use case
https://www.mrexcel.com/board/threads/lock-unlock-vbaprojects-programmatically-without-sendkeys.1136415/. unstable and would fail if run sequentially for multiple workbooks, I think due to a lack of the timer/waiting loops implemented in James' solution - I didn't thoroughly debug the problem