Stop transaction in SAP with VBA - excel

I have a working VBA macro which enters SAP, starts a transaction and then extracts the data in spreadsheet.
But sometimes the calculation runs too long, or I just would like to stop it to intervene. There is a functionality on the toolbar at the top left corner, where the user can "stop transaction" manually.
Is there any SAP script code for the "stop transaction" button, so I can avoid the manual step?
SAP toolbar:

It is assumed that the VBA macro is running in the first session. If a second session is opened before starting the macro, it can be used to close the first session.
for example:
Set SapGuiAuto = GetObject("SAPGUI")
Set SAPapp = SapGuiAuto.GetScriptingEngine
Set SAPconnection = SAPapp.Children(0)
Set session = SAPconnection.Children(1)
session.findById("wnd[0]/tbar[0]/okcd").text = "/i1"
session.findById("wnd[0]").sendVKey 0
session.createSession
Application.Wait (Now + TimeValue("0:00:05"))
session.findById("wnd[0]/tbar[0]/okcd").text = "/i3"
session.findById("wnd[0]").sendVKey 0
session.createSession
Application.Wait (Now + TimeValue("0:00:05"))
Whether a "rollback" is carried out or not, would be to test.
Regards,
ScriptMan

I guess you better record a script with this scenario, then you can re-use it any time.
Otherwise, I am at the very moment struggling with the same case, but with the run time counter part to leave the tcode if running too long.
It is a hart nut to crack too, but a different topic.
Update: realizing that there is no way to get the 'Stop Transaction' step recorded, I applied the above method - thank you Script Man, it was not the first time you saved the day.
For anyone reading this thread - may be useful to know how to split the SAP runtime from VBA script runtime.
I introduced an object that is the 'Execute' command itself. This way, SAP takes the command and starts execution, while the macro will step over as it is not an actual command but applying a new object only. This trick can help users to write a time counter and drop the session if running too long.
For reference, see my code here - I quoted the part of my code that contains the relevant method.
'check whether you already have an extra session open to close the long running session
'open one if needed
On Error Resume Next
Set session1 = Connection.Children(1)
If Err.Number <> 0 Then
session.CreateSession
Application.Wait (Now + TimeValue("0:00:05"))
're-set the sessions, ensuring you use the first session for actual work and keep session1 in background
Set session = Connection.Children(0)
Set session1 = Connection.Children(1)
SesCount = Connection.Sessions.Count()
Err.Clear
On Error GoTo 0
End If
'get the ID of first session, so you can enter the correct terminating transaction code when needed
sessionID = Mid(session.ID, (InStrRev(session.ID, "[") + 1), 1)
Terminator = "/i" & sessionID + 1
session.FindById("wnd[0]").Maximize
'some code comes here
'here I use an object to apply the execute button - this way parallel with the SAP runtime, the VBA script can proceed.
perec = session.FindById("wnd[0]/tbar[1]/btn[8]").press
'here we set a loop to check whether system is busy over a certain time then we may interrupt:
Do
Application.Wait (Now + TimeValue("0:00:05"))
SecondsElapsed = SecondsElapsed + 5
fityirc = session.Busy()
if fityirc = False then
exit Do
end if
Loop Until SecondsElapsed >= 100
If fityirc = True Then
session1.FindById("wnd[0]/tbar[0]/okcd").Text = Terminator
session1.FindById("wnd[0]").sendVKey 0
End If
'...and so on. This solution is applied in a loop to extract datasets massively without human interaction.

Or, have a look at code I've just written and tested to use the Windows API to run the Stop Transaction menu item. I raised a question about it on the SAP forum, but figured it out myself in the meantime (SAP Forum)
Private Declare PtrSafe Function FindWindowA Lib "user32.dll" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function GetSystemMenu Lib "user32" (ByVal hWnd As LongPtr, ByVal bRevert As Long) As LongPtr
Private Declare PtrSafe Function GetMenuItemCount Lib "user32" (ByVal hMenu As LongPtr) As Long
Private Declare PtrSafe Function GetMenuItemInfoA Lib "user32" (ByVal hMenu As LongPtr, ByVal un As Long, ByVal b As Long, lpMenuItemInfo As MENUITEMINFO) As Long
Private Declare PtrSafe Function SendMessageA Lib "user32" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Public Const MIIM_STRING As Integer = &H40
Public Const MIIM_ID = &H2
Public Const WM_COMMAND = &H111
Public Const WM_SYSCOMMAND = &H112
Public Type MENUITEMINFO
cbSize As Long
fMask As Long
fType As Long
fState As Long
wID As LongPtr
hSubMenu As Long
hbmpChecked As Long
hbmpUnchecked As Long
dwItemData As Long
dwTypeData As String
cch As Long
End Type
Public Function RunMenuItemByString(ByVal sMenuItem As String, _
ByVal sWindowClass As String, _
ByVal sWindowText As String, _
ByVal iCommandType As Integer) As Boolean
Dim hWnd As LongPtr, hMenu As LongPtr, lpMenuItemID As LongPtr
Dim lngMenuItemCount As Long, lngMenuItem As Long, lngResultMenuItemInfo As Long
Dim typMI As MENUITEMINFO
Dim s As String
Dim blnRet As Boolean
hWnd = FindWindowA(sWindowClass, sWindowText)
hMenu = GetSystemMenu(hWnd, 0&)
lngMenuItemCount = GetMenuItemCount(hMenu)
For lngMenuItem = 0 To lngMenuItemCount - 1
typMI.cbSize = Len(typMI)
typMI.dwTypeData = String$(255, " ")
typMI.cch = Len(typMI.dwTypeData)
typMI.fMask = MIIM_STRING Or MIIM_ID
lngResultMenuItemInfo = GetMenuItemInfoA(hMenu, lngMenuItem, 1, typMI)
s = Trim$(typMI.dwTypeData)
lpMenuItemID = typMI.wID
If InStr(1, s, sMenuItem, vbTextCompare) > 0 Then
blnRet = SendMessageA(hWnd, iCommandType, lpMenuItemID, 0&) = 0
Exit For
End If
Next lngMenuItem
RunMenuItemByString = blnRet
End Function
Public Function TestRunMenuItemByString()
lpHwndSAPSession = oSAPSession.FindById("wnd[0]").Handle
sWindowText = GetWindowText(lpHwndSAPSession)
TestRunMenuItemByString = RunMenuItemByString("Stop Transaction", "SAP_FRONTEND_SESSION", sWindowText, WM_SYSCOMMAND)
End Function
The TestRunMenuItemByString function can be used only after a session is started, and will only work if there is actually a transaction executing. You will need to figure out how to reference your sap session object (oSAPSession) in order to use the Handle value from it.
The declarations should work in both 32 bit and 64 bit versions of VBA and the LongPtr has been used for the handle (h) and pointer (lp) variables to reflect this.
This was tested in Microsoft Access, but I see no reason why it shouldn't work in VBA in other Office applications. I can't vouch for it being adaptable for VBScript.

Related

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.

Send Keys & AppActivate

Method:
I'm using a combination of SendKeys & Virtual Keyboard to send key strokes to a core administration system that is stored on Citrix as an application. The VBA code is identifying the application by using the AppActivate & Application.ActiveWindow methods.
Goal:
My goal is to have an user to input data into an excel spreadsheet and send the data to the core administration system using VBA in lieu of the user manually keying.
Problem:
My problems are many, but as of right now, I'm struggling to send Ctrl + f to the core administration system application. It doesn't seem to recognize the stroke, however, sending f alone or enter "keybd_event VK_RETURN, mvk, 0, 0" seems to work. Also, "keybd_event VK_CONTROL, mvk, 0, 0" seemed promising but I get an "Overflow" error when ran.
Code (So Far):
Option Explicit
Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte,
ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Declare PtrSafe Function MapVirtualKey Lib "user32" Alias "
MapVirtualKeyA" (ByVal wCode As Long, ByVal wMapType As Long) As Long
Private Const VK_RETURN = &HD
Private Const VK_CONTROL = &HD11
Private Const KEYEVENTF_KEYUP = &H2
Sub pleasework5()
Dim keys As String
Dim wsh As Object
Dim mvk As Double
Set wsh = CreateObject("WScript.Shell")
mvk = MapVirtualKey(VK_RETURN, 0)
AppActivate ("application name") 'use form to enter username
Application.ActiveWindow.Activate
Application.Wait Now() + TimeValue("00:00:05")
'keybd_event VK_CONTROL, mvk, 0, 0
wsh.SendKeys ("^f"), True
Please let me know how to send Ctrl + f to the system application or if there's a better method of going about this.
Thank you!
I hope you've found the solution by now. However, here's what I do to send Ctrl + L
SendKeys "(^l)"
Hope that helps

Is there any possible way to track the windows lock and unlock time using vba excel

I want to track the time for windows lock and unlock.
Is there any possible way to track the windows lock and unlock time using vba excel?
Thanks in advance.
Private Declare Function SwitchDesktop Lib "user32" (ByVal hDesktop As Long) As Long
Private Declare Function OpenDesktop Lib "user32" Alias "OpenDesktopA" (ByVal lpszDesktop As String, ByVal dwFlags As Long, ByVal fInherit As Long, ByVal dwDesiredAccess As Long) As Long
Private Declare Function CloseDesktop Lib "user32" (ByVal hDesktop As Long) As Long
Private Const DESKTOP_SWITCHDESKTOP As Long = &H100
Function Check_If_Locked() As String
Dim p_lngHwnd As Long
Dim p_lngRtn As Long
Dim p_lngErr As Long
p_lngHwnd = OpenDesktop(lpszDesktop:="Default", dwFlags:=0, fInherit:=False, dwDesiredAccess:=DESKTOP_SWITCHDESKTOP)
If p_lngHwnd = 0 Then
system = "Error"
Else
p_lngRtn = SwitchDesktop(hDesktop:=p_lngHwnd)
p_lngErr = Err.LastDllError
If p_lngRtn = 0 Then
If p_lngErr = 0 Then
system = "Locked"
Else
system = "Error"
End If
Else
system = "Unlocked"
End If
p_lngHwnd = CloseDesktop(p_lngHwnd)
End If
Check_If_Locked = system
End Function
Private Sub Form_Timer()
Debug.Print Check_If_Locked
End Sub
You are probably better off to look in the event log afterwards rather than trying to use Excel to track in realtime when this happens. See this answer for the event log id values.
There is also this post on SuperUser.

Excel VBA application.sendkeys "^C", True not working

I am using Excel VBA to copy text selection from an Access file (I'd prefer not to get into details as to why). I have it in a Do While loop that SHOULD press the tab key (works), then copies the data (fails), puts it into the clipboard (works), and sets the clipboard information to a variable (works), which then, for debugging purposes, does a debug.print of the variable (works). This is to cycle through a form to get to a "base point" where I can 100% use tabs and such to navigate to other parts of the form. See code please:
AppActivate ("Microsoft Access - Filename that is constant")
X = 0
Do While X < 14
Application.SendKeys "{TAB}", True
Application.SendKeys "^C", True
Sleep (500)
mydata.GetFromClipboard
cb = mydata.GetText
Debug.Print (cb)
If Len(cb) = 5 Then
X = 14
End If
X = X + 1
Loop
Set mydata = Nothing
I've tried getting this to work, but to no avail. What am I doing wrong or perhaps what would be a better solution?
Though I hate Sendkeys and was wondering whether I should ask you about it but since you said not to ask why, I will keep my trap shut. :P
Try this small fix... If this works then that means, you need to give it some time before issuing the next sendkeys command.
Sub Sample()
'
'~~> Rest of your code
'
Application.SendKeys "{TAB}", True
Wait 2
Application.SendKeys "^{C}", True
'
'~~> Rest of your code
'
End Sub
Private Sub Wait(ByVal nSec As Long)
nSec = nSec + Timer
While nSec > Timer
DoEvents
Wend
End Sub
what would be a better solution?
Use APIs as shown Here. This doesn't directly answer your question but it explains how the concept works.
So applying that would be something like this
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Dim Ret As Long
Sub Sample()
Ret = FindWindow(vbNullString, "Microsoft Access - Filename that is constant")
If Ret <> 0 Then
MsgBox "Window Found"
Else
MsgBox "Window Not Found"
End If
End Sub
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++. Another example which demonstrates how this API is used.
I figured it out. I copied the code from here: http://www.vbaexpress.com/forum/showthread.php?38826-SendInput()-in-Excel-64Bit
I changed VkkeyMenu to VbKeyControl and the "f" key to "C". I know it could be simplified to take up less lines, but I'd rather not mess with it if it works like the saying "If it ain't broke, don't fix it." Code:
Private Declare PtrSafe Function SendInput Lib "user32" (ByVal nInputs As LongPtr, pInputs As Any, ByVal cbSize As LongPtr) As LongPtr
Private Declare PtrSafe Function VkKeyScan Lib "user32" Alias "VkKeyScanA" (ByVal cChar As Byte) As Integer
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Type KeyboardInput ' creating variable type
dwType As Long ' input type (keyboard or mouse)
wVk As Integer ' the key to press/release as ASCSI scan code
wScan As Integer ' not required
dwFlags As Long ' specify if key is pressed or released
dwTime As Long ' not required
dwExtraInfo As Long ' not required
dwPadding As Currency ' only required for mouse inputs
End Type
' SendInput constants
Private Const INPUT_KEYBOARD As Long = 1
Private Const KEYEVENTF_EXTENDEDKEY As Long = 1
Private Const KEYEVENTF_KEYUP As Long = 2
' Member variables
Private TheKeys() As KeyboardInput
Private NEvents As Long
Sub testage()
ReDim TheKeys(0 To 3)
With TheKeys(0)
.dwType = INPUT_KEYBOARD 'operation type
.wVk = vbKeyControl 'press CTRL key
End With
With TheKeys(1)
.dwType = INPUT_KEYBOARD ' operation
.wVk = VkKeyScan(Asc("C")) 'press chr key
End With
With TheKeys(2)
.dwType = INPUT_KEYBOARD 'operation type
.wVk = VkKeyScan(Asc("C"))
.dwFlags = KEYEVENTF_KEYUP 'release chr key
End With
With TheKeys(3)
.dwType = INPUT_KEYBOARD ' operation type
.wVk = vbKeyControl
.dwFlags = KEYEVENTF_KEYUP 'release CTRL Key
End With
Call SendInput(4, TheKeys(0), Len(TheKeys(0)))
Erase TheKeys
End Sub

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