Turn off screenupdating for Powerpoint - excel

I am writing a script that loops through a folder and creates graphs from some criteria, and then exports these to powerpoint. At the moment, creating 130 graphs takes 290 seconds, of which 286 are used by powerpoint. I suspect a major reason for this is not being able to turn off screenupdating for powerpoint. I have tried using code from here http://skp.mvps.org/ppt00033.htm to solve this. However, I'm not noticing any effect. While I can alt-tab and keep powerpoint in the background, when switching to Powerpoint all the changes are being shown and you can basically see how it slows down the program. Anybody knows how I am to use this code? Should it be in a class module, should I do anything else or what am I doing wrong? Below is the code-snippet I have borrowed and an example of how I try to call it:
Option Explicit
' UserDefined Error codes
Const ERR_NO_WINDOW_HANDLE As Long = 1000
Const ERR_WINDOW_LOCK_FAIL As Long = 1001
Const ERR_VERSION_NOT_SUPPORTED As Long = 1002
' API declarations for FindWindow() & LockWindowUpdate()
' Use FindWindow API to locate the PowerPoint handle.
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As Long) As Long
' Use LockWindowUpdate to prevent/enable window refresh
Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
' Use UpdateWindow to force a refresh of the PowerPoint window
Declare Function UpdateWindow Lib "user32" (ByVal hwnd As Long) As Long
Property Let ScreenUpdating(State As Boolean)
Static hwnd As Long
Dim VersionNo As String
' Get Version Number
If State = False Then
VersionNo = Left(Application.Version, InStr(1, Application.Version, ".") - 1)
'Get handle to the main application window using ClassName
Select Case VersionNo
Case "8"
' For PPT97:
hwnd = FindWindow("PP97FrameClass", 0&)
Case "9"
' For PPT2K:
hwnd = FindWindow("PP9FrameClass", 0&)
Case "10"
' For XP:
hwnd = FindWindow("PP10FrameClass", 0&)
Case "11"
' For 2003:
hwnd = FindWindow("PP11FrameClass", 0&)
Case "12"
' For 2007:
hwnd = FindWindow("PP12FrameClass", 0&)
Case "14"
' For 2010:
hwnd = FindWindow("PPTFrameClass", 0&)
Case Else
Err.Raise Number:=vbObjectError + ERR_VERSION_NOT_SUPPORTED, _
Description:="Newer version."
Exit Property
End Select
If hwnd = 0 Then
Err.Raise Number:=vbObjectError + ERR_NO_WINDOW_HANDLE, _
Description:="Unable to get the PowerPoint Window handle"
Exit Property
End If
If LockWindowUpdate(hwnd) = 0 Then
Err.Raise Number:=vbObjectError + ERR_WINDOW_LOCK_FAIL, _
Description:="Unable to set a PowerPoint window lock"
Exit Property
Else
LockWindowUpdate (hwnd)
End If
Else
'Unlock the Window to refresh
LockWindowUpdate (0&)
UpdateWindow (hwnd)
hwnd = 0
End If
End Property
Sub TestSub()
' Lock screen redraw
If ScreenUpdatingOff = True Then ScreenUpdating = False
' --- Loop through charts in Excel and export them to Powerpoint
' Redraw screen again
ScreenUpdating = True
End Sub
Many thanks in advance. Very strange that this functionality is not readily available, now I need your help!

Assuming you put your code in a class module called Class1, you create an instance in your main code like this...
Dim myClass1 as Class1
Set myClass1 = New Class1
Class1.ScreenUpdating = False
EDIT: Just use the code as it was originally written: no need to add anything.
The bad news is that it doesn't make any difference to speed in my testing in PPT 2013. You can verify that its working though by leaving it set to False.
Class module cScreenUpdating...
Option Explicit
' UserDefined Error codes
Const ERR_NO_WINDOW_HANDLE As Long = 1000
Const ERR_WINDOW_LOCK_FAIL As Long = 1001
Const ERR_VERSION_NOT_SUPPORTED As Long = 1002
' API declarations for FindWindow() & LockWindowUpdate()
' Use FindWindow API to locate the PowerPoint handle.
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As Long) As Long
' Use LockWindowUpdate to prevent/enable window refresh
Private Declare Function LockWindowUpdate Lib "user32" _
(ByVal hwndLock As Long) As Long
' Use UpdateWindow to force a refresh of the PowerPoint window
Private Declare Function UpdateWindow Lib "user32" (ByVal hWnd As Long) As Long
Property Let ScreenUpdating(State As Boolean)
Static hWnd As Long
Dim VersionNo As String
' Get Version Number
If State = False Then
VersionNo = Left(Application.Version, _
InStr(1, Application.Version, ".") - 1)
'Get handle to the main application window using ClassName
Select Case VersionNo
Case "8"
' For PPT97:
hWnd = FindWindow("PP97FrameClass", 0&)
Case "9"
' For PPT2K:
hWnd = FindWindow("PP9FrameClass", 0&)
Case "10"
' For XP:
hWnd = FindWindow("PP10FrameClass", 0&)
Case "11"
' For 2003:
hWnd = FindWindow("PP11FrameClass", 0&)
Case "12"
' For 2007:
hWnd = FindWindow("PP12FrameClass", 0&)
Case "14", "15"
' For 2010:
hWnd = FindWindow("PPTFrameClass", 0&)
Case Else
Err.Raise Number:=vbObjectError + ERR_VERSION_NOT_SUPPORTED, _
Description:="Newer version."
Exit Property
End Select
If hWnd = 0 Then
' window was not found...
Err.Raise Number:=vbObjectError + ERR_NO_WINDOW_HANDLE, _
Description:="Unable to get the PowerPoint Window handle"
Exit Property
End If
'Attempt to lock the window
If LockWindowUpdate(hWnd) = 0 Then
' attempt failed...
Err.Raise Number:=vbObjectError + ERR_WINDOW_LOCK_FAIL, _
Description:="Unable to set a PowerPoint window lock"
Exit Property
End If
Else 'State = True
'Unlock the Window to refresh
LockWindowUpdate (0&)
UpdateWindow (hWnd)
hWnd = 0
End If
End Property
Example usage...
Set appObject = New cScreenUpdating
appObject.ScreenUpdating = False
' code here
appObject.ScreenUpdating = True

I just minimized the PowerPoint Window after I opened the file and Maximized it when the building was done.
ppApp.ActiveWindow.WindowState = ppWindowMinimized
VBA
ppApp.ActiveWindow.WindowState = ppWindowMaximized

One workaround I found was to minimize the PPT window, and then use EnableWindow to prevent user input getting to it. Tested with Office 365, from VB.NET
<DllImport("user32.dll")>
Private Shared Function EnableWindow(ByVal hWnd As IntPtr, ByVal bEnable As Boolean) As Boolean
End Function
Private _pptApp As PowerPoint.Application
Public Property ScreenUpdating As Boolean
Get
Return _pptApp.WindowState=PpWindowState.ppWindowNormal
End Get
Set(value As Boolean)
If value Then
EnableWindow(_pptApp.HWND, True)
_pptApp.WindowState = PpWindowState.ppWindowNormal
Else
'need to make sure it is enabled otherwise changing the state throws an exception
EnableWindow(_pptApp.HWND, True)
_pptApp.WindowState = PpWindowState.ppWindowMinimized
EnableWindow(_pptApp.HWND, False)
End If
End Set
End Property

Related

Best way to activate an unsaved workbook

I have various code to create reports. The reports are added to a new workbook that does not get saved, the theory being that the user can choose whether to save the workbook or just close it after looking at the results. My code below will activate the unsaved workbook.
Sub ActivateWorkbook(wbResults As Workbook)
Dim objWindow As Window
With Application
.VBE.MainWindow.WindowState = vbext_ws_Minimize
For Each objWindow In .Windows
With objWindow
If .Caption <> wbResults.Name Then .WindowState = xlMinimized
End With
Next objWindow
With .Windows(wbResults.Name)
.WindowState = xlMaximized
.Activate
End With
End With
End Sub
This works okay with a single monitor. But if there is already more than one workbook and they are different monitors, it minimises windows in both (all) monitors and looks less than ideal. I am thinking that if I am able to identify which monitor has the active workbook, I could only minimize windows for that monitor (including the VBE, if required).
In reply to chris neilsen, I will include some basic code to illustrate what I'm calling the above procedure with. Please keep in mind that each procedure is varied in purpose and most of the code in each doesn't really pertain to this particular problem.
Sub ExampleCode()
Dim wbXXX As Workbook
Set wbXXX = Workbooks.Add
With wbXXX
'Main code here
End With
Call ActivateWorkbook(wbXXX)
Set wbXXX = Nothing
End Sub
Thanks to anybody trying to help. It is appreciated.
Okay, this seems to be working for me. It's not pretty. Note that "Microsoft Visual Basic for Applications Extensibility 5.3" is required to minimise the VBE, which is where the code is being run from, not the main Excel application. In any case, Activate has not worked for me reliably in the past. If it works for you, no need for any of this I guess. If anybody is game to test it, please let me know how you go. I have only tested on a dual monitor setup so far.
Objective: Show the new workbook in the same monitor as the active workbook when Activate does not work.
Private Declare PtrSafe Function FindWindow _
Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) _
As LongPtr
Private Declare PtrSafe Function MonitorFromWindow _
Lib "user32" _
(ByVal hwnd As LongPtr, _
ByVal dwFlags As Long) _
As LongPtr
Private Declare PtrSafe Function EnumDisplayMonitors _
Lib "user32.dll" _
(ByVal hdc As Long, _
ByRef lprcClip As Any, _
ByVal lpfnEnum As Long, _
ByVal dwData As Long) _
As Long
Private Declare PtrSafe Function GetSystemMetrics _
Lib "user32" _
(ByVal Index As Long) _
As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Const MONITOR_DEFAULTTONEAREST = &H2
Private Const SM_CMONITORS As Long = 80
Private hWndMonitor As LongPtr
Private hActiveWorkbook As LongPtr
Private hVBE As LongPtr
Private lngMode As Long
Function MonitorCount() As Long
MonitorCount = GetSystemMetrics(SM_CMONITORS)
End Function
Function MonitorsAreTheSame() As Boolean
MonitorsAreTheSame = True
'Count of monitors
If MonitorCount > 1 Then
'Check the ActiveWorkbook
lngMode = 0
hWndMonitor = FindWindow("XLMAIN", Application.Caption)
EnumDisplayMonitors ByVal 0&, ByVal 0&, AddressOf MonitorEnumProc, ByVal 0&
'Check the VBE
lngMode = 1
hWndMonitor = FindWindow("wndclass_desked_gsk", Application.VBE.MainWindow.Caption)
EnumDisplayMonitors ByVal 0&, ByVal 0&, AddressOf MonitorEnumProc, ByVal 0&
MonitorsAreTheSame = CBool(hActiveWorkbook = hVBE)
End If
End Function
Private Function MonitorEnumProc(ByVal hMonitor As Long, ByVal hdcMonitor As Long, lprcMonitor As RECT, ByVal dwData As Long) As Long
If MonitorFromWindow(hWndMonitor, MONITOR_DEFAULTTONEAREST) = hMonitor Then
Select Case lngMode
Case 0
hActiveWorkbook = CStr(hMonitor)
Case 1
hVBE = CStr(hMonitor)
End Select
End If
MonitorEnumProc = MonitorCount
End Function
Sub Test()
Dim wbkTest As Workbook
Set wbkTest = Workbooks.Add
Call ActivateWorkbook(wbkTest)
Set wbkTest = Nothing
End Sub
Sub ActivateWorkbook(wbkResults As Workbook)
Dim objWindow As Window
With Application
If MonitorsAreTheSame = True Then
.VBE.MainWindow.WindowState = vbext_ws_Minimize
For Each objWindow In .Windows
With objWindow
If .Left = Application.VBE.MainWindow.Left Then
If .Caption <> wbkResults.Name Then .WindowState = xlMinimized
End If
End With
Next objWindow
Else
For Each objWindow In .Windows
With objWindow
If .Left <> Application.VBE.MainWindow.Left Then
If .Caption <> wbkResults.Name Then .WindowState = xlMinimized
End If
End With
Next objWindow
End If
.Windows(wbkResults.Name).WindowState = xlMaximized
AppActivate (.Caption)
End With
End Sub
this should be sufficient - no second sub for activation needed. These should show the new workbook in the foreground, no other windows changed.
Sub ExampleCode()
Dim wbXXX As Workbook
Set wbXXX = Workbooks.Add
With wbXXX
'Main code here
End With
wbXXX.Activate
Set wbXXX = Nothing
End Sub

How to trap Left Click in Excel?

I want to know if the selection of a cell is caused by a cursor move or by a mouse action.
There are a lot of articles explaining how to trap mouse click in Excel, even some explaining that left click can be trapped.
This code is found many times on the web:
' The declaration tells VBA where to find and how to call the API
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
' The function returns whether a key (or mouse button) is pressed or not
Public Function KeyPressed(ByVal Key As Long) As Boolean
KeyPressed = CBool((GetAsyncKeyState(Key) And &H8000) = &H8000)
End Function
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If (KeyPressed(&H1) = True) Then
MsgBox "Left click"
End If
If (KeyPressed(&H2) = True) Then
MsgBox "Right click"
End If
End Sub
This code traps the right click event, but not the left! Probably because it is placed in the Worksheet_SelectionChange event which is only called when a SelectionChanged has occurred and therefore when the left button has already been released!
How to detect a left click on a cell of a sheet to know if the selection of a cell is caused by a keyboard input (arrows or enter) or by a mouse left/right click action?
I found this great article and adapt it for mouse button check : https://www.mrexcel.com/board/threads/keypress-event-for-worksheet-cells.181654/
Add this module:
Option Explicit
Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _
(ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Declare Function CallNextHookEx Lib "user32" _
(ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Declare Function GetActiveWindow Lib "user32" () As Long
Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Const HC_ACTION = 0
Const WH_MOUSE_LL = 14 ' Type of windows message to be hooked
Const WM_RBUTTONDOWN = &H204 ' Mouse message for right button down
Const WM_LBUTTONDOWN = &H201 ' Mouse message for left button down
Type KBDLLHOOKSTRUCT
vkCode As Long
scanCode As Long
flags As Long
time As Long
dwExtraInfo As Long
End Type
Dim hkLowLevelID As Long ' Hook id of the LowLevelMouseProc function
Dim LeftMouseDown As Boolean ' Flag to trap left mouse down events
Dim RightMouseDown As Boolean ' Flag to trap left mouse down events
Dim EllapsedTimer As Date
Function LowLevelMouseProc _
(ByVal nCode As Long, ByVal wParam As Long, lParam As KBDLLHOOKSTRUCT) As Long
On Error GoTo ResumeHere
' CAUTION !!!
' We can't do any action which envolves UI interaction because Excel is already beeing to update UI
' Hook mouse events only if XL is the active window
If GetActiveWindow = FindWindow("XLMAIN", Application.Caption) Then
If (nCode = HC_ACTION) Then
' Check if the left button is pressed
If (wParam = WM_LBUTTONDOWN) Then
LeftMouseDown = True
EllapsedTimer = Now() + TimeValue("00:00:01")
Application.OnTime EllapsedTimer, "ResetFlags"
ElseIf (wParam = WM_RBUTTONDOWN) Then
RightMouseDown = True
EllapsedTimer = Now() + TimeValue("00:00:01")
Application.OnTime EllapsedTimer, "ResetFlags"
End If
End If
End If
ResumeHere:
' Pass function to next hook if there is one
LowLevelMouseProc = CallNextHookEx(0, nCode, wParam, ByVal lParam)
End Function
Function isLeftMouseDown()
isLeftMouseDown = LeftMouseDown
End Function
Function isRightMouseDown()
isRightMouseDown = RightMouseDown
End Function
' Reset the flags if the click has been thrown too long ago
Sub ResetFlags()
RightMouseDown = False
LeftMouseDown = False
End Sub
' Call this proc when opening Workbook
Sub StartHook()
If (hkLowLevelID = 0) Then
' Initiate the hooking process
hkLowLevelID = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, Application.Hinstance, 0)
End If
End Sub
' Call this proc when closing Workbook
Sub StopHook()
If hkLowLevelID <> 0 Then
UnhookWindowsHookEx hkLowLevelID
hkLowLevelID = 0
End If
End Sub
It defines 2 procs StartHook and StopHook that you use in "ThisWoorkbook":
Private Sub Workbook_Open()
Call StartHook
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call StopHook
End Sub
And 2 functions that you can use in the macro for the Sheets like this:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' Check if the mouse Left button was pressed
If (isLeftMouseDown()) Then
... do some stuff on left click - for example ...
If (ActiveCell.Column = 1) Then
MsgBox "You LeftClick in column A"
End If
...
End If
End Sub
Caution :
The flag can be read for 1 second after the click event, they are then reseted. That is to prevent some side effect when leaving excel and coming back to it.
Addendum to the code answer:
As of VBA 7 and above, the 'Declare' statements at the beginning need to also include 'PtrSafe'. Microsft added this check to ensure that the 'Declare' statement is safe to run in 64-bit versions of Office. See the article here:
https://learn.microsoft.com/en-us/office/vba/language/concepts/getting-started/64-bit-visual-basic-for-applications-overview

Excel Vba Print Userform and save Userform as pdf

I have a project that requires user entry form to be printed, renamed and saved to a specific folder
I've gone through numerous subjects relating to .printform command on this platform and usually the solutions requires to PrintScreen, save as bitmap, paste to new workbook and use Activesheet.ExportAsFixedFormat to set as pdf......
but then
My userforms width is 603,
My userforms height is 875,
The userform requires a vertical scrollbar to view all details
So "SnapScreen" wouldn't go a long way
The current code i have uses .printform command
and asks me to choose the printer i want to print to
and if the selected printer isn't active on my computer, it aborts command
Below is the code
Option Explicit
Private Const HWND_BROADCAST As Long = &HFFFF&
Private Const WM_WININICHANGE As Long = &H1A
Private Declare PtrSafe Sub keybd_event Lib "user32" _
(ByVal bVk As Byte, ByVal bScan As Byte, _
ByVal dwFlags As Long, ByVal dwExtraInfo As LongPtr)
Private Declare PtrSafe Function SendNotifyMessage Lib "user32" Alias "SendNotifyMessageA" ( _
ByVal hwnd As LongPtr, _
ByVal Msg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Declare PtrSafe Function SetDefaultPrinter Lib "winspool.drv" Alias "SetDefaultPrinterA" ( _
ByVal pszPrinter As String) As Long
Public Sub ChangePrinter(NewPrinter As String)
SetDefaultPrinter NewPrinter
Call SendNotifyMessage(HWND_BROADCAST, _
WM_WININICHANGE, _
0, ByVal "windows")
End Sub
Private Sub btn_Print_Click()
Dim Msg As String
Dim ireply As Integer
ireply = MsgBox("Select Active-Printer", vbQuestion + vbOKCancel)
Select Case ireply
Case vbOK
GoTo line123456
Case vbCancel
Exit Sub
End Select
line123456:
Dim dir as string
Dim OldPrinter As String
Dim NewPrinter As String
OldPrinter = Left(Application.ActivePrinter, InStrRev(Application.ActivePrinter, "on ") - 2)
Application.Dialogs(xlDialogPrinterSetup).Show
NewPrinter = Left(Application.ActivePrinter, InStrRev(Application.ActivePrinter, "on ") - 2)
''folderpath (created pdf to be renamed based on textbox value)
'dir = "C:\Users\user\Documents\Almadina Related\NHIS RELATED" & Me.txt_pNameDefaultclaimsForm.Value & ".pdf"
ChangePrinter NewPrinter
On Error GoTo Endproc
Me.PrintForm
GoTo SkipExit
Endproc:
MsgBox "Sorry, print command aborted - a default printer is not selected"
Unload Me
Exit Sub
SkipExit:
ChangePrinter OldPrinter
End Sub
Kindly Help.
is it possible to print, rename and save USERFORM to a specific folder as pdf
Thank You!

VBA to Close a PDF Document from Excel

I have this lovely little procedure that is supposed to either shut down the window with the Acrobat display or just one document in it. Only the design is of my own making, meaning I don't fully understand the code, but I do know that it works only partially. It will quit Adobe Acrobat in full, regardless of how many documents are displayed but it can't close just one (as the original from which it was transcribed claimed that it could and should).
Private Sub CloseReaderDC(Optional ByVal MailIdx As Integer)
Dim WinId As String
Dim Wnd As LongPtr
If MailIdx Then
WinId = AcrobatWindowID(Mail(MailIdx))
Wnd = FindWindow(vbNullString, WinId)
PostMessage Wnd, WM_CLOSE, 0, ByVal 0&
Else
WinId = AcrobatWindowID
Wnd = FindWindow(WinId, vbNullString)
SendMessage Wnd, WM_CLOSE, 0, ByVal 0&
End If
End Sub
The logic is that the parameter MailIdx identifies a file name which is sufficient to find a top window. If no value is given the app should be shut down. This part works. The other part also works, but only if there is a single document open, in which case not the document is closed but the entire application. I believe this shutdown may be caused by Acrobat Reader itself which doesn't see a reason for staying open with no document to display. I also think that the window handle may not be found if there are several documents because FindWindow finds a top window only and the one I want to close would be the second one. In practice, I tried both, to close the existing before opening another one and after. In the one case the app gets shut down, in the other nothing happens.
I don't know why my tutor uses SendMessage in one case and PostMessage in the other. I also don't know if the window I'm after is a Child Window or how to get a handle on it if it is. Any suggestions?
Edit 11 Jan 2021
I used the following code to test #FaneDuru's solution.
Private Sub Test_CloseReaderDC()
ReDim Mail(2)
Mail(0) = ""
Mail(1) = "File1.PDF"
Mail(2) = "File2.PDF"
CloseReaderDC 1
End Sub
Private Sub CloseReaderDC(Optional ByVal MailIdx As Integer)
' NIC 003 ++ 10 Jan 2021
Dim WinTitle As String
Dim WinCap As String
Dim Wnd As LongPtr
WinTitle = AcrobatWindowID
If MailIdx Then
WinCap = AcrobatWindowID(Mail(MailIdx))
Wnd = FindWindow(vbNullString, WinCap)
Debug.Print Wnd
SendMessage Wnd, WM_CloseClick, 6038, ByVal 0&
Else
Wnd = FindWindow(WinTitle, vbNullString)
Debug.Print Wnd
SendMessage Wnd, WM_CLOSE, 0, ByVal 0&
End If
End Sub
Function AcrobatWindowID(Optional ByVal Wn As String)
' NIC 003 ++ 07 Jan 2021
Dim Fun As Boolean
Fun = CBool(Len(Wn))
If Fun Then Wn = Wn & " - "
AcrobatWindowID = Wn & Split("AcrobatSDIWindow,Adobe Acrobat Reader DC", ",")(Abs(Fun))
End Function
The code worked perfectly for both 1 or 2 files, not closing the app until called with a parameter of 0. But on second try it failed to find the window and therefore took no action.
I started Acrobat and selected the 2 previously opened files from its File>Open menu. File1 was in the first tab, File2 in the second, active. Then I attempted to delete File1 which failed. Then I called the code with 2 as parameter which closed the top file. Thereafter the code found the window for File1 and closed it.
I don't think the apparent rule is followed consistently, however. How the files were opened seems to make a difference. In my project the files are opened by hyperlink, one at a time. My above test therefore is not indicative of how FaneDuru's suggestion will work in my project but it proves that the solution works.
You did not say anything about my comment regarding closing the active document by programmatically pressing the File menu "Close File" control...
This way of closing does not make Acrobat application quitting. It stay open, even if only a document was open in the moment of running the code.
So, test the next code line, please. You need the Acrobat Reader DC handler and the necessary arguments, like following:
Const WM_CloseClick = &H111
SendMessage Wnd, WM_CloseClick, 6038, ByVal 0&
6038 is the 'Close File' File menu control ID.
I could determine it using the next function:
Private Function findControlID(mainWHwnd As LongPtr, ctlNo As Long) As Long
Dim aMenu As LongPtr, sMenu As LongPtr
aMenu = GetMenu(mainWHwnd): Debug.Print "Main menu = " & Hex(aMenu)
sMenu = GetSubMenu(aMenu, 0&): Debug.Print "File menu = " & Hex(sMenu)
mCount = GetMenuItemCount(sMenu): Debug.Print "File menu no of controls: " & mCount 'check if it is 28
findControlID = GetMenuItemID(sMenu, ctlNo - 1) 'Menu controls are counted starting from 0
End Function
The above function was called in this way:
Sub testFindCloseControlID()
Dim Wnd As LongPtr
'Wnd = findWindowByPartialTitle("Adobe Acrobat Reader DC") 'you will obtain it in your way
Debug.Print findControlID(Wnd, 15) '15 means the fiftheenth control of the File menu (0)
End Sub
15 has been obtained counting the horizontal controls separators, too.
In order to find "Adobe Acrobat Reader DC" window handler I used the function mentioned above, but this does not matter too much. You may use your way of determining it...
Please, test the above way and send some comments
Edited:
In order to extract the applications menu(s) captions, I use the next declarations:
Option Explicit
'APIs for identify a window handler
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As LongPtr, _
ByVal lpString As String, ByVal cch As Long) As Long
Private Declare PtrSafe Function GetWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal wCmd As Long) As Long
'____________________________________________________
'Menu related APIs
Private Declare PtrSafe Function GetMenu Lib "user32.dll" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GetSubMenu Lib "user32" (ByVal hMenu As LongPtr, ByVal nPos As Long) As LongPtr
Private Declare PtrSafe Function GetMenuItemID Lib "user32" _
(ByVal hMenu As LongPtr, ByVal nPos As Long) As Long
Private Declare PtrSafe Function GetMenuItemCount Lib "user32" (ByVal hMenu As LongPtr) As Long
Private Declare PtrSafe Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" (ByVal hMenu As LongPtr, _
ByVal Un As Long, ByVal b As Long, lpMenuItemInfo As MENUITEMINFO) As Long
Private Declare PtrSafe Function GetMenuString Lib "user32" Alias "GetMenuStringA" (ByVal hMenu As LongPtr, _
ByVal wIDItem As Long, ByVal lpString As String, ByVal nMaxCount As Long, ByVal wFlag As Long) As Long
'_____________________________________________________
Private Type MENUITEMINFO
cbSize As Long
fMask As Long
fType As Long
fState As Long
wID As Long
hSubMenu As LongPtr
hbmpChecked As LongPtr
hbmpUnchecked As LongPtr
dwItemData As LongPtr
dwTypeData As String
cch As Long
hbmpItem As LongPtr
End Type
Private Const GW_HWNDNEXT = 2
And the next functions/subs:
To find any window knowing only its partial title:
Sub testFindWindByPartTitle()
Debug.Print findWindowByPartialTitle("Notepad")
End Sub
Private Function findWindowByPartialTitle(ByVal sCaption As String, Optional strSecond As String) As LongPtr
Dim lhWndP As LongPtr
Dim sStr As String
findWindowByPartialTitle = CLngPtr(0)
lhWndP = FindWindow(vbNullString, vbNullString) 'PARENT WINDOW
Do While lhWndP <> 0
sStr = String(GetWindowTextLength(lhWndP) + 1, Chr$(0))
GetWindowText lhWndP, sStr, Len(sStr)
If Len(sStr) > 0 Then sStr = left$(sStr, Len(sStr) - 1)
If InStr(1, sStr, sCaption) > 0 And _
IIf(strSecond <> "", InStr(1, sStr, strSecond) > 0, 1 = 1) Then
findWindowByPartialTitle = lhWndP
Exit Do
End If
lhWndP = GetWindow(lhWndP, GW_HWNDNEXT)
Loop
End Function
A version of extract the necessary ID by control caption, but it works only for Notepad:
Private Sub TestfindMenuItemsByCaption()
Const NotePApp As String = "Notepad"
Debug.Print findMenuIDByString(NotePApp, "Save") 'it does work
Const pdfApp As String = "Adobe Acrobat Reader DC"
Debug.Print findMenuIDByString(pdfApp, "Close") 'it does not work
End Sub
Private Function findMenuIDByString(pdfApp As String, searchString As String) As Long
Dim mainWHwnd As LongPtr, aMenu As LongPtr, mCount As Long
Dim LookFor As Long, sMenu As LongPtr, sCount As Long
Dim LookSub As Long, sID As Long, sString As String
mainWHwnd = findWindowByPartialTitle(pdfApp)
aMenu = GetMenu(mainWHwnd): Debug.Print "Main menu = " & Hex(aMenu)
sMenu = GetSubMenu(aMenu, 0): Debug.Print "File menu = " & Hex(sMenu)
sCount& = GetMenuItemCount(sMenu)
For LookSub& = 0 To sCount& - 1
sID& = GetMenuItemID(sMenu, LookSub&): Debug.Print "ID = " & sID: 'Stop
sString$ = String$(100, " ")
Call GetMenuString(sMenu, sID&, sString$, 100&, 1&) ' 1&)
Debug.Print sString$ ': Stop
If InStr(LCase(sString$), LCase(searchString$)) Then
findMenuIDByString = sID
Exit Function
End If
Next LookSub&
End Function
And a second version, unfortunately working exactly in the same way. I mean, returning the ID only for Notepad:
Private Sub TestfindMenuItemsByCaptionBis()
Const NotePApp As String = "Notepad"
Debug.Print findMenuItemIDByCaption(NotePApp, "Save")
Const pdfApp As String = "Adobe Acrobat Reader DC"
Debug.Print findMenuItemIDByCaption(pdfApp, "Close")
End Sub
Private Function findMenuItemIDByCaption(strApp As String, strCaption As String)
Dim appHwnd As LongPtr, hMenu As LongPtr, fMenu As LongPtr, i As Long
Dim retval As Long, mii As MENUITEMINFO 'mii receives information about each item
Const WM_SaveClick = &H111, MIIM_STATE = &H1, MIIM_STRING = &H40&, MIIM_ID = &H2&, MIIM_CHECKMARKS = &H8&
Const MIIM_SUBMENU = &H4&, MIIM_TYPE = &H10, MIIM_FTYPE = &H100&, MIIM_DATA = &H20&
appHwnd = findWindowByPartialTitle(strApp)
If appHwnd = 0 Then MsgBox "No application window found...": Exit Function
hMenu = GetMenu(appHwnd) 'application window Menu
fMenu = GetSubMenu(hMenu, 0) 'app window 'File' Submenu
For i = 0 To GetMenuItemCount(fMenu)
With mii
.cbSize = Len(mii)
.fMask = MIIM_STATE Or MIIM_SUBMENU Or MIIM_TYPE
.dwTypeData = space(256)
.cch = 256
retval = GetMenuItemInfo(fMenu, i, 1, mii) '2 = the third menu item
Debug.Print left(.dwTypeData, .cch)
If InStr(left(.dwTypeData, .cch), strCaption) > 0 Then
findMenuItemIDByCaption = GetMenuItemID(fMenu, i): Exit Function
End If
End With
Next i
End Function
I tried all constants as I could find, but not success... If we would find a way, a subroutine could also read the recent files list and activate the needed one, if is not the active one is the necessary one.

Determine if application is running with Excel

Goal
Have an Excel file with a "Search" button that opens a custom program. This program is used for researches. If the program is already opened when the user clicks on the button, make it popup and focus on that given program.
Current Situation
Here's the code I'm trying to use to make it work:
Search Button
Private Sub btnSearch_Click()
Dim x As Variant
Dim Path As String
If Not IsAppRunning("Word.Application") Then
Path = "C:\Tmp\MyProgram.exe"
x = Shell(Path, vbNormalFocus)
End If
End Sub
IsAppRunning()
Function IsAppRunning(ByVal sAppName) As Boolean
Dim oApp As Object
On Error Resume Next
Set oApp = GetObject(, sAppName)
If Not oApp Is Nothing Then
Set oApp = Nothing
IsAppRunning = True
End If
End Function
This code will work only when I put "Word.Application" as the executable. If I try to put "MyProgram.Application" the function will never see the program is running. How can I find that "MyProgram.exe" is currently opened?
Further more, I'd need to put the focus on it...
You can check this more directly by getting a list of open processes.
This will search based on the process name, returning true/false as appropriate.
Sub exampleIsProcessRunning()
Debug.Print IsProcessRunning("MyProgram.EXE")
Debug.Print IsProcessRunning("NOT RUNNING.EXE")
End Sub
Function IsProcessRunning(process As String)
Dim objList As Object
Set objList = GetObject("winmgmts:") _
.ExecQuery("select * from win32_process where name='" & process & "'")
IsProcessRunning = objList.Count > 0
End Function
Here's how I brought the search window to front:
Private Const SW_RESTORE = 9
Private Declare Function BringWindowToTop Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As Any, ByVal lpWindowName As Any) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Sub btnSearch_Click()
Dim x As Variant
Dim Path As String
If IsProcessRunning("MyProgram.exe") = False Then
Path = "C:\Tmp\MyProgram.exe"
x = Shell(Path, vbNormalFocus)
Else
Dim THandle As Long
THandle = FindWindow(vbEmpty, "Window / Form Text")
Dim iret As Long
iret = BringWindowToTop(THandle)
Call ShowWindow(THandle, SW_RESTORE)
End If
End Sub
Now if the window was minimized and the user clicks the search button again, the window will simply pop up.
Just want to point out that the Window Text may change when documents are open in the application instance.
For example, I was trying to bring CorelDRAW to focus and everything would work fine so long as there wasn't a document open in Corel, if there was, I would need to pass the complete name to FindWindow() including the open document.
So, instead of just:
FindWindow("CorelDRAW 2020 (64-Bit)")
It would have to be:
FindWindow("CorelDRAW 2020 (64-Bit) - C:\CompletePath\FileName.cdr")
As that is what would be returned from GetWindowText()
Obviously this is an issue as you don't know what document a user will have open in the application, so for anyone else who may be coming here, years later, who may be experiencing the same issue, here's what I did.
Option Explicit
Private Module
Private Const EXE_NAME As String = "CorelDRW.exe"
Private Const WINDOW_TEXT As String = "CorelDRAW 2020" ' This is common with all opened documents
Private Const GW_HWNDNEXT = 2
Private Const SW_RESTORE = 9
Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Private Declare PtrSafe Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As Any, ByVal lpWindowName As Any) As Long
Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Public Sub FocusIfRunning(parAppName as String, parWindowText as String)
Dim oProcs As Object
Dim lWindowHandle As Long
Dim sWindowText As String
Dim sBuffer As String
' Create WMI object and execute a WQL query statement to find if your application
' is a running process. The query will return an SWbemObjectSet.
Set oProcs = GetObject("winmgmts:").ExecQuery("SELECT * FROM win32_process WHERE " & _
"name = '" & parAppName & "'")
' The Count property of the SWbemObjectSet will be > 0 if there were
' matches to your query.
If oProcs.Count > 0 Then
' Go through all the handles checking if the start of the GetWindowText()
' result matches your WindowText pre-file name.
' GetWindowText() needs a buffer, that's what the Space(255) is.
lWindowHandle = FindWindow(vbEmpty, vbEmpty)
Do While lWindowHandle
sBuffer = Space(255)
sWindowText = Left(sBuffer, GetWindowText(lWindowHandle, sBuffer, 255))
If Mid(sWindowText, 1, Len(parWindowText)) Like parWindowText Then Exit Do
' Get the next handle. Will return 0 when there are no more.
lWindowHandle = GetWindow(lWindowHandle, GW_HWNDNEXT)
Loop
Call ShowWindow(lWindowHandle , SW_RESTORE)
End If
End Sub
Private Sub btnFocusWindow_Click()
Call FocusIfRunning(EXE_NAME, WINDOW_TEXT)
End Sub
Hopefully somebody gets use from this and doesn't have to spend the time on it I did.
Just wanted to say thank you for this solution. Only just started playing around with code and wanted to automate my job a bit. This code will paste current selection in excel sheet into an already open application with as single click. Will make my life so much easier!!
Thanks for sharing
Public Const SW_RESTORE = 9
Public Declare Function BringWindowToTop Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As Any, ByVal lpWindowName As Any) As Long
Public Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Public Sub updatepart()
'
' updatepart Macro
' copies current selection
' finds and focuses on all ready running Notepad application called Test
' pastes value into Notepad document
' Keyboard Shortcut: Ctrl+u
'
Dim data As Range
Set data = Application.Selection
If data.Count <> 1 Then
MsgBox "Selection is too large"
Exit Sub
End If
Selection.Copy
If IsProcessRunning("Notepad.EXE") = False Then
MsgBox "Notepad is down"
Else
Dim THandle As Long
THandle = FindWindow(vbEmpty, "Test - Notepad")
Dim iret As Long
iret = BringWindowToTop(THandle)
Call ShowWindow(THandle, SW_RESTORE)
End If
waittime (500)
'Call SendKeys("{F7}")
Call SendKeys("^v", True) '{F12}
Call SendKeys("{ENTER}")
End Sub
Function waittime(ByVal milliseconds As Double)
Application.Wait (Now() + milliseconds / 24 / 60 / 60 / 1000)
End Function
Function IsProcessRunning(process As String)
Dim objList As Object
Set objList = GetObject("winmgmts:") _
.ExecQuery("select * from win32_process where name='" & process & "'")
If objList.Count > 0 Then
IsProcessRunning = True
Else
IsProcessRunning = False
End If
End Function

Resources