Heres my code that does not work:
Private Const MOUSEEVENTF_LEFTDOWN = &H2
Private Const MOUSEEVENTF_LEFTUP = &H4
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Integer
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim wHandle As Long = FindWindow(vbNullString, "Ultima Online")
PostMessage(wHandle, MOUSEEVENTF_LEFTDOWN, 0, 0)
PostMessage(wHandle, MOUSEEVENTF_LEFTUP, 0, 0)
I'm not sure why this code should work - it seems you're just clicking on the window, not on a specific button.
To minimize windows you could use another api function: SetWindowPlacement,
see: http://www.codeproject.com/KB/dialog/Minimizewindow.aspx
Another idea: If you want a hacky solution you can send the keys Alt+Space n to minimize a window, but this is very hacky, and works only for English machines:
SendKeys ("% n") ''//in vb6
SendKeys.Send("% n") ''//in vb.net
Related
#If VBA7 And Win64 Then
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
#End If
Private Sub close_window()
Dim WinWnd As Long, Ret As String, RetVal As Long, lpClassName As String
'Ask for a Window title
'Ret = InputBox("Enter the exact window title:" + Chr$(13) + Chr$(10) + "Note: must be an exact match")
'Search the window
WinWnd = FindWindow(vbNullString, "somedocument.docx - Word")
If WinWnd = 0 Then MsgBox "Couldn't find the window ...": Exit Sub
'Show the window
ShowWindow WinWnd, SW_SHOWNORMAL
'Create a buffer
lpClassName = Space(256)
'retrieve the class name
RetVal = GetClassName(WinWnd, lpClassName, 256)
'Show the classname
MsgBox "Classname: " + Left$(lpClassName, RetVal)
'Post a message to the window to close itself
'PostMessage WinWnd, WM_CLOSE, 0&, 0&
End Sub
The purpose of the aforementioned code is to close a Word document. But, even if comment the PostMessage WinWnd, WM_CLOSE, 0&, 0&
as showed above, the word doc indeed closes whereas uncommenting the postmessage command, the window doesn't close. I have come to the conclusion (by commenting line by line the above code) that ShowWindow WinWnd, SW_SHOWNORMAL function closes the window(word document). Is this normal?
Following FaneDuru's suggestions here is the code that succesfully accomplishes the task:
#If VBA7 And Win64 Then
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
#End If
Private Sub Form_Load()
Dim WinWnd As LongPtr, Ret As String, RetVal As Long, lpClassName As String
'Ask for a Window title
'Ret = InputBox("Enter the exact window title:" + Chr$(13) + Chr$(10) + "Note: must be an exact match")
'Search the window
WinWnd = FindWindow(vbNullString, "some_document.docx - Word")
If WinWnd = 0 Then MsgBox "Couldn't find the window ...": Exit Sub
'Show the window
ShowWindow WinWnd, SW_SHOWNORMAL
'Create a buffer
lpClassName = Space(256)
'retrieve the class name
'RetVal = GetClassName(WinWnd, lpClassName, 256)
'Show the classname
'MsgBox "Classname: " + Left$(lpClassName, RetVal)
'Post a message to the window to close itself
PostMessage WinWnd, WM_CLOSE, 0&, 0&
End Sub
i am using Office 2016 and i want to do a PowerPoint presentation where you can't exit slide show just with hitting ESC key, so you can interact with slides only by your mouse ( or eventually exit it with a key combination but not by just clicking ESC ). Kiosk mode do most of work but still ESC is available. I know about NoEsc add-in but it does not work for me. It just not showing me that menu in Ribbon or elsewhere, but other add-ins do and they appear in Add-ins tab next to View tab in. So i found a code on other website for keyboard disabling macro but it works only on 32-bit and can't run on 64-bit. Im not a coder so i need a little help how can i make it work on 64-bit or 32+64-bit.
Here is an original code from website:
Option Explicit
'Esc Disable Key
Private Const WH_KEYBOARD_LL = 13&
Private Const HC_ACTION = 0&
Private Const VK_ESCAPE = &H1B
Private Type KBDLLHOOKSTRUCT
vkCode As Long
scanCode As Long
flags As Long
time As Long
dwExtraInfo As Long
End Type
Dim Response As Integer
Private 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
Public Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Sub CopyMemory Lib "Kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal cb As Long)
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Public m_hDllKbdHook As Long
Public Sub hookup()
Call UnhookWindowsHookEx(m_hDllKbdHook)
m_hDllKbdHook = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf LowLevelKeyboardProc, App.hInstance, 0&)
End Sub
Public Function LowLevelKeyboardProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Static kbdllhs As KBDLLHOOKSTRUCT
If nCode = HC_ACTION Then
Call CopyMemory(kbdllhs, ByVal lParam, Len(kbdllhs))
If (kbdllhs.vkCode = VK_ESCAPE) Then
LowLevelKeyboardProc = 1
End If
End If
End Function
And Here is what i did so far:
Change App.hInstance to 0&, because i got an error that App. is not defined.
Public Sub hookup()
Call UnhookWindowsHookEx(m_hDllKbdHook)
m_hDllKbdHook = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf LowLevelKeyboardProc, App.hInstance, 0&)
End Sub
To
Public Sub hookup()
Call UnhookWindowsHookEx(m_hDllKbdHook)
m_hDllKbdHook = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf LowLevelKeyboardProc, 0&, 0&)
End Sub
Added PtrSafe next to all Declare
But then mismatch appeared here and highlight "AddressOf LowLevelKeyboardProc"
Public Sub hookup()
Call UnhookWindowsHookEx(m_hDllKbdHook)
m_hDllKbdHook = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf LowLevelKeyboardProc, 0&, 0&)
End Sub
So i changed "lpfn As Long" to "lpfn As LongPtr" and then mismatch error is gone.
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
To
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
But the problem is, even if i got rid of all error messages in macro editor and i can run this macro with no troubles seems like it does nothing during slide show. ESC key is still working even after running it by Macro Window or clicking action button for "Run macro" during show.
Macros are set to Always Enabled ( Lowest security mode ) in Office Options and presentation is saved as (.ppsm), so macro-enabled format.
Here is my full modified code:
Option Explicit
'Esc Disable Key
Private Const WH_KEYBOARD_LL = 13&
Private Const HC_ACTION = 0&
Private Const VK_ESCAPE = &H1B
Private Type KBDLLHOOKSTRUCT
vkCode As Long
scanCode As Long
flags As Long
time As Long
dwExtraInfo As Long
End Type
Dim Response As Integer
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Public Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare PtrSafe Sub CopyMemory Lib "Kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal cb As Long)
Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Public m_hDllKbdHook As Long
Public Sub hookup()
Call UnhookWindowsHookEx(m_hDllKbdHook)
m_hDllKbdHook = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf LowLevelKeyboardProc, 0&, 0&)
End Sub
Public Function LowLevelKeyboardProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Static kbdllhs As KBDLLHOOKSTRUCT
If nCode = HC_ACTION Then
Call CopyMemory(kbdllhs, ByVal lParam, Len(kbdllhs))
If (kbdllhs.vkCode = VK_ESCAPE) Then
LowLevelKeyboardProc = 1
End If
End If
End Function
Thank you, and sorry for my bad english :)
This used to be a big problem when people were deep diving into Excel API functions. Luckily this website has a lot of what you need all in one spot:
https://jkp-ads.com/Articles/apideclarations.asp
It's pretty much what you need : )
Will a kind soul help to provide a vba solution to press a button (e.g 3) in Microsoft calculator without using sendkeys?
Please pardon my bad work as i am new, I believe i am stuck because the windows are not unique.
If anyone has a solution to this problem, please feel free to post your answers. I welcome all alternatives other than sendkeys. Thank you very much.
Below is my failed code.
Private Const BM_CLICK = &HF5
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) 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
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWndParent As Long, ByVal hWndChildAfter As Long, ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Sub Calculator()
Dim Program As String, TaskID As Double
Program = "calc.exe"
On Error Resume Next
AppActivate "Calculator"
If Err <> 0 Then
Err = 0
TaskID = Shell(Program, 1)
Do
DoEvents
hwindow2 = FindWindow(vbNullString, "Calculator")
Loop Until hwindow2 > 0
main_view = FindWindowEx(hwindow2, 0&, "Calcframe", vbNullString)
sub_view = FindWindowEx(main_view, 0&, "#32770", vbNullString)
sub_window = FindWindowEx(sub_view, 0&, "Button", vbNullString)
'Call SendMessage(sub_window, BM_CLICK, 0, ByVal0&)
If Err <> 0 Then MsgBox "Can't start " & Program
End If
End Sub
So I have a method I am using to which I can integrate powerpoint into a panel. I use the FindWindow and SetParent functions to achieve this:
Dim proc as integer
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As Long) As Long
Private Declare Function SetParent Lib "user32" Alias "SetParent" (ByVal hWndChild As IntPtr, ByVal hWndNewParent As IntPtr) As Integer
Public Sub embed_Window()
Do Until proc <> 0
proc = FindWindow(vbNullString, window_name)
Loop
SetParent(proc, Panel1.Handle)
End Sub
This part works fine for embedding another window into my panel control. My question is, how can I close the window that is now in my panel? I can no longer use the FindWindow method as it is not a window in the task bar anymore.
In order to close an opened window you need to use PostMessage:
Private Declare Auto Function PostMessage Lib "user32" (ByVal hwnd As Integer, ByVal message As UInteger, ByVal wParam As Integer, ByVal lParam As Integer) As Boolean
Public Const WM_CLOSE = &H10
Public Sub CloseWindow()
PostMessage(proc, WM_CLOSE, 0, 0)
End Sub
I'm working on an Excel Workbook that uses VBA for data input, since I don't want the application itself to be available to the user if the user does not know the password.
I managed to set up the Userform for data input and then a new Userform for the password input.
However, I noticed that the password is easily bypassed if the Password Userform is terminated.
I tried to make the Userform_Terminate() take the user back to the previous Userform, but it just creates an endless loop.
Anyone know a workaround for this?
Private Sub UserForm_Terminate()
Unload Me
UserForm1.Show
End Sub
If what you need is disallowing user closing UserForm, then here is a solution.
Disable leaving form with either close button click or Alt+F4:
Code within UserForm:
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then Cancel = True
End Sub
Make close button on form unclickable and grayed out:
Code within UserForm:
Private Sub UserForm_Initialize()
DisableCloseButton (Me.Caption) 'disable close button (X)
End Sub
Code within a module, works for 32 and 64 bit:
Option Explicit
Private Const MF_BYPOSITION = &H400
Private Const MF_REMOVE = &H1000
#If VBA7 Then '64 bit
Private Declare PtrSafe Function DrawMenuBar Lib "User32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GetMenuItemCount Lib "User32" (ByVal hMenu As LongPtr) As LongPtr
Private Declare PtrSafe Function GetSystemMenu Lib "User32" (ByVal hwnd As LongPtr, ByVal bRevert As LongPtr) As LongPtr
Private Declare PtrSafe Function RemoveMenu Lib "User32" (ByVal hMenu As LongPtr, ByVal nPosition As LongPtr, ByVal wFlags As LongPtr) As LongPtr
Private Declare PtrSafe Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private hwnd As LongPtr
#Else '32 bit
Private Declare Function DrawMenuBar Lib "User32" (ByVal hwnd As Long) As Long
Private Declare Function GetMenuItemCount Lib "User32" (ByVal hMenu As Long) As Long
Private Declare Function GetSystemMenu Lib "User32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Private Declare Function RemoveMenu Lib "User32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Declare Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private hwnd As Long
#End If
Public Sub DisableCloseButton(ByVal formCaption As String) 'deactivates the upper right "x" in the user form
#If VBA7 Then '64 bit
Dim hMenu As LongPtr, menuItemCount As LongPtr
#Else '32 bit
Dim hMenu As Long, menuItemCount As Long
#End If
hwnd = FindWindow(vbNullString, formCaption) 'Obtain the window handle to the userform
hMenu = GetSystemMenu(hwnd, 0) 'Obtain the handle to the form's system menu
'Clear list box
If hMenu Then
menuItemCount = GetMenuItemCount(hMenu) 'Obtain the number of items in the menu
'Remove the system menu Close menu item. The menu item is 0-based, so the last item on the menu is menuItemCount - 1
Call RemoveMenu(hMenu, menuItemCount - 1, MF_REMOVE Or MF_BYPOSITION)
Call RemoveMenu(hMenu, menuItemCount - 2, MF_REMOVE Or MF_BYPOSITION) 'Remove the system menu separator line
Call DrawMenuBar(hwnd) 'Force a redraw of the menu. This refreshes the titlebar, dimming the X
End If
End Sub