I have an Access 2019 database and want to include a button to open the ODBC administrator. The event procedure on click is written as
Private Sub Command210_Click()
Dim RetVal
RetVal = Shell("odbcad32.exe", 1)
End Sub
however this does not work, if I replace odbcad32.exe with notepad.exe it will open notepad on clicking but odbcad32 does not work - any ideas why?
Based on one of my previous answers you could call the ODBC administrator like that
Option Compare Database
Option Explicit
Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias _
"ShellExecuteA" (ByVal hwnd As LongPtr, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As LongPtr
Private Declare PtrSafe Function Wow64EnableWow64FsRedirection _
Lib "kernel32.dll" (ByVal Enable As Boolean) As Boolean
Private Sub RunODBC_on64Bit()
Const SW_SHOWNORMAL = 1
On Error Resume Next
Wow64EnableWow64FsRedirection False
ShellExecute 0, "open", "odbcad32.exe", "", "C:\windows\system32\odbcad32.exe", SW_SHOWNORMAL
Wow64EnableWow64FsRedirection True
End Sub
I got it in the end - I replaced line
RetVal = Shell("odbcad32.exe", 1)
with
RetVal = Shell("Explorer.exe ""C:\Windows\SysWOW64\odbcad32.exe""", 1)
and that sorted it.
Related
(I am not a native English speaker, I use google translate, then modify. If something wrong, forgive my poor English.)
My goal is to make a Userform with scrollbar in MS Word, hoping to scroll with the mouse wheel.
But VBA doesn't offer MouseScroll Event Handler. After searching, I know it can be achieved with WinAPI Hook.
I refer to the examples in “Subclassing and Hooking with Visual Basic (O'Reilly, 2001)”. After modification, my code can be successfully executed with modal Userform.
But when I open Userform in Modeless mode, once the hook is executed, the entire Windows system will be stuck, clicking windows of other program didn't respond, and the CPU usage > 80%.
I used Debug.Print to output some text. When I looked at the VBE’s immediate window, the macro was still executing, but it fell into an infinite loop.
My code is below:
(I use Win10 64-bit and Office 365 Word 64-bit. 64-bit API declaration is according to the document on Microsoft's official website.)
MouseHook Module code：
Option Explicit
Type POINTAPI
X As Long
Y As Long
End Type
Type MOUSEHOOKSTRUCT
pt As POINTAPI
hwnd As LongPtr
wHitTestCode As Long
dwExtraInfo As LongPtr
End Type
'This structure is just the extension of MOUSEHOOKSTRUCT
Type MOUSEHOOKSTRUCTEX
structMouseHook As MOUSEHOOKSTRUCT
mousedata As Long
End Type
Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" ( _
ByVal idHook As Long, _
ByVal lpfn As LongPtr, _
ByVal hmod As LongPtr, _
ByVal dwThreadId As Long) As LongPtr
Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" ( _
ByVal hhk As LongPtr) As Long
Declare PtrSafe Function CallNextHookEx Lib "user32" ( _
ByVal hHook As LongPtr, _
ByVal nCode As Long, _
ByVal wParam As LongPtr, _
lParam As Any) As LongPtr
Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
Private Const WH_MOUSE As Long = 7
Private Const HC_ACTION As Long = 0
Public IsHooked As Boolean
Private mhook As LongPtr
Private i As Long
Public Sub SetMouseHook()
If IsHooked Then
MsgBox "Don't hook the MOUSE twice."
Else
'I perform thread-specific Hook
mhook = SetWindowsHookEx(WH_MOUSE, AddressOf MouseProc, 0, GetCurrentThreadId)
IsHooked = True
End If
End Sub
Public Sub RemoveMouseHook()
Call UnhookWindowsHookEx(mhook)
IsHooked = False
End Sub
Public Function MouseProc( _
ByVal uCode As Long, _
ByVal wParam As LongPtr, _
lParam As MOUSEHOOKSTRUCTEX) As LongPtr
If uCode = HC_ACTION Then
Debug.Print i & "HC_ACTION" & lParam.mousedata: i = i + 1
'To emphasize the keypoint, I omitted some irrelevant code.
'lParam.mousedata gives you the direction of the mousewheel scrolling.
'(by positive or negative)
End If
MouseProc = CallNextHookEx(mhook, uCode, wParam, lParam)
End Function
Userform code:
(The form has two command buttons, which perform sethook and unhook function.)
Option Explicit
Private Sub cmdHook_Click()
Call SetMouseHook
End Sub
Private Sub cmdUnHook_Click()
Call RemoveMouseHook
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Call RemoveMouseHook
End Sub
How to solve this problem?
If the Modeless Userform cannot use the WH_MOUSE hook, are there any alternatives, like WH_MOUSE_LL hook or VSTO?
Thank you all.
===== Update =====
In my final test, I find that ‘WH_MOUSE Hook’, ‘WH_MOUSE_LL Hook’, and ‘Instance Subclassing’ all can work in Modeless VBA Userform.
But you should close the VBE first, and then execute the macro from the Macros dialog box (ALT+F8). (I executed the macro with VBE opened before.)
my Subclassing code is below:
Subclassing Userform code:
Option Explicit
'the Userform name is "frmSubclass"
'it contains 2 cmdButtons and 1 Frame with vertical scrollbar
'click the "SetSubclass Button" to SetSubclass
'click the "UnSubclass Button" to unSubclass
Private Sub cmdSetSubclass_Click()
Call SetSubclass
End Sub
Private Sub cmdUnSubclass_Click()
Call unSubclass
End Sub
Private Sub UserForm_Initialize()
Me.Frame1.ScrollBars = fmScrollBarsVertical
Me.Frame1.ScrollHeight = 1000
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Call unSubclass
End Sub
Subclassing bas Module code：
Option Explicit
'WinAPI function
Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
Declare PtrSafe Function GetWindow Lib "user32" ( _
ByVal hwnd As LongPtr, _
ByVal wCmd As Long) As LongPtr
Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongPtrA" ( _
ByVal hwnd As LongPtr, _
ByVal nIndex As Long, _
ByVal dwNewLong As LongPtr) As LongPtr
Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcA" ( _
ByVal lpPrevWndFunc As LongPtr, _
ByVal hwnd As LongPtr, _
ByVal Msg As Long, _
ByVal wParam As LongPtr, _
ByVal lParam As LongPtr) As LongPtr
'Windows constant
Private Const GW_CHILD As Long = 5
Private Const GWLP_WNDPROC As Long = -4
Private Const WM_MOUSEWHEEL As Long = &H20A
'module-level variables
Private m_OrigWndProc As LongPtr
Private m_hwnd As LongPtr
Public Function SetSubclass() As Boolean
'I want to Subclassing the frame window inside the Main Userform
'not the Main userform itself
'get hwnd of Main Userform window which classname is "ThunderDFrame" in VBA
m_hwnd = FindWindow("ThunderDFrame", vbNullString)
Debug.Print IIf(m_hwnd <> 0, "Find Window: " & Hex$(m_hwnd), "Window not Find")
'get hwnd of client window of Main Userform
m_hwnd = GetWindow(m_hwnd, GW_CHILD)
Debug.Print IIf(m_hwnd <> 0, "Find Window: " & Hex$(m_hwnd), "Window not Find")
'get hwnd of Frame window
m_hwnd = GetWindow(m_hwnd, GW_CHILD)
Debug.Print IIf(m_hwnd <> 0, "Find Window: " & Hex$(m_hwnd), "Window not Find")
'I use spy++ to watch all hwnd values, the 3 values of m_hwnd is correct
'set Subclass and store the Original Window Procedure
If m_OrigWndProc <> 0 Then
Debug.Print "Already subclassed" 'Do not allow to subclass a 2nd time
Else
m_OrigWndProc = SetWindowLongPtr(m_hwnd, GWLP_WNDPROC, AddressOf SubclassWndProc)
Debug.Print "Subclassing succeed."
End If
End Function
Public Function unSubclass() As Boolean
If m_OrigWndProc <> 0 Then
SetWindowLongPtr m_hwnd, GWLP_WNDPROC, m_OrigWndProc
m_OrigWndProc = 0
End If
End Function
Public Function SubclassWndProc( _
ByVal hwnd As LongPtr, _
ByVal uMsg As Long, _
ByVal wParam As LongPtr, _
ByVal lParam As LongPtr) As LongPtr
On Error Resume Next
If uMsg = WM_MOUSEWHEEL Then
'the Userform name is "frmSubclass"
frmSubclass.Caption = " wParam = " & wParam
'By observing the value of wParam, we can know
'4287102976 represents scrolling down,7864320 represents scrolling up
If wParam = 4287102976# Then
frmSubclass.Frame1.ScrollTop = frmSubclass.Frame1.ScrollTop + 15
ElseIf wParam = 7864320 Then
frmSubclass.Frame1.ScrollTop = frmSubclass.Frame1.ScrollTop - 15
End If
End If
'Pass message to the default window procedure
SubclassWndProc = CallWindowProc(m_OrigWndProc, hwnd, uMsg, wParam, lParam)
End Function
starting point bas Module code：
Option Explicit
Sub testSubclass()
frmSubclass.Show vbModeless 'the Userform name is "frmSubclass"
End Sub
The book you mentioned is called "Subclassing and Hooking". You tried "Hooking" when in fact your problem is more suited to "Subclassing" instead.
You should subclass your Userform where you want to process the "WM_MOUSEWHEEL" message. Look into "SetWindowLong" and "CallWindowProc" functions to achieve this goal.
I use 'Close_by_Caption' to close open .PDFs before they are regenerated. Previously this was easy because I could assume that always 'Foxit Reader' opened the file and that each file was opened in a separate instance of Foxit.
Newly, 'PDF-XChange Editor' should also be used to open .PDF. Now I don't know if I have to close the file with 'Close_By_Caption 'Demo - PDF-XChange Editor' or 'Demo.pdf - Foxit Reader'.
Of course I can run both commands one after the other - but surely someone will come soon who wants to use another viewer....
Is there a way to find all programs that have the word 'Demo' in 'AppCaption'? Of course, it would be even better if I would knew that either the program is a .PDF-viewer or the opened file is a .PDF...
'API Find application by full caption
Private Declare Function FindWindow _
Lib "user32" _
Alias "FindWindowA" _
( _
ByVal lpClassName As String, _
ByVal lpWindowName As String _
) _
As Long
'*****************************************
'API Bring Window to foreground
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long
'*****************************************
'API Send message to application
Private Declare Function PostMessage _
Lib "user32" _
Alias "PostMessageA" _
( _
ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any _
) _
As Long
'*****************************************
Const WM_CLOSE = &H10
'*****************************************
Function Close_By_Caption(AppCaption As String)
Dim hWnd As Long
hWnd = FindWindow(vbNullString, AppCaption)
If hWnd Then
'Bring to Front
SetForegroundWindow hWnd
'Close the app nicely
PostMessage hWnd, WM_CLOSE, 0&, 0&
End If
End Function
'*****************************************
Sub Test_Close()
Close_By_Caption "demo.pdf - Foxit Reader"
End Sub
'*****************************************```
I have search lot on the internet but I didn't find the solution. I need to get all API handles of particular window by caption/title of that window.
I have a code but it captures all handle of all open windows.
Public Sub GetWindows()
x = 0
winOutputType.winHandle = 0
winOutputType.winClass = 1
winOutputType.winTitle = 2
winOutputType.winHandleClass = 3
winOutputType.winHandleTitle = 4
winOutputType.winHandleClassTitle = 5
GetWinInfo 0&, 0, winOutputType.winHandleClassTitle
End Sub
I need code that will ask me window name and then capture handles of that particular window.
I was looking for a duplicate for Close all VBE windows (VB for Aplications) but couldn't find a link. I ended up here. For future users looking for a similar query, this should help you/them.
Option Explicit
Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
(ByVal hWnd As LongPtr, ByVal lpString As String, ByVal cch As LongPtr) As LongPtr
Public Sub GetWindows()
'~~> Pass Full Name or Partial Name. This is not case sensitive
Debug.Print GetAllWindowHandles("Microsoft Visual Basic")
End Sub
Private Function GetAllWindowHandles(partialName As String)
Dim hWnd As Long, lngRet As Long
Dim strText As String
hWnd = FindWindowEx(0&, 0&, vbNullString, vbNullString)
While hWnd <> 0
strText = String$(100, Chr$(0))
lngRet = GetWindowText(hWnd, strText, 100)
If InStr(1, strText, partialName, vbTextCompare) > 0 Then
Debug.Print "The Handle of the window is " & hWnd & " and " & vbNewLine & _
"The title of the window is " & Left$(strText, lngRet) & vbNewLine & _
"----------------------"
End If
'~~> Find next window
hWnd = FindWindowEx(0&, hWnd, vbNullString, vbNullString)
Wend
End Function
I'm trying to pull up the on-screen keyboard.
Here are my attempts so far:
' Only needed for Test3
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Sub Test1()
' Run-time error'53':
' File Not found
Dim RetVal As Variant
RetVal = Shell("C:\WINDOWS\system32\osk.exe", 1)
End Sub
Sub Test2()
' Run-time error '432':
' File name or class name not found during Automation operation
ActiveWorkbook.FollowHyperlink Address:="C:\Windows\System32\osk.exe"
End Sub
Sub Test3()
' No error. Nothing happens at all
ShellExecute 0, vbNullString, "osk.exe", vbNullString, "C:\", 1
End Sub
Test2 from this forum.
Test3 from this forum.
I checked the path to osk.exe is correct.
I have a Surface laptop/tablet, so it has a touch screen and a "touch" keyboard (different from the osk). Is that what's causing the issue or possibly it's a Windows 10 thing?
On a 64-Bit OS try this
Option Explicit
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Function Wow64EnableWow64FsRedirection Lib "kernel32.dll" (ByVal Enable As Boolean) As Boolean
Private Sub RunOsk_on64Bit()
Const SW_SHOWNORMAL = 1
On Error Resume Next
Wow64EnableWow64FsRedirection False
ShellExecute 0, "open", "osk.exe", "", "C:\windows\system32\osk.exe", SW_SHOWNORMAL
Wow64EnableWow64FsRedirection True
End Sub
Found here, this might the explanation, quote from the link
This is an issue with 64-bit OS, it affects any 64-bit version of Windows.
Basically you are calling osk.exe, but your program you are calling it
from is a 32-bit app. Windows won't allow you to call a 64-bit OSK.exe
from your program. The comments appear to miss your point here, anyone
can start osk.exe from Run, but call it from within a 32-bit
application won't work in 64-bit Windows.
I am developing software that uses the on-screen keyboard, the only
work around is Wow64DisableWow64FsRedirection.
Update: A "nicer" version might look like that
Option Explicit
Type SHELLEXECUTEINFO
cbSize As Long
fMask As Long
hwnd As Long
lpVerb As String
lpFile As String
lpParameters As String
lpDirectory As String
nShow As Long
hInstApp As Long
lpIDList As Long
lpClass As String
hkeyClass As Long
dwHotKey As Long
hIcon As Long
hProcess As Long
End Type
Public Declare Function ShellExecuteEx Lib "shell32.dll" _
(lpExecInfo As SHELLEXECUTEINFO) As Long
Declare Function Wow64DisableWow64FsRedirection Lib "kernel32.dll" (ByRef ptr As Long) As Boolean
Declare Function Wow64RevertWow64FsRedirection Lib "kernel32.dll" (ByRef ptr As Long) As Boolean
Public Function KeyboardOpen()
Dim shInfo As SHELLEXECUTEINFO
Dim lngPtr As Long
With shInfo
.cbSize = Len(shInfo)
.lpFile = "C:\Windows\Sysnative\cmd.exe" 'best to use Known folders here
.lpParameters = "/c start osk.exe"
.lpDirectory = "C:\windows\system32" 'best to use Known folders here
.lpVerb = "open"
.nShow = 0
End With
Call Wow64DisableWow64FsRedirection(lngPtr)
Call ShellExecuteEx(shInfo)
Call Wow64RevertWow64FsRedirection(lngPtr)
End Function
Based on the information in MSDN it might be more reliable to use Wow64DisableWow64FsRedirection and Wow64RevertWow64FsRedirection functions instead.
I'm using ShellExecute on VBA to force the computer to Sleep (not Hibernate), for that to be done I need to disable hibernation. I've entered rundll32.exe but I'm getting an error in the "powercfg.cpl -hibernate off".
I've also tried:
powercfg.exe /hibernate off
and
powercfg -hibernate off
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hwnd As Long, _
ByVal lpszOp As String, _
ByVal lpszFile As String, _
ByVal lpszParams As String, _
ByVal lpszDir As String, _
ByVal FsShowCmd As Long) As Long
Const SW_SHOWNORMAL As Long = 1
Sub DoSleep()
ShellExecute 0, "runas", "C:\WINDOWS\System32\rundll32.exe", "powercfg.cpl -h off", "C:\", SW_SHOWNORMAL
ShellExecute 0, "runas", "C:\WINDOWS\System32\rundll32.exe", "powrprof.dll,SetSuspendState 0,1,0", "C:\", SW_SHOWNORMAL
ShellExecute 0, "runas", "C:\WINDOWS\System32\rundll32.exe", "powercfg.cpl -hibernate on", "C:\", SW_SHOWNORMAL
End Sub
After quite a bit of trial and error I found the solution. This will put your computer in sleep mode through VBA:
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hwnd As Long, _
ByVal lpszOp As String, _
ByVal lpszFile As String, _
ByVal lpszParams As String, _
ByVal lpszDir As String, _
ByVal FsShowCmd As Long) As Long
Const SW_SHOWNORMAL As Long = 1
Sub DoSleep()
ShellExecute 0, "runas", "powercfg.exe", "/hibernate off", "C:\", SW_SHOWNORMAL
Shell "C:\WINDOWS\System32\rundll32.exe powrprof.dll,SetSuspendState 0,1,0"
ShellExecute 0, "runas", "powercfg.exe", "/hibernate on", "C:\", SW_SHOWNORMAL
End Sub