Related
I am currently modifying a really old system running Windows Server 2k. One of the requirements I am working on is to block off keyboard presses at a certain window of another program which we can't modify.
Generally my process was fine as I detect keypresses and then terminate the window if they occur, However the only working code that I have found and worked with causes many issues when sometimes Control/Windows Key/etc gets stuck and the entire system tends to act out weird. This is the Code I am using for the Hook:
Public Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Public Declare Function SetWindowsHook Lib "user32" Alias "SetWindowsHookA" (ByVal nFilterType As Long, ByVal pfnFilterProc As Long) As Long
Public 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 Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Global Const WH_KEYBOARD_LL = 13
Public hook As Long
Public Const HC_ACTION = 0
Type HookStruct
vkCode As Long
scancode As Long
FLAGS As Long
time As Long
dwExtraInfo As Long
End Type
Public active As Boolean
Public value As String
Public Function myfunc(ByVal code As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim kybd As HookStruct
myfunc = True
If code = HC_ACTION And wParam <> 257 Then
If active Then
'SendKeys "{ESC}"
'MsgBox ("keypressed")
End If
myfunc = CallNextHookEx(hook, code, wParam, lParam)
ElseIf code < 0 Then
myfunc = CallNextHookEx(hook, code, wParam, lParam)
End If
End Function
Generally the code IS working, However if you press Control, Alt or Windows key then the entire system tends to go haywire.
Is there a better method to detect those key presses outside the system/in a specific window even possibly, Or am I doing something wrong here?
See the following thread: Detect keypress outside your application
You can try these two other approaches to see if they are more stable:
RegisterHotKey, a function that defines a system-wide hot key:
Declare Function RegisterHotKey Lib "user32" Alias "RegisterHotKey" (ByVal hwnd As Long, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
or GetAsyncKeyState, a function that determines whether a key is up or down at the time the function is called, and whether the key was pressed after a previous call to GetAsyncKeyState:
Declare Function GetAsyncKeyState Lib "user32" Alias "GetAsyncKeyState" (ByVal vKey As Long) As Integer
You could run a timer and continuously check GetAsyncKeyState to see if the key(s) you are looking for have been pressed:
Private Sub tmrKeyPressCheck_Timer()
Dim iCounter As Integer
For iCounter = 64 To 90
If CheckKey(iCounter) Then
txtKeyPressLog.Text = Hour(Now) & ":" & Minute(Now) & ":" & Second(Now) & ": " & Chr(iCounter) & vbCrLf & txtKeyPressLog.Text
End If
Next
End Sub
Private Function CheckKey(ByVal p_lngKey As Long) As Boolean
Dim iReturn As Integer
iReturn = GetAsyncKeyState(p_lngKey)
CheckKey = (iReturn <> 0)
End Function
This is the code that ended up working without the issues:
Private Const WH_KEYBOARD_LL = 13&
Private Const HC_ACTION = 0&
Private Const LLKHF_EXTENDED = &H1&
Private Const LLKHF_INJECTED = &H10&
Private Const LLKHF_ALTDOWN = &H20&
Private Const LLKHF_UP = &H80&
Private Const VK_RIGHT = &H27
Private Const VK_LEFT = &H25
Private Const VK_RSHIFT = &HA1
Private Type KBDLLHOOKSTRUCT
vkCode As Long
scanCode As Long
FLAGS As Long
time As Long
dwExtraInfo As Long
End Type
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
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, ByVal lParam 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 value As String
Public active As Boolean
Public Function HookKeyboard() As Long
On Error GoTo ErrorHookKeyboard
m_hDllKbdHook = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf LowLevelKeyboardProc, App.hInstance, 0&)
HookKeyboard = m_hDllKbdHook
Exit Function
ErrorHookKeyboard:
MsgBox Err & ":Error in call to HookKeyboard()." _
& vbCrLf & vbCrLf & "Error Description: " & Err.Description, vbCritical, "Warning"
Exit Function
End Function
Public Sub UnHookKeyboard()
On Error GoTo ErrorUnHookKeyboard
UnhookWindowsHookEx (m_hDllKbdHook)
Exit Sub
ErrorUnHookKeyboard:
MsgBox Err & ":Error in call to UnHookKeyboard()." _
& vbCrLf & vbCrLf & "Error Description: " & Err.Description, vbCritical, "Warning"
Exit Sub
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 active Then
MsgBox ("keypressed")
End If
End If
I just need to call HookKeyboard/UnhookKeyboard in the main form
I used to be able to run command lines running external programs (like exiftool or image magick) with the function below in my access 2007 db.
I migrated to access 2013 and after a few code adaptations, the DB works, except this function ExecCmd. When I use it I get no error but nothing happens.
Can anyone help ? Either by showing me whats wrong or suggesting a better way to do the same.
Public Const SEE_MASK_DOENVSUBST As Long = &H200
Public Const SEE_MASK_IDLIST As Long = &H4
Public Const SEE_MASK_NOCLOSEPROCESS As Long = &H40
Public Const SW_HIDE As Long = 0
Public Const SW_SHOW As Long = 5
Public Const WAIT_TIMEOUT As Long = 258&
Public Type SHELLEXECUTEINFOA
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 PtrSafe Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Public Declare PtrSafe Function GetExitCodeProcess Lib "kernel32.dll" (ByVal hProcess As Long, ByRef lpExitCode As Long) As Long
Public Declare PtrSafe Function ShellExecuteEx Lib "shell32.dll" (ByRef lpExecInfo As SHELLEXECUTEINFOA) As Long
Public Declare PtrSafe Function WaitForSingleObject Lib "kernel32.dll" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Public Function ExecCmd(ByVal vsCmdLine As String, Optional ByRef vsParameters As String, Optional ByRef vsCurrentDirectory As String = vbNullString, Optional ByVal vnShowCmd As Long = SW_SHOW, Optional ByVal vnTimeOut As Long = 200) As Long
Dim lpShellExInfo As SHELLEXECUTEINFOA
With lpShellExInfo
.cbSize = Len(lpShellExInfo)
.lpDirectory = vsCurrentDirectory
.lpVerb = "open"
.lpFile = vsCmdLine
.lpParameters = vsParameters
.nShow = vnShowCmd
.fMask = SEE_MASK_DOENVSUBST Or SEE_MASK_NOCLOSEPROCESS Or SEE_MASK_IDLIST
End With
If ShellExecuteEx(lpShellExInfo) Then
Do While WaitForSingleObject(lpShellExInfo.hProcess, vnTimeOut) = WAIT_TIMEOUT
DoEvents
Loop
GetExitCodeProcess lpShellExInfo.hProcess, ExecCmd
CloseHandle lpShellExInfo.hProcess
Else
ExecCmd = vbError
End If
End Function
I found another similar function, but the first one was better, if only because It had the ability to run the command hidden.
This works:
Option Explicit
Private Type STARTUPINFO
cb As Long
lpReserved As String
lpDesktop As String
lpTitle As String
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 Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessID As Long
dwThreadID As Long
End Type
Private Declare PtrSafe Function WaitForSingleObject Lib "kernel32" (ByVal _
hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare PtrSafe Function CreateProcessA Lib "kernel32" (ByVal _
lpApplicationName As Long, ByVal lpCommandLine As String, ByVal _
lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _
ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, _
lpStartupInfo As STARTUPINFO, lpProcessInformation As _
PROCESS_INFORMATION) As Long
Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal _
hObject As Long) As Long
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const INFINITE = -1&
Public Sub ExecCmd(cmdline As String)
Dim proc As PROCESS_INFORMATION
Dim start As STARTUPINFO
Dim ReturnValue As Integer
' Initialize the STARTUPINFO structure:
start.cb = Len(start)
' Start the shelled application:
ReturnValue = CreateProcessA(0&, cmdline$, 0&, 0&, 1&, _
NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc)
' Wait for the shelled application to finish:
Do
ReturnValue = WaitForSingleObject(proc.hProcess, 0)
DoEvents
Loop Until ReturnValue <> 258
ReturnValue = CloseHandle(proc.hProcess)
End Sub
I was able to recreate your issue using a simple test case. The VBA procedure...
Sub test()
Dim r As Variant
r = ExecCmd("cscript.exe", "C:\Users\Public\Documents\foo.vbs", "", 0)
End Sub
...worked fine under 32-bit Access 2013 but failed silently under 64-bit Access 2013. However, the following code does seem to work under 64-bit Access 2013:
Sub test2()
Dim sh As Object ' WshShell
Set sh = CreateObject("WScript.Shell")
sh.Run "cscript.exe C:\Users\Public\Documents\foo.vbs", 0
Set sh = Nothing
End Sub
For more information, see
Run Method (Windows Script Host)
Problem solved: API calls in 64bit are different.
Code below works: appli is launched and the code waits for it to finish before going further.
Best of all: a parameter controls the visibility of the app window: very useful to run a background batch of command line processes without poisoning the display or the focus.
Thanks for the help !
Private Const STARTF_USESHOWWINDOW& = &H1
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const INFINITE = -1&
Private Type STARTUPINFO
cb As Long
lpReserved As String
lpDesktop As String
lpTitle As String
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 Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessID As Long
dwThreadID As Long
End Type
Private Declare PtrSafe Function WaitForSingleObject Lib "kernel32" (ByVal _
hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare PtrSafe Function CreateProcessA Lib "kernel32" (ByVal _
lpApplicationName As Long, ByVal lpCommandLine As String, ByVal _
lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _
ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, _
lpStartupInfo As STARTUPINFO, lpProcessInformation As _
PROCESS_INFORMATION) As Long
Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal _
hObject As Long) As Long
Public Sub ShellWait(Pathname As String, Optional WindowStyle As Long)
Dim proc As PROCESS_INFORMATION
Dim start As STARTUPINFO
Dim ret As Long
' Initialize the STARTUPINFO structure:
With start
.cb = Len(start)
If Not IsMissing(WindowStyle) Then
.dwFlags = STARTF_USESHOWWINDOW
.wShowWindow = WindowStyle
End If
End With
' Start the shelled application:
ret& = CreateProcessA(0&, Pathname, 0&, 0&, 1&, _
NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc)
' Wait for the shelled application to finish:
ret& = WaitForSingleObject(proc.hProcess, INFINITE)
ret& = CloseHandle(proc.hProcess)
End Sub
I need to have my form-based application check stdin periodically for input, but still perform other processing. Scripting.TextStream.Read() and the ReadFile() API are blocking, is there a non-blocking method of reading stdin in VB6?
With Timer1 set to fire every 100 ms, I've tried:
Private Declare Function AllocConsole Lib "kernel32" () As Long
Private Declare Function FreeConsole Lib "kernel32" () As Long
Dim sin As Scripting.TextStream
Private Sub Form_Load()
AllocConsole
Dim FSO As New Scripting.FileSystemObject
Set sin = FSO.GetStandardStream(StdIn)
Timer1.Enabled = True
End Sub
Private Sub Timer1_Timer()
Dim cmd As String
While Not sin.AtEndOfStream
cmd = sin.Read(1)
Select Case cmd
' Case statements to process each byte read...
End Select
Wend
End Sub
I've also tried:
Private Declare Function AllocConsole Lib "kernel32" () As Long
Private Declare Function FreeConsole Lib "kernel32" () As Long
Private Declare Function GetStdHandle Lib "kernel32" (ByVal nStdHandle As Long) As Long
Private Declare Function ReadFileA Lib "kernel32" Alias "ReadFile" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Any) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Const STD_INPUT_HANDLE = -10&
Dim hStdIn As Long
Private Sub Form_Load()
AllocConsole
hStdIn = GetStdHandle(STD_INPUT_HANDLE)
Timer1.Enabled = True
End Sub
Private Sub Timer1_Timer()
Dim bytesRead as Long
Dim cmd As String
cmd = Space$(16)
cmd = ReadFile(hStdIn, ByVal cmd, Len(cmd), bytesRead, ByVal 0&)
' Statements to process each Line read...
End Sub
I've tried the ReadConsole() API, too, they all block.
Use vbAdvance add-in to compile following sample with "Build As Console Application" option checked.
Option Explicit
'--- for GetStdHandle
Private Const STD_INPUT_HANDLE As Long = -10&
Private Const STD_OUTPUT_HANDLE As Long = -11&
'--- for PeekConsoleInput
Private Const KEY_EVENT As Long = 1
'--- for GetFileType
Private Const FILE_TYPE_PIPE As Long = &H3
Private Const FILE_TYPE_DISK As Long = &H1
Private Declare Function GetStdHandle Lib "kernel32" (ByVal nStdHandle As Long) As Long
Private Declare Function GetConsoleMode Lib "kernel32" (ByVal hConsoleHandle As Long, lpMode As Long) As Long
Private Declare Function SetConsoleMode Lib "kernel32" (ByVal hConsoleHandle As Long, ByVal dwMode As Long) As Long
Private Declare Function PeekNamedPipe Lib "kernel32" (ByVal hNamedPipe As Long, lpBuffer As Any, ByVal nBufferSize As Long, ByVal lpBytesRead As Long, lpTotalBytesAvail As Long, ByVal lpBytesLeftThisMessage As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal lpOverlapped As Long) As Long
Private Declare Function OemToCharBuff Lib "user32" Alias "OemToCharBuffA" (ByVal lpszSrc As String, ByVal lpszDst As String, ByVal cchDstLength As Long) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As Any) As Long
Private Declare Function CharToOemBuff Lib "user32" Alias "CharToOemBuffA" (ByVal lpszSrc As String, lpszDst As Any, ByVal cchDstLength As Long) As Long
Private Declare Function PeekConsoleInput Lib "kernel32" Alias "PeekConsoleInputA" (ByVal hConsoleInput As Long, lpBuffer As Any, ByVal nLength As Long, lpNumberOfEventsRead As Long) As Long
Private Declare Function ReadConsoleInput Lib "kernel32" Alias "ReadConsoleInputA" (ByVal hConsoleInput As Long, lpBuffer As Any, ByVal nLength As Long, lpNumberOfEventsRead As Long) As Long
Private Declare Function GetFileType Lib "kernel32" (ByVal hFile As Long) As Long
Sub Main()
Dim hStdIn As Long
Dim sBuffer As String
Dim dblTimer As Double
hStdIn = GetStdHandle(STD_INPUT_HANDLE)
Do
sBuffer = sBuffer & ConsoleReadAvailable(hStdIn)
If dblTimer + 1 < Timer Then
dblTimer = Timer
Call OemToCharBuff(sBuffer, sBuffer, Len(sBuffer))
ConsolePrint "%1: %2" & vbCrLf, Format$(Timer, "0.00"), sBuffer
sBuffer = vbNullString
End If
Loop
End Sub
Private Function ConsoleReadAvailable(ByVal hStdIn As Long) As String
Dim lType As Long
Dim sBuffer As String
Dim lChars As Long
Dim lMode As Long
Dim lAvailChars As Long
Dim baBuffer(0 To 512) As Byte
Dim lEvents As Long
lType = GetFileType(hStdIn)
If lType = FILE_TYPE_PIPE Then
If PeekNamedPipe(hStdIn, ByVal 0, 0, 0, lAvailChars, 0) = 0 Then
Exit Function
End If
End If
If lType = FILE_TYPE_DISK Or lAvailChars > 0 Then
sBuffer = Space(IIf(lAvailChars > 0, lAvailChars, 512))
Call ReadFile(hStdIn, ByVal sBuffer, Len(sBuffer), lChars, 0)
ConsoleReadAvailable = Left$(sBuffer, lChars)
End If
If GetConsoleMode(hStdIn, lMode) <> 0 Then
Call SetConsoleMode(hStdIn, 0)
Do While PeekConsoleInput(hStdIn, baBuffer(0), 1, lEvents) <> 0
If lEvents = 0 Then
Exit Do
End If
If baBuffer(0) = KEY_EVENT And baBuffer(4) <> 0 Then ' baBuffer(4) = INPUT_RECORD.bKeyDown
sBuffer = Space(1)
Call ReadFile(hStdIn, ByVal sBuffer, Len(sBuffer), lChars, 0)
ConsoleReadAvailable = ConsoleReadAvailable & Left$(sBuffer, lChars)
Else
Call ReadConsoleInput(hStdIn, baBuffer(0), 1, lEvents)
End If
Loop
Call SetConsoleMode(hStdIn, lMode)
End If
End Function
Public Function ConsolePrint(ByVal sText As String, ParamArray A() As Variant) As String
' Const FUNC_NAME As String = "ConsolePrint"
Dim lI As Long
Dim sArg As String
Dim baBuffer() As Byte
Dim dwDummy As Long
'--- format
For lI = UBound(A) To LBound(A) Step -1
sArg = Replace(A(lI), "%", ChrW$(&H101))
sText = Replace(sText, "%" & (lI - LBound(A) + 1), sArg)
Next
ConsolePrint = Replace(sText, ChrW$(&H101), "%")
'--- output
ReDim baBuffer(1 To Len(ConsolePrint)) As Byte
If CharToOemBuff(ConsolePrint, baBuffer(1), UBound(baBuffer)) Then
Call WriteFile(GetStdHandle(STD_OUTPUT_HANDLE), baBuffer(1), UBound(baBuffer), dwDummy, ByVal 0&)
End If
End Function
I am afraid that I haven't managed to get this to work as of yet, however someone else might be able to have a go. The ideas was to use asynchronous I/O with the console std input (I assume the idea of your app is to allow people to write directly into the console window, and read the input as it comes).
I separated off all the API stuff into a module (MAsynchConsole):
Option Explicit
Private Const GENERIC_READ As Long = &H80000000
Private Const GENERIC_WRITE As Long = &H40000000
Private Const OPEN_EXISTING As Long = 3&
Private Const FILE_FLAG_OVERLAPPED As Long = &H40000000
Private Const FILE_SHARE_READ As Long = &H1
Private Const FILE_FLAG_NO_BUFFERING As Long = &H20000000
Private Type OVERLAPPED
Internal As Long
InternalHigh As Long
OffsetOrPointer As Long
OffsetHigh As Long
hEvent As Long
End Type
Private Type OVERLAPPED_ENTRY
lpCompletionKey As Long
lpOverlapped As Long ' pointer to OVERLAPPED
Internal As Long
dwNumberOfBytesTransferred As Long
End Type
Private Declare Function AllocConsole Lib "kernel32" () As Long
Private Declare Function CancelIo Lib "Kernel32.dll" ( _
ByVal hFile As Long _
) As Long
Private Declare Function CreateFile Lib "Kernel32.dll" Alias "CreateFileW" ( _
ByVal lpFileName As Long, _
ByVal dwDesiredAccess As Long, _
ByVal dwShareModen As Long, _
ByRef lpSecurityAttributes As Any, _
ByVal dwCreationDisposition As Long, _
ByVal dwFlagsAndAttributes As Long, _
ByVal hTemplateFile As Long _
) As Long
Private Declare Function FreeConsole Lib "kernel32" () As Long
Private Declare Function GetStdHandle Lib "kernel32" ( _
ByVal nStdHandle As Long _
) As Long
Private Declare Function ReadFile Lib "Kernel32.dll" ( _
ByVal hFile As Long, _
ByVal lpBuffer As Long, _
ByVal nNumberOfBytesToRead As Long, _
ByRef lpNumberOfBytesRead As Long, _
ByRef lpOverlapped As OVERLAPPED _
) As Long
Private Declare Function ReadFileEx Lib "Kernel32.dll" ( _
ByVal hFile As Long, _
ByVal lpBuffer As Long, _
ByVal nNumberOfBytesToRead As Long, _
ByRef lpOverlapped As OVERLAPPED, _
ByVal lpCompletionRoutine As Long _
) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private m_hStdIn As Long
Private m_uOverlapped As OVERLAPPED
Private m_sUnicodeBuffer As String
Private m_oReadCallback As IReadCallback
Public Sub CloseConsole()
CancelIo m_hStdIn
Set m_oReadCallback = Nothing
m_sUnicodeBuffer = vbNullString
CloseHandle m_hStdIn
FreeConsole
End Sub
Private Sub FileIOCompletionRoutine( _
ByVal dwErrorCode As Long, _
ByVal dwNumberOfBytesTransfered As Long, _
ByRef uOverlapped As OVERLAPPED _
)
On Error GoTo ErrorHandler
m_oReadCallback.DataRead "FileIOCompletionRoutine"
m_oReadCallback.DataRead "dwErrorCode = " & CStr(dwErrorCode)
If dwErrorCode Then
MsgBox "Error = " & CStr(dwErrorCode)
CloseConsole
Exit Sub
End If
m_oReadCallback.DataRead "dwNumberOfBytesTransfered = " & CStr(dwNumberOfBytesTransfered)
m_oReadCallback.DataRead Left$(m_sUnicodeBuffer, dwNumberOfBytesTransfered)
Exit Sub
ErrorHandler:
'
End Sub
Public Sub OpenConsoleForInput(ByRef the_oReadCallback As IReadCallback)
Dim sFileName As String
On Error GoTo ErrorHandler
Set m_oReadCallback = the_oReadCallback
AllocConsole
'm_hStdIn = GetStdHandle(-10&)
sFileName = "CONIN$"
'm_hStdIn = CreateFile(StrPtr(sFileName), GENERIC_READ, FILE_SHARE_READ, ByVal 0&, OPEN_EXISTING, 0&, 0&)
m_hStdIn = CreateFile(StrPtr(sFileName), GENERIC_READ Or GENERIC_WRITE, FILE_SHARE_READ, ByVal 0&, OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0&)
m_oReadCallback.DataRead "m_hStdIn = " & CStr(m_hStdIn)
m_oReadCallback.DataRead "LastError = " & CStr(Err.LastDllError)
m_sUnicodeBuffer = Space$(8192)
Exit Sub
ErrorHandler:
Err.Raise Err.Number, Err.Source, Err.Description
End Sub
Public Sub Read()
Dim nRet As Long
Dim nBytesRead As Long
On Error GoTo ErrorHandler
m_oReadCallback.DataRead "About to call ReadFileExe"
'm_uOverlapped.OffsetHigh = 0&
'm_uOverlapped.OffsetOrPointer = 0&
'nRet = ReadFile(m_hStdIn, StrPtr(m_sUnicodeBuffer), LenB(m_sUnicodeBuffer), nBytesRead, m_uOverlapped)
nRet = ReadFileEx(m_hStdIn, StrPtr(m_sUnicodeBuffer), LenB(m_sUnicodeBuffer), m_uOverlapped, AddressOf FileIOCompletionRoutine)
m_oReadCallback.DataRead "nRet = " & CStr(nRet)
m_oReadCallback.DataRead "nBytesRead = " & CStr(nBytesRead)
If nRet = 0 Then
m_oReadCallback.DataRead "Err.LastDllError = " & CStr(Err.LastDllError)
Else
m_oReadCallback.DataRead StrConv(Left$(m_sUnicodeBuffer, nBytesRead), vbUnicode)
End If
Exit Sub
ErrorHandler:
Err.Raise Err.Number, Err.Source, Err.Description
End Sub
This relies on an interface (IReadCallback) to communicate with the main GUI.
Option Explicit
Public Sub DataRead(ByRef out_sData As String)
'
End Sub
This is my sample form (FAsynchConsoleTest) - which uses a Timer (Timer) and RichTextBox (txtStdIn):
Option Explicit
Implements IReadCallback
Private Sub Form_Load()
MAsynchConsole.OpenConsoleForInput Me
Timer.Enabled = True
End Sub
Private Sub Form_Unload(Cancel As Integer)
MAsynchConsole.CloseConsole
End Sub
Private Sub IReadCallback_DataRead(out_sData As String)
txtStdIn.SelStart = Len(txtStdIn.Text)
txtStdIn.SelText = vbNewLine & out_sData
End Sub
Private Sub mnuTimerOff_Click()
Timer.Enabled = False
End Sub
Private Sub mnuTimerOn_Click()
Timer.Enabled = True
End Sub
Private Sub Timer_Timer()
MAsynchConsole.Read
End Sub
Unfortunately, whilst CreateFile() using FILE_FLAG_OVERLAPPED should create a file handle that can be used with async I/O, and the handle seems valid, ReadFileEx() returns 0, and GetLastError is 6, which is:
//
// MessageId: ERROR_INVALID_HANDLE
//
// MessageText:
//
// The handle is invalid.
//
#define ERROR_INVALID_HANDLE 6L
The console, interestingly, is frozen whilst this all happens.
Anyone else have any ideas? The docs seem to suggest that if you use CreateFile() with a console device name, the parameter is ignored.
wqw's answer doesn't work for a form-based application, but the prototypes given there for Peek/ReadConsoleInput allow for one that does:
Private Declare Function AllocConsole Lib "kernel32" () As Long
Private Declare Function FreeConsole Lib "kernel32" () As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetStdHandle Lib "kernel32" (ByVal nStdHandle As Long) As Long
Private Declare Function PeekConsoleInput Lib "kernel32" Alias "PeekConsoleInputA" (ByVal hConsoleInput As Long, lpBuffer As Any, ByVal nLength As Long, lpNumberOfEventsRead As Long) As Long
Private Declare Function ReadConsoleInput Lib "kernel32" Alias "ReadConsoleInputA" (ByVal hConsoleInput As Long, lpBuffer As Any, ByVal nLength As Long, lpNumberOfEventsRead As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal lpOverlapped As Long) As Long
Private Declare Function SetConsoleMode Lib "kernel32" (ByVal hConsoleInput As Long, dwMode As Long) As Long
Private Const STD_INPUT_HANDLE As Long = -10& ' GetStdHandle()
Private Const KEY_EVENT As Long = 1 ' PeekConsoleInput()
Private Const ENABLE_PROCESSED_INPUT As Long = &H1 ' SetConsoleMode()
Private Const ENABLE_ECHO_INPUT As Long = &H4
Dim hStdIn As Long
Private Sub Form_Load()
AllocConsole
hStdIn = GetStdHandle(STD_INPUT_HANDLE)
SetConsoleMode hStdIn, ENABLE_PROCESSED_INPUT ' Or ENABLE_ECHO_INPUT ' uncomment to see the characters typed (for debugging)
Timer1.Enabled = True
Exit Sub
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
CloseHandle hStdIn
FreeConsole
End Sub
Private Sub Timer1_Timer()
Dim bytesRead As Long
Dim buffer As String
Dim baBuffer(0 To 512) As Byte
Dim lEvents As Long
PeekConsoleInput hStdIn, baBuffer(0), 1, lEvents
If lEvents > 0 Then
If baBuffer(0) = KEY_EVENT And baBuffer(4) <> 0 Then ' baBuffer(4) = INPUT_RECORD.bKeyDown
buffer = Space$(1)
Call ReadFile(hStdIn, ByVal buffer, Len(buffer), bytesRead, 0)
' buffer now contains one byte read from console
' Statements to process go here.
Else
Call ReadConsoleInput(hStdIn, baBuffer(0), 1, lEvents)
End If
End If
End Sub
PeekNamedPipe, GetConsoleMode and PeekConsoleInput will all return zero if your app isn't a true VB6 console app (though all that may be required is linking with the console subsystem, e.g., "C:\Program Files\Microsoft Visual Studio\vb98\LINK.EXE" /EDIT /SUBSYSTEM:CONSOLE MyApp.exe, I haven't tested it that far). They still work, however, at least Peek... does.
It is key that only one byte is read on each pass, as reading what is in baBuffer is problematic past the first record (INPUT_RECORD structure), but one byte at a time non-blocking is better than none at all. For me, Timer1 is set at 100 ms, but a better setting might be 55 ms, the events time slice.
Also key is that ReadConsoleInput is non-blocking if there is an event present on stdin, not just a key to be read. Using it when the recognized event isn't a key, effectively clears the event, allowing the application to proceed. It is possible to use this to read the bytes from the buffer without using ReadFile at all:
PeekConsoleInput hStdIn, baBuffer(0), 1, lEvents
If lEvents > 0 Then
Call ReadConsoleInput(hStdIn, baBuffer(0), 1, lEvents)
If baBuffer(0) = KEY_EVENT And baBuffer(4) <> 0 Then
' Chr(baBuffer(14)) now produces the character typed...
This hasn't been tested for reading true human input, except in the simplest debugging during construction, but it does work and should allow most VB6 form-based apps to effectively use a console. Thank you wqw!
I have a small VB6 app in which I use the Shell command to execute a program. I am storing the output of the program in a file. I am then reading this file and putting the output on the screen using a msgbox in VB6.
This is what my code looks like now:
sCommand = "\evaluate.exe<test.txt "
Shell ("cmd.exe /c" & App.Path & sCommand)
MsgBox Text2String(App.Path & "\experiments\" & genname & "\freq")
The problem is that the output which the VB program is printing using the msgbox is the old state of the file. Is there some way to hold the execution of the VB code until my shell command program finishes so that I get the correct state of the output file and not a previous state?
The secret sauce needed to do this is the WaitForSingleObject function, which blocks execution of your application's process until the specified process completes (or times out). It's part of the Windows API, easily called from a VB 6 application after adding the appropriate declaration to your code.
That declaration would look something like this:
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle _
As Long, ByVal dwMilliseconds As Long) As Long
It takes two parameters: a handle to the process that you want to wait on, and the time-out interval (in milliseconds) that indicates the maximum amount of time that you want to wait. If you do not specify a time-out interval (a value of zero), the function does not wait and returns immediately. If you specify an infinite time-out interval, the function returns only when the process signals that it has completed.
Armed with that knowledge, the only task that remains is figuring out how to get a handle to the process that you started. That turns out to be pretty simple, and can be accomplished a number of different ways:
One possibility (and the way I'd do it) is by using the ShellExecuteEx function, also from the Windows API, as a drop-in replacement for the Shell function that is built into VB 6. This version is far more versatile and powerful, yet just as easily called using the appropriate declaration.
It returns a handle to the process that it creates. All you have to do is pass that handle to the WaitForSingleObject function as the hHandle parameter, and you're in business. Execution of your application will be blocked (suspended) until the process that you've called terminates.
Another possibility is to use the CreateProcess function (once again, from the Windows API). This function creates a new process and its primary thread in the same security context as the calling process (i.e., your VB 6 application).
Microsoft has published a knowledge base article detailing this approach that even provides a complete sample implementation. You can find that article here: How To Use a 32-Bit Application to Determine When a Shelled Process Ends.
Finally, perhaps the simplest approach yet is to take advantage of the fact that the built-in Shell function's return value is an application task ID. This is a unique number that identifies the program you started, and it can be passed to the OpenProcess function to obtain a process handle that can be passed to the WaitForSingleObject function.
However, the simplicity of this approach does come at a cost. A very significant disadvantage is that it will cause your VB 6 application to become completely unresponsive. Because it will not be processing Windows messages, it will not respond to user interaction or even redraw the screen.
The good folks over at VBnet have made complete sample code available in the following article: WaitForSingleObject: Determine when a Shelled App has Ended.
I'd love to be able to reproduce the code here to help stave off link rot (VB 6 is getting up there in years now; there's no guarantee that these resources will be around forever), but the distribution license in the code itself appears to explicitly forbid that.
There is no need to resort to the extra effort of calling CreateProcess(), etc. This more or less duplicates the old Randy Birch code though it wasn't based on his example. There are only so many ways to skin a cat.
Here we have a prepackaged Function for handy use, which also returns the exit code. Drop it into a static (.BAS) module or include it inline in a Form or Class.
Option Explicit
Private Const INFINITE = &HFFFFFFFF&
Private Const SYNCHRONIZE = &H100000
Private Const PROCESS_QUERY_INFORMATION = &H400&
Private Declare Function CloseHandle Lib "kernel32" ( _
ByVal hObject As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" ( _
ByVal hProcess As Long, _
lpExitCode As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" ( _
ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" ( _
ByVal hHandle As Long, _
ByVal dwMilliseconds As Long) As Long
Public Function ShellSync( _
ByVal PathName As String, _
ByVal WindowStyle As VbAppWinStyle) As Long
'Shell and wait. Return exit code result, raise an
'exception on any error.
Dim lngPid As Long
Dim lngHandle As Long
Dim lngExitCode As Long
lngPid = Shell(PathName, WindowStyle)
If lngPid <> 0 Then
lngHandle = OpenProcess(SYNCHRONIZE _
Or PROCESS_QUERY_INFORMATION, 0, lngPid)
If lngHandle <> 0 Then
WaitForSingleObject lngHandle, INFINITE
If GetExitCodeProcess(lngHandle, lngExitCode) <> 0 Then
ShellSync = lngExitCode
CloseHandle lngHandle
Else
CloseHandle lngHandle
Err.Raise &H8004AA00, "ShellSync", _
"Failed to retrieve exit code, error " _
& CStr(Err.LastDllError)
End If
Else
Err.Raise &H8004AA01, "ShellSync", _
"Failed to open child process"
End If
Else
Err.Raise &H8004AA02, "ShellSync", _
"Failed to Shell child process"
End If
End Function
I know it's an old thread, but...
How about using the Windows Script Host's Run method? It has a bWaitOnReturn parameter.
object.Run (strCommand, [intWindowStyle], [bWaitOnReturn])
Set oShell = CreateObject("WSCript.shell")
oShell.run "cmd /C " & App.Path & sCommand, 0, True
intWindowStyle = 0, so cmd will be hidden
Do like this :
Private Type STARTUPINFO
cb As Long
lpReserved As String
lpDesktop As String
lpTitle As String
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 Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessID As Long
dwThreadID As Long
End Type
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal _
hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CreateProcessA Lib "kernel32" (ByVal _
lpApplicationName As String, ByVal lpCommandLine As String, ByVal _
lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _
ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As String, _
lpStartupInfo As STARTUPINFO, lpProcessInformation As _
PROCESS_INFORMATION) As Long
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, lpExitCode As Long) As Long
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const INFINITE = -1&
Public Function ExecCmd(cmdline$)
Dim proc As PROCESS_INFORMATION
Dim start As STARTUPINFO
' Initialize the STARTUPINFO structure:
start.cb = Len(start)
' Start the shelled application:
ret& = CreateProcessA(vbNullString, cmdline$, 0&, 0&, 1&, _
NORMAL_PRIORITY_CLASS, 0&, vbNullString, start, proc)
' Wait for the shelled application to finish:
ret& = WaitForSingleObject(proc.hProcess, INFINITE)
Call GetExitCodeProcess(proc.hProcess, ret&)
Call CloseHandle(proc.hThread)
Call CloseHandle(proc.hProcess)
ExecCmd = ret&
End Function
Sub Form_Click()
Dim retval As Long
retval = ExecCmd("notepad.exe")
MsgBox "Process Finished, Exit Code " & retval
End Sub
Reference : http://support.microsoft.com/kb/129796
Great code. Just one tiny little problem: you must declare in the ExecCmd (after Dim start As STARTUPINFO):
Dim ret as Long
You will get an error when trying to compile in VB6 if you don't.
But it works great :)
Kind regards
In my hands, the csaba solution hangs with intWindowStyle = 0, and never passes control back to VB. The only way out is to end process in taskmanager.
Setting intWindowStyle = 3 and closing the window manually passes control back
I've found a better & simpler solution:
Dim processID = Shell("C:/path/to/process.exe " + args
Dim p As Process = Process.GetProcessById(processID)
p.WaitForExit()
and then you just continue with your code.
Hope it helps ;-)
I want to send Close Messge To Other Running Process
For that i have the name of that process
Not Process ID
Assuming you're using VB 6 (because you didn't specify .NET), you could the following code:
''#Module-level WinAPI Declarations
Private Const PROCESS_ALL_ACCESS = &H1F0FFF
Private Const TH32CS_SNAPPROCESS As Long = 2&
Private Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long
th32DefaultHeapID As Long
th32ModuleID As Long
cntThreads As Long
th32ParentProcessID As Long
pcPriClassBase As Long
dwFlags As Long
szexeFile As String * 260
End Type
Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal blnheritHandle As Long, ByVal dwAppProcessId As Long) As Long
Private Declare Function ProcessFirst Lib "kernel32.dll" Alias "Process32First" (ByVal hSnapshot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function ProcessNext Lib "kernel32.dll" Alias "Process32Next" (ByVal hSnapshot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function CreateToolhelpSnapshot Lib "kernel32.dll" Alias "CreateToolhelp32Snapshot" (ByVal lFlags As Long, lProcessID As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32.dll" (ByVal ApphProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
''#Public function to actually kill a process, given its name
Public Sub KillProcess(ByVal ProcessName As String)
Dim uProcess As PROCESSENTRY32
Dim RProcessFound As Long
Dim hSnapshot As Long
Dim SzExeName As String
Dim ExitCode As Long
Dim MyProcess As Long
Dim AppKill As Boolean
Dim AppCount As Integer
Dim i As Integer
If LenB(ProcessName) <> 0 Then
AppCount = 0
uProcess.dwSize = Len(uProcess)
hSnapshot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0&)
RProcessFound = ProcessFirst(hSnapshot, uProcess)
Do
i = InStr(1, uProcess.szexeFile, Chr(0))
SzExeName = LCase$(Left$(uProcess.szexeFile, i - 1))
If Right$(SzExeName, Len(ProcessName)) = LCase$(ProcessName) Then
AppCount = AppCount + 1
MyProcess = OpenProcess(PROCESS_ALL_ACCESS, False, uProcess.th32ProcessID)
AppKill = TerminateProcess(MyProcess, ExitCode)
Call CloseHandle(MyProcess)
End If
RProcessFound = ProcessNext(hSnapshot, uProcess)
Loop While RProcessFound
Call CloseHandle(hSnapshot)
End If
End Sub
Basically what this code does is enumerate all currently running processes in order to find the one you want to kill. The CreateToolHelpSnapshot API function returns a snapshot of the processes, and then we loop through this snapshot with the Process32First and Process32Next functions. When it finds a match to the name you specified, it uses the TerminateProcess function to terminate that process and all of its threads. Note that this is untested on post-XP versions of Windows.
If you speak Win32 fluently, see the following MSDN article: Taking a Snapshot and Viewing Processes
Lots of the examples you find on the Internet (i.e., option one, option two) use EnumWindows to send a WM_CLOSE message to the windows associated with a particular process. The advantage of this is that it asks nicely—sending the WM_CLOSE message gives the process a chance to save any data and exit gracefully. TerminateProcess, as used in the above example, is not so nice—it's an instant buzz-kill. But it will allow you to end processes that don't own any windows. You didn't mention if this was a requirement in the question.
(Honestly, there isn't enough detail in the question for me to have any business trying to answer this question, but I'm procrastinating. If you need anything else, please edit your question to include more details and add a comment to let me know...)