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.
Related
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.
This is my first time asking for any help on stack overflow, let alone commenting so please be gentle with me :)
I am at a loss with this one, I will give as much information as possible.
Issue
I would like to preface, this code does not cause any crashes on the latest update of 0365, only on Version 1807 & earlier. It also does not crash on the 32 bit version at all which makes me think it's a 64 bit issue. My client cannot update from this version either so simply asking them to update is not going to be able to happen.
I have narrowed the crashing down to this particular section.
Public Function GetSpecialFolder(CSIDL As Long) As String
'*******************************************************************************
'* Function: GetSpecialFolder
'* Purpose: Wraps the apis to retrieve folders such as My Docs etc.
'*******************************************************************************
Dim idlstr As Long
Dim sPath As String
Dim IDL As ITEMIDLIST
Const MAX_LENGTH = 260
'Fill the IDL structure with the specified folder item.
On Error GoTo GetSpecialFolder_Error
idlstr = SHGetSpecialFolderLocation _
(0, CSIDL, IDL)
If idlstr = 0 Then
'Get the path from the IDL list, and return the folder adding final "\".
sPath = Space$(MAX_LENGTH)
**idlstr = SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal sPath)**
If idlstr Then
GetSpecialFolder = Left$(sPath, InStr(sPath, Chr$(0)) _
- 1) & "\"
End If
End If
procExit:
On Error Resume Next
Exit Function
GetSpecialFolder_Error:
CommonErrorHandler lngErrNum:=Err.Number, strErrDesc:=Err.Description, _
strProc:="GetSpecialFolder", strModule:="modWinAPI", lngLineNum:=Erl
Resume procExit
End Function
And here is the declaration
'File system
Public Declare PtrSafe Function SHGetSpecialFolderLocation Lib "shell32.dll" _
(ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long
Public Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare PtrSafe Function GetTempPath Lib "kernel32" _
Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private 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 Type ITEMIDLIST
mkid As ShortItemId
End Type
Private Type ShortItemId
cb As Long
abID As Byte
End Type
I have tried adding LongPtr as suggested in documents I've found online but it hasn't helped.
Can anyone help me?
Thanks!
SHGetSpecialFolderLocation does not fill in the memory you allocate for ITEMIDLIST like Declared function usually do, it allocates a new piece of memory that you are later required to free with CoTaskMemFree. That makes it pointless to declare ITEMIDLIST as a structure in VBA to begin with (and your declaration is wrong anyway, cb must be Integer, and abID is a variable-length byte array, not a single byte).
If you needed to do something with individual members of a structure allocated in this way, you would have to copy them out of the returned pointer with CopyMemory. Luckily, you don't need to do any of that because SHGetSpecialFolderLocation returns a pointer to PIDLIST_ABSOLUTE, and SHGetPathFromIDList accepts PCIDLIST_ABSOLUTE:
Public Declare PtrSafe Function SHGetSpecialFolderLocation Lib "shell32.dll" _
(ByVal hwndOwner As LongPtr, ByVal nFolder As Long, ByRef pIdl As LongPtr) As Long
Public Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pIdl As LongPtr, ByVal pszPath As String) As Long
Public Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (pv As Any)
Public Function GetSpecialFolder(ByVal CSIDL As Long) As String
Dim retval As Long
Dim pIdl As LongPtr
Dim sPath As String
Const MAX_LENGTH = 260
retval = SHGetSpecialFolderLocation(0, CSIDL, pIdl)
If retval = 0 Then
sPath = Space$(MAX_LENGTH)
retval = SHGetPathFromIDList(pIdl, sPath)
If retval <> 0 Then
GetSpecialFolder = Left$(sPath, InStr(sPath, Chr$(0)) - 1) & "\"
End If
CoTaskMemFree ByVal pIdl
End If
End Function
Note that it's pointless to have an On Error Goto in such function because Windows API generally do not raise exceptions, they return error codes. It would make sense if you used Err.Raise ... after finding out a return value indicates an error.
TBH, I have no clue how this was functioning correctly on a 32 bit build. The declarations for the two structures are incorrect. This one...
Private Type ShortItemId
cb As Long
abID As Byte
End Type
...is defined in the MS documentation as this:
typedef struct _SHITEMID {
USHORT cb;
BYTE abID[1];
} SHITEMID;
Note that abID is an array, and cb is an unsigned short (you can use an Integer for that in VBA, but it definitely is not a Long).
In addition, this structure (wrapped in the ITEMIDLIST) is not even supposed to be allocated by the caller, but must be freed by the caller:
It is the responsibility of the calling application to free the returned IDList by using CoTaskMemFree.
Re the pointers, the only pointers (that aren't being marshaled from String) are the
pidl parameter of SHGetSpecialFolderLocation and the pointer to ppidl in SHGetPathFromIDList. Note that you can't use a VBA defined struct, because you need to free the memory when you're done. Something like this will work:
Private Declare PtrSafe Function SHGetSpecialFolderLocation Lib "shell32.dll" _
(ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As LongPtr) As Long
Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As LongPtr, ByVal pszPath As String) As Boolean
Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As LongPtr)
Private Const S_OK As Long = 0
Private Const MAX_LENGTH = 260
Public Function GetSpecialFolder(ByVal CSIDL As Integer) As String
Dim result As Long
Dim path As String
Dim idl_ptr As LongPtr
'Fill the IDL structure with the specified folder item.
result = SHGetSpecialFolderLocation(0, CSIDL, idl_ptr)
If result = S_OK Then
'Get the path from the IDL list, and return the folder adding final "\".
path = Space$(MAX_LENGTH)
If SHGetPathFromIDList(idl_ptr, path) Then
GetSpecialFolder = Left$(path, InStr(path, vbNullChar) - 1) & "\"
End If
CoTaskMemFree idl_ptr
End If
End Function
Note that per the discussion in the comments, you could technically declare hwndOwner as LongPtr as well, but it shouldn't make any difference.
When launching an .exe using .Run in VBA, a typical call may look like this:
x = wsh.Run(Command:="program.exe ""argument""", WindowStyle:=0, waitonreturn:=False)
Where windowStyle=0 should theoretically cause the program to run invisible to the user. But what if a pop-up window occurs within the .exe that you don't want to the user to see?
The windowStyle input will not suppress the appearance of warning messages or pop up windows declaring things like 'calculation complete' from appearing to the user, this often also pauses the code until the pop up is cleared. Clearing the window (i.e. clicking 'okay') in an automated manner is trivial (see this answer), but preventing it from appearing to the user to begin with is proving difficult to me as a relative beginner. (i.e. when the pop up is triggered by the .exe it is invisible to the user, and then closed automatically by the VBA code)
Currently I detect the existence of a new pop up window using this function (where sCaption is the name of the pop up window):
Private Function GetHandleFromPartialCaption(ByRef lWnd As Long, ByVal sCaption As String) As Boolean
Dim lhWndP As Long
Dim sStr As String
GetHandleFromPartialCaption = False
lhWndP = FindWindow(vbNullString, vbNullString) 'PARENT WINDOW
Do While lhWndP <> 0
sStr = String(GetWindowTextLength(lhWndP) + 1, Chr$(0))
GetWindowText lhWndP, sStr, Len(sStr)
sStr = Left$(sStr, Len(sStr) - 1)
If InStr(1, sStr, sCaption) > 0 Then
GetHandleFromPartialCaption = True
lWnd = lhWndP
Exit Do
End If
lhWndP = GetWindow(lhWndP, GW_HWNDNEXT)
Loop
End Function
Then close it automatically. But it still briefly flashes up on screen to the user. Ideally I'd like this VBA code to run in the background so the user can get on with other tasks whilst it runs, not being distracted by flashing boxes.
Is there a way to force all windows of program.exe, including pop ups, to be invisible whilst it is running?
For further information, see my previous question on how to close the pop up window, here. This thread concerns how to prevent its appearance to a user.
EDIT 1
SendKeys is temperamental, so I am using this looping code to kill the .exe when I detect the pop up window, therefore the .exe does not need to be in focus to close the pop up (closing the pop up kills the .exe in my case anyway):
....
Main Code Body
....
t = Now
waittime = Now + TimeValue("0:01:30") 'limit to run a single row of calculations
Do While t < waittime
If GetHandleFromPartialCaption(lhWndP, "Popup Window Text") = True Then
Set oServ = GetObject("winmgmts:")
Set cProc = oServ.ExecQuery("Select * from Win32_Process")
For Each oProc In cProc
If oProc.Name = "Program.exe" Then
errReturnCode = oProc.Terminate()
Marker2 = 1
Exit Do
End If
Next
Endif
Loop
....
Main Code Body Continues
....
where GetHandleFromPartialCaption() is the function above, finding the pop up window based on the sCaption argument. My code loops and searches constantly for the pop up whilst the .exe is running the calculation, and kills the .exe as soon as it appears. But it still flashes up to the user.
To run an application completely hidden, launch it in a different desktop with CreateProcess.
Here's an example executing a simple command line and waiting for the process to exit :
Option Explicit
Private Declare PtrSafe Function OpenDesktop Lib "user32.dll" Alias "OpenDesktopW" (ByVal lpszDesktop As LongPtr, ByVal dwFlags As Long, ByVal fInherit As Byte, ByVal dwDesiredAccess As Long) As LongPtr
Private Declare PtrSafe Function CreateDesktop Lib "user32.dll" Alias "CreateDesktopW" (ByVal lpszDesktop As LongPtr, ByVal lpszDevice As LongPtr, ByVal pDevmode As LongPtr, ByVal dwFlags As Long, ByVal dwDesiredAccess As Long, ByVal lpsa As LongPtr) As LongPtr
Private Declare PtrSafe Function CloseDesktop Lib "user32.dll" (ByVal hDesktop As LongPtr) As Long
Private Declare PtrSafe Function CreateProcess Lib "kernel32.dll" Alias "CreateProcessW" (ByVal lpApplicationName As LongPtr, ByVal lpCommandLine As LongPtr, ByVal lpProcessAttributes As LongPtr, ByVal lpThreadAttributes As LongPtr, ByVal bInheritHandles As Byte, ByVal dwCreationFlags As Long, ByVal lpEnvironment As LongPtr, ByVal lpCurrentDirectory As LongPtr, ByRef lpStartupInfo As STARTUPINFO, ByRef lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare PtrSafe Function WaitForSingleObject Lib "kernel32.dll" (ByVal hHandle As LongPtr, ByVal dwMilliseconds As Long) As Long
Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32.dll" (ByVal hProcess As LongPtr, ByRef lpExitCode As Long) As Long
Private Declare PtrSafe Function CloseHandle Lib "kernel32.dll" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function GetWindowText Lib "user32.dll" Alias "GetWindowTextW" (ByVal hwnd As LongPtr, ByVal lpString As LongPtr, ByVal nMaxCount As Long) As Long
Private Declare PtrSafe Function EnumDesktopWindows Lib "user32.dll" (ByVal hDesktop As LongPtr, ByVal lpfn As LongPtr, ByRef lParam As Any) As Long
Private Declare PtrSafe Function SendMessageW Lib "user32.dll" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Private Declare PtrSafe Function GetLastError Lib "kernel32.dll" () As Long
Private Type STARTUPINFO
cb As Long
lpReserved As LongPtr
lpDesktop As LongPtr
lpTitle As LongPtr
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As LongPtr
hStdInput As LongPtr
hStdOutput As LongPtr
hStdError As LongPtr
End Type
Private Type PROCESS_INFORMATION
hProcess As LongPtr
hThread As LongPtr
dwProcessID As Long
dwThreadID As Long
End Type
Public Sub UsageExample()
Dim exitCode As Long
exitCode = ExecuteHidden("cmd /C echo abcd > %USERPROFILE%\Desktop\output.txt", timeoutMs:=10000)
End Sub
Public Function ExecuteHidden(command As String, timeoutMs As Long) As Long
Dim si As STARTUPINFO, pi As PROCESS_INFORMATION, hDesktop As LongPtr, ex As Long
Const NORMAL_PRIORITY_CLASS& = &H20&, INFINITE& = &HFFFFFFFF, GENERIC_ALL& = &H10000000
On Error GoTo Catch
' get a virtual desktop '
si.lpDesktop = StrPtr("hidden-desktop")
hDesktop = OpenDesktop(si.lpDesktop, 0, 0, GENERIC_ALL)
If hDesktop Then Else hDesktop = CreateDesktop(si.lpDesktop, 0, 0, 0, GENERIC_ALL, 0)
If hDesktop Then Else Err.Raise GetLastError()
' run the command '
si.cb = LenB(si)
If CreateProcess(0, StrPtr(command), 0, 0, 1, NORMAL_PRIORITY_CLASS, 0, 0, si, pi) Then Else Err.Raise GetLastError()
' wait for exit '
If WaitForSingleObject(pi.hProcess, timeoutMs) Then Err.Raise 1000, , "Timeout while waiting for the process to exit"
If GetExitCodeProcess(pi.hProcess, ExecuteHidden) <> 0 Then Else Err.Raise GetLastError()
' cleanup '
Catch:
If pi.hThread Then CloseHandle pi.hThread
If pi.hProcess Then CloseHandle pi.hProcess
If hDesktop Then CloseDesktop hDesktop
If Err.Number Then Err.Raise Err.Number
End Function
And if you need to find a window in the desktop, use EnumDesktopWindows instead of EnumWindows:
Private Function FindWindow(ByVal hDesktop As LongPtr, title As String) As LongPtr
Dim hwnds As New Collection, hwnd, buffer$
buffer = Space$(1024)
EnumDesktopWindows hDesktop, AddressOf EnumDesktopWindowsProc, hwnds
For Each hwnd In hwnds
If Left$(buffer, GetWindowText(hwnd, StrPtr(buffer), Len(buffer))) Like title Then
FindWindow = hwnd
Exit Function
End If
Next
End Function
Private Function EnumDesktopWindowsProc(ByVal hwnd As LongPtr, hwnds As Collection) As Long
hwnds.Add hwnd
EnumDesktopWindowsProc = True
End Function
If you need to close a window, simply send WM_CLOSE to the main window or to a popup:
const WM_CLOSE& = &H10&
SendMessageW hwnd, WM_CLOSE, 0, 0
The short answer is to hide popups it is required to call ShowOwnedPopups(hwnd,0). The VBA declaration is given here
Declare Function ShowOwnedPopups Lib "user32" Alias "ShowOwnedPopups" _
(ByVal hwnd As Long, ByVal fShow As Long) As Long
For a longer answer with some experimental C# code investigating this see this blog post. I have copied first part of blog post into answer here for brevity.
Firstly, a key reading resource is Windows Features which tells that all windows are created with CreateWindowEx but popups are create by specifying WS_POPUP and child windows are created by specifying WS_CHILD. So popups and child windows are different.
On the same page in the section Window Visibility it explains that we can set the visibility of a main window and the change will cascade down to all child windows but there is no mention of this cascade affecting popups.
And here is some final VBA code but which depends upon a simple C# demo program called VisibilityExperiment
Option Explicit
Private Declare Function ShowOwnedPopups Lib _
"user32" (ByVal hwnd As Long, _
ByVal fShow As Long) As Long
Private Declare Function EnumWindows _
Lib "user32" ( _
ByVal lpEnumFunc As Long, _
ByVal lParam As Long) _
As Long
Private Declare Function GetWindowThreadProcessId _
Lib "user32" (ByVal hwnd As Long, lpdwprocessid As Long) As Long
Private mlPid As Long
Private mlHWnd As Variant
Private Function EnumAllWindows(ByVal hwnd As Long, ByVal lParam As Long) As Long
Dim plProcID As Long
GetWindowThreadProcessId hwnd, plProcID
If plProcID = mlPid Then
If IsEmpty(mlHWnd) Then
mlHWnd = hwnd
Debug.Print "HWnd:&" & Hex$(mlHWnd) & " PID:&" & Hex$(mlPid) & "(" & mlPid & ")"
End If
End If
EnumAllWindows = True
End Function
Private Function GetPID(ByVal sExe As String) As Long
Static oServ As Object
If oServ Is Nothing Then Set oServ = GetObject("winmgmts:\\.\root\cimv2")
Dim cProc As Object
Set cProc = oServ.ExecQuery("Select * from Win32_Process")
Dim oProc As Object
For Each oProc In cProc
If oProc.Name = sExe Then
Dim lPid As Long
GetPID = oProc.ProcessID
End If
Next
End Function
Private Sub Test()
Dim wsh As IWshRuntimeLibrary.WshShell
Set wsh = New IWshRuntimeLibrary.WshShell
Dim lWinStyle As WshWindowStyle
lWinStyle = WshNormalFocus
Dim sExe As String
sExe = "VisibilityExperiment.exe"
Dim sExeFullPath As String
sExeFullPath = Environ$("USERPROFILE") & "\source\repos\VisibilityExperiment\VisibilityExperiment\bin\Debug\" & sExe
Dim x As Long
x = wsh.Run(sExeFullPath, lWinStyle, False)
mlPid = GetPID(sExe)
mlHWnd = Empty
Call EnumWindows(AddressOf EnumAllWindows, 0)
Stop
Call ShowOwnedPopups(mlHWnd, 0) '* o to hide, 1 to show
End Sub
To repeat, to hide popups one must call ShowOwnedPopups(). Sadly, I cannot see around this restriction. Even if we tried to use the Windows API directly to spawn the process there is nothing in the STARTUPINFO structure (Windows) which looks like it will help, there is nothing to specify the visibility of popups.
How about:
Dim TaskID as Double
TaskID = Shell("program.exe", vbHide)
or if the window is not behaving as desired, try vbNormalNoFocus or vbMinimizedNoFocus.
If this isn't suitable for some reason, please share some more about what the .exe ... Perhaps redirected output could be an option.
More from MSDN.
Some interesting notes here (albeit for C#)
Redirecting standard Shell output
I assume you are unable to modify "program.exe" to use a different type of notification?
An alternative approach is to force Excel to stay "on top":
3 Best Ways to Force a Window to Stay on Top
A utility called "Always On Top"
How to keep Excel Window Always on Top, such as:
#If Win64 Then
Public Declare PtrSafe Function SetWindowPos _
Lib "user32" ( _
ByVal hwnd As LongPtr, _
ByVal hwndInsertAfter As LongPtr, _
ByVal x As Long, ByVal y As Long, _
ByVal cx As Long, ByVal cy As Long, _
ByVal wFlags As Long) _
As Long
#Else
Public Declare Function SetWindowPos _
Lib "user32" ( _
ByVal hwnd As Long, _
ByVal hwndInsertAfter As Long, _
ByVal x As Long, ByVal y As Long, _
ByVal cx As Long, ByVal cy As Long, _
ByVal wFlags As Long) _
As Long
#End If
Public Const SWP_NOSIZE = &H1
Public Const SWP_NOMOVE = &H2
Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2
Sub ShowXLOnTop(ByVal OnTop As Boolean)
Dim xStype As Long
#If Win64 Then
Dim xHwnd As LongPtr
#Else
Dim xHwnd As Long
#End If
If OnTop Then
xStype = HWND_TOPMOST
Else
xStype = HWND_NOTOPMOST
End If
Call SetWindowPos(Application.hwnd, xStype, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE)
End Sub
Sub SetXLOnTop()
ShowXLOnTop True
End Sub
Sub SetXLNormal()
ShowXLOnTop False
End Sub
I'm trying to refresh desktop, tried this,
Private Declare Function SHChangeNotify Lib "Shell32.dll" (ByVal wEventID As Long,
ByVal uFlags As Long, ByVal dwItem1 As Long, ByVal dwItem2 As Long) As Long
call SHChangeNotify(&H8000000&, &H0, vbNullString, vbNullString)
But it gives me error
What is the correct way to refresh desktop ?
You need to call SHCangeNotify(&H8000000, &H0, Nothing, Nothing) from within a method for example:
Public Class example
Private Declare Function SHChangeNotify Lib "Shell32.dll" (ByVal wEventID As Long, _
ByVal uFlags As Long, _
ByVal dwitem1 As Long, _
ByVal deitem2 As Long) As Long
Private Sub refreshWindow()
SHCangeNotify(SHChangeNotify(&H8000000, &H0, Nothing, Nothing)
End Sub
End Class
I am implementing an application in C#.net that is passing a message to an VB6 application.
For testing I created 2 applications both in C#.NET:- One sends message and 2nd receives the message.
The receiving application (C#.NET) makes use of the following function to catch the message:-
Protected Override void WndProc(ref Message m)
I now need to implement this receiver app in VB6.. How do we implement Protected Override void WndProc(ref Message m) in VB6? Or is there any other alternative?
Overriding the default windows procedure is possible in VB6 and is called Subclassing.
In a module:
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const GWL_WNDPROC As Long = (-4)
Private originalWindowProcAddr As Long
Public Sub subclassForm(hwnd As Long)
'// replace existing windows procedure save its address
originalWindowProcAddr = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf NewWindowProc)
End Sub
Public Function NewWindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Debug.Print "received message for:", hwnd, "message:", uMsg
'// forward message to default
NewWindowProc = CallWindowProc(originalWindowProcAddr, hwnd, uMsg, wParam, lParam)
End Function
Public Sub unSubclassForm(hwnd As Long)
'// must tidy up by restoring the original window proc
SetWindowLong hwnd, GWL_WNDPROC, originalWindowProcAddr
End Sub
In the form
Private Sub Form_Load()
subclassForm Me.hwnd
End Sub
Private Sub form_Unload(Cancel As Integer)
unSubclassForm Me.hwnd
End Sub
Failing to call unSubclassForm will crash the VB IDE, as will breaking into debug mode.
I have followed this method:-
http://support.microsoft.com/kb/176058/en-us
Alternate link: https://web.archive.org/web/20150118054920/http://support.microsoft.com:80/kb/176058
How To Pass String Data Between Applications Using SendMessage
SUMMARY
There are many ways to achieve inter-process communication using Visual Basic. Unless you establish an OLE Automation client server relationship, string data is difficult to handle cleanly. The main reason is that 32-bit applications run in a separate address space, so the address of a string in one application is not meaningful to another application in a different address space. Using the SendMessage() API function to pass a WM_COPYDATA message avoids this problem.
This article demonstrates how to pass string data from one application to another by using the SendMessage API function with the WM_COPYDATA message.
WARNING: One or more of the following functions are discussed in this article; VarPtr, VarPtrArray, VarPtrStringArray, StrPtr, ObjPtr. These functions are not supported by Microsoft Technical Support. They are not documented in the Visual Basic documentation and are provided in this Knowledge Base article "as is." Microsoft does not guarantee that they will be available in future releases of Visual Basic.
Visual Basic does not support pointers and castings in the manner of Visual C++. In order to pass string data from one Visual Basic application to another, the Unicode string must be converted to ASCII prior to passing it to the other application. The other application must then convert the ASCII string back to Unicode.
The following summarizes how to pass string data from one application to another.
Step-by-Step Example
Convert the string to a byte array using the CopyMemory() API.
Obtain the address of the byte array using the VarPtr() intrinsic function and copy the address and length of the byte array into a COPYDATASTRUCT structure.
Pass the COPYDATASTRUCT to another application using the WM_COPYDATA message, setting up the other application to receive the message.
Unpack the structure on the target system using CopyMemory(), and convert the byte array back to a string using the StrConv() intrinsic function.
The next section shows you how to create a sample program that demonstrates passing string data from one application to another.
Steps to Create the Sample
To create this sample, you create two separate projects; a sending project and a target project.
Create the target application:
Start a new Standard EXE project in Visual Basic. Form1 is created by default. This project will be your target application.
Add a Label control to Form1.
Copy the following code to the Code window of Form1:
Private Sub Form_Load()
gHW = Me.hWnd
Hook
Me.Caption = "Target"
Me.Show
Label1.Caption = Hex$(gHW)
End Sub
Private Sub Form_Unload(Cancel As Integer)
Unhook
End Sub
Add a module to the project and paste the following code in the Module1 code window:
Type COPYDATASTRUCT
dwData As Long
cbData As Long
lpData As Long
End Type
Public Const GWL_WNDPROC = (-4)
Public Const WM_COPYDATA = &H4A
Global lpPrevWndProc As Long
Global gHW As Long
'Copies a block of memory from one location to another.
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Declare Function CallWindowProc Lib "user32" Alias _
"CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As _
Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As _
Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As _
Long) As Long
Public Sub Hook()
lpPrevWndProc = SetWindowLong(gHW, GWL_WNDPROC, _
AddressOf WindowProc)
Debug.Print lpPrevWndProc
End Sub
Public Sub Unhook()
Dim temp As Long
temp = SetWindowLong(gHW, GWL_WNDPROC, lpPrevWndProc)
End Sub
Function WindowProc(ByVal hw As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
If uMsg = WM_COPYDATA Then
Call mySub(lParam)
End If
WindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, _
lParam)
End Function
Sub mySub(lParam As Long)
Dim cds As COPYDATASTRUCT
Dim buf(1 To 255) As Byte
Call CopyMemory(cds, ByVal lParam, Len(cds))
Select Case cds.dwData
Case 1
Debug.Print "got a 1"
Case 2
Debug.Print "got a 2"
Case 3
Call CopyMemory(buf(1), ByVal cds.lpData, cds.cbData)
a$ = StrConv(buf, vbUnicode)
a$ = Left$(a$, InStr(1, a$, Chr$(0)) - 1)
Form1.Print a$
End Select
End Sub
Save the project and minimize the Visual Basic IDE.
Create the Sending Application
Start a second instance of the Visual Basic IDE and create a new Standard EXE project in Visual Basic. Form1 is created by default.
Add a CommandButton to Form1.
Copy the following code to the Code window of Form1:
Private Type COPYDATASTRUCT
dwData As Long
cbData As Long
lpData As Long
End Type
Private Const WM_COPYDATA = &H4A
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
'Copies a block of memory from one location to another.
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Sub Command1_Click()
Dim cds As COPYDATASTRUCT
Dim ThWnd As Long
Dim buf(1 To 255) As Byte
' Get the hWnd of the target application
ThWnd = FindWindow(vbNullString, "Target")
a$ = "It Works!"
' Copy the string into a byte array, converting it to ASCII
Call CopyMemory(buf(1), ByVal a$, Len(a$))
cds.dwData = 3
cds.cbData = Len(a$) + 1
cds.lpData = VarPtr(buf(1))
i = SendMessage(ThWnd, WM_COPYDATA, Me.hwnd, cds)
End Sub
Private Sub Form_Load()
' This gives you visibility that the target app is running
' and you are pointing to the correct hWnd
Me.Caption = Hex$(FindWindow(vbNullString, "Target"))
End Sub
Save the project.
Running the Sample
Restore the target application and press the F5 key to run the project. Note that the value of the hWnd displayed in the label.
Restore the sending application and press the F5 key to run the project. Verify that the hWnd in the form caption matches the hWnd in the label on the target application. Click the CommandButton and the text message should be displayed on the form of the target application.