How can I lock an application after period of user inactivity? - windows

How can I lock an application after period of user inactivity?
I have a fat Windows applocation written in VB6. User must log into the application to use it. I need to log the user out after a period of inactivity. There are over 100 separate forms with one Main form that is always open after the user logs in, so I am looking for an application solution not a form level solution.
I am thinking about monitoring keyboard and mouse usage using WIN API.

Are you looking to measure inactivity in/of the application? Or the entire desktop?
If the latter, I’d suggest looking at GetLastInputInfo which you could call from time to time, either from another app, or from a timer in your main window. You can find a VB6 example of it's use here, though you can call it from just about any language you want as it is a Win32 API.

Here is the solution I decided upon. I wanted to document it properly. As this is the approach I had envisioned, it is not my code. Someone smarter than I did awhile ago.
I simply implemented the solution into my application.
Solution was posted by DaVBMan
Sample code
Original discussion thread.
The app is an multiple-document interface app.
In a common.bas module:
WIN API Code: for Keyboard and Mouse monitoring:
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
Private m_hDllKbdHook As Long
Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare Function GetCursorPos Lib "user32.dll" (ByRef lpPoint As POINTAPI) As Long
Global variables to hold DateTime last user activity and if mouse and keyboard activity has occurred
Public KeysHaveBeenPressed As Boolean
Public HasMouseMoved As Boolean
Public gLastUserActivity As Date
Code to detect keyboard activity
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
'keys have been pressed
KeysHaveBeenPressed = True
End If
LowLevelKeyboardProc = CallNextHookEx(m_hDllKbdHook, nCode, wParam, lParam)
End Function
Code to detect mouse movement:
Public Sub CheckMouse()
On Error GoTo ErrCheckMouse
Dim p As POINTAPI
GetCursorPos p
If p.x <> LastMouse.x Or p.y <> LastMouse.y Then
HasMouseMoved = True
LastMouse.x = p.x
LastMouse.y = p.y
End If
Exit Sub
ErrCheckMouse:
MsgBox Err.Number & ": Error in CheckMouse(). Error Description: " & Err.Description, vbCritical, "Error"
Exit Sub
End Sub
On the Main parent Form:
Added a timer:
Private Sub muTimer_Timer()
CheckMouse
'Debug.Print "MU Timer Fire"
'Debug.Print "Keyboard:" & KeysHaveBeenPressed & " - " & "Mouse:" & HasMouseMoved
If HasMouseMoved = False And KeysHaveBeenPressed = False Then
If DateDiff("m", gLastUserActivity, Now) > gnMUTimeOut Then
muTimer.Interval = 0
<Make call to lock the application>
Else
'Debug.Print " dT "; DateDiff("s", gLastUserActivity, Now)
End If
Else
HasMouseMoved = False
KeysHaveBeenPressed = False
gLastUserActivity = Now
End If
'Debug.Print " dT "; DateDiff("s", gLastUserActivity, Now)
End Sub
Also on the MainForm load event:
Private Sub MDIForm_Load()
HookKeyboard
end sub
Private Sub MDIForm_QueryUnload(Cancel As Integer, UnloadMode As Integer)
UnHookKeyboard
end sub

Related

vb6 suppress keyboard strokes with API? (making a hotkey)

I've searched, and can't seem to find an answer, so any help would be appreciated.
I want to make a hotkey, but when the hotkey is pressed, I don't want the actual "character" to be displayed, just the action to be performed.
So for example, I have this:
Private Declare Function GetAsyncKeyState Lib "user32" _
(ByVal vKey As KeyCodeConstants) As Long
Private Const VK_A = &H41
Private Sub keyboardTimer001_Timer()
If KeyDown(VK_A) Then
' do my stuff, but DONT DISPLAY the letter "A"
End If
end sub
So this basically just has a timer (interval 1) checking the async keyboard. If it detects that the letter "a" was pressed, I perform an action. But I want it to do this WITHOUT printing the letter "a".
How would I remove the key from the keyboard buffer/prevent it from displaying? (Side note - not sure if something like 'PeekMessage' would work - if so - does anyone know where I can find a good vb6 code sample where I can peek for stuff like 'ctrl+a' or 'ctrl+alt+a', etc, etc and then just clear the buffer, and perform my action?)
Thanks!
You can use a combination of RegisterHotKey and PeekMessage. The following code defines Key-A and Ctrl-A to perform actions:
Main Form
Option Explicit
Private Done As Boolean
Private Sub Form_Activate()
Done = False
RegisterHotKey Me.hWnd, &HBBBB&, MOD_NONE, vbKeyA
RegisterHotKey Me.hWnd, &HBBBA&, MOD_CONTROL, vbKeyA
ProcessMessages
End Sub
Private Sub ProcessMessages()
Dim Message As Msg
Do While Not Done
WaitMessage
If PeekMessage(Message, Me.hWnd, WM_HOTKEY, WM_HOTKEY, PM_REMOVE) Then
If Message.wParam = &HBBBB& Then
MsgBox "This is my Key-A action"
ElseIf Message.wParam = &HBBBA& Then
MsgBox "This is my Ctrl-A action"
End If
End If
DoEvents
Loop
End Sub
Private Sub Form_Unload(Cancel As Integer)
Done = True
Call UnregisterHotKey(Me.hWnd, &HBBBB&)
Call UnregisterHotKey(Me.hWnd, &HBBBA&)
End Sub
The above code works well, but in a production app I might lean towards subclassing the main window. If you prefer subclassing, you will need to use a technique of your choosing and replace the ProcessMessages method with something like this:
Private Function ISubclass_WindowProc(ByVal hwnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case iMsg
Case WM_HOTKEY
If wParam = &HBBBB& Then
MsgBox "This is my Key-A action"
ElseIf wParam = &HBBBA& Then
MsgBox "This is my Ctrl-A action"
End If
End Select
End Function
As you can see, subclassing is a little cleaner. Of course, you need to define the Win API stuff. So in a module, place the following code:
Module
Option Explicit
Public Declare Function RegisterHotKey Lib "user32" (ByVal hWnd As Long, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
Public Declare Function UnregisterHotKey Lib "user32" (ByVal hWnd As Long, ByVal id As Long) As Long
Public Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As Msg, ByVal hWnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
Public Declare Function WaitMessage Lib "user32" () As Long
Public Const MOD_NONE = &H0
Public Const MOD_ALT = &H1
Public Const MOD_CONTROL = &H2
Public Const MOD_SHIFT = &H4
Public Const MOD_WIN = &H8
Public Const PM_REMOVE = &H1
Public Const WM_HOTKEY = &H312
Public Type POINTAPI
x As Long
y As Long
End Type
Public Type Msg
hWnd As Long
Message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type

Detecting a Keypress outside Vb6

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

How to give file path to "save as" window using vb6

I'm working on a VB6 code.
It has to perform the following operations in sequence:
1. Check the window is open or not (Done! using FindWindows)
2. Press Ctrl + S (Done! using SendKeys("^S")
3. Type full path name (Stuck here! Don't know how to proceed)
4. Hit Enter key (Done! using SendKeys)
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, _
ByVal cch As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hWnd As Long) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long
'--------------------------------------------------------
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal lhWndP As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal lhWndP As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function SetForegroundWindow Lib "user32" ( _
ByVal hWnd As Long) _
As Long
Private Const BM_CLICK = &HF5
Private Const WM_CLOSE = &H10
Private Const WM_SETTEXT As Long = &HC
'------------------------------------------------------------
Private Const GW_HWNDNEXT = 2
Private Sub Command1_Click()
Dim lhWndP As Long
Dim lhWndP1 As Long
Dim hWnd1 As Long
Dim hWnd11 As Long
If Dir$("C:\users\public\123.txt") <> "" Then
Kill ("C:\users\public\123.txt")
End If
If GetHandleFromPartialCaption(lhWndP, "Untitled - Notepad") = True Then
SetForegroundWindow lhWndP
DoEvents
Call VBA.SendKeys("^s")
DoEvents
Call VBA.SendKeys("C:\users\public\123.txt") 'This is not working 100%
If GetHandleFromPartialCaption(lhWndP1, "Save As") = True Then
DoEvents
hWnd11 = FindWindowEx(lhWndP1, 0, "Button", "&Save")
If hWnd11 <> 0 Then
Call PostMessage(hWnd11, BM_CLICK, 0, 0)
Else
MsgBox "Button handle not found!"
End If
End If
hWnd11 = FindWindowEx(lhWndP1, 0, "Button", "&Save")
If hWnd11 <> 0 Then
Call PostMessage(hWnd1, BM_CLICK, 0, 0)
Else
MsgBox "Button handle not found!"
End If
End If
End
End Sub
Public 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
I tried sendmessage function. But WM_SETTEXT is setting some junk to the window title and not in file name field.
Any alternate for this WM_SETTEXT ? or some other method to accompolish the task?
Note: In this example i've used a notepad. But actual application uses a third party window. I dont have code for that application.
The problem is that you aren't waiting for the SendKeys text to be processed by the target application. A call to DoEvents is not the same thing as waiting for an external application to do something. It allows your application to flush the rest of its event queue.
If you need to wait for an external application to process, the quick and dirty way to do it is add a short Sleep. Declare the API function as...
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
...and then try this:
'...
If GetHandleFromPartialCaption(lhWndP, "Untitled - Notepad") = True Then
SetForegroundWindow lhWndP
Sleep 100
Call VBA.SendKeys("^s")
Sleep 100
Call VBA.SendKeys("C:\users\public\123.txt") 'This is not working 100%
If GetHandleFromPartialCaption(lhWndP1, "Save As") = True Then
Sleep 100
hWnd11 = FindWindowEx(lhWndP1, 0, "Button", "&Save")
If hWnd11 <> 0 Then
Call PostMessage(hWnd11, BM_CLICK, 0, 0)
Else
MsgBox "Button handle not found!"
End If
End If
hWnd11 = FindWindowEx(lhWndP1, 0, "Button", "&Save")
If hWnd11 <> 0 Then
Call PostMessage(hWnd1, BM_CLICK, 0, 0)
Else
MsgBox "Button handle not found!"
End If
End If
'...
If that still doesn't work, adjust the Sleep times until it does.

API SendMessage() does not work for external app dialog

I created a form that has 2 buttons. One button pops a msgbox and the other runs form frmAPI (code is listed below) listed below. If I open the msgbox and leave it open and then run the frmAPI it will list the msgbox and its text and then close it. THis is what I expect it to do. If I open another application and generate a msgbox in that app with my frmAPI still running it will in fact list the other apps msgbox and the text but it does not close the msgbox from the other app. If Irun the frmAPI from the other app and do the same test the results are reversed. So in short it will only close the dialog from within the same app.
I would like to be able to close a dialog from any app based on it being a dialog and having text that will match my criteria. Any help on what I am doing wrong?
Thanks
Imports System.Runtime.InteropServices
Imports System.Text
Partial Public Class TestMSgBoxStuff
Inherits Form
Public Sub New()
InitializeComponent()
End Sub
<DllImport("user32.dll", SetLastError:=True)> _
Private Shared Function FindWindow(lpClassName As String, lpWindowName As String) As IntPtr
End Function
<DllImport("user32.dll", SetLastError:=True)> _
Private Shared Function FindWindowEx(hwndParent As IntPtr, hwndChildAfter As IntPtr, lpszClass As String, lpszWindow As String) As IntPtr
End Function
<DllImport("user32.dll", CharSet:=CharSet.Auto, SetLastError:=True)> _
Private Shared Function GetWindowText(hWnd As IntPtr, lpString As StringBuilder, nMaxCount As Integer) As Integer
End Function
<DllImport("user32.dll", SetLastError:=True, CharSet:=CharSet.Auto)> _
Private Shared Function GetWindowTextLength(hWnd As IntPtr) As Integer
End Function
<DllImport("user32.dll", SetLastError:=True)> _
Private Shared Function SendMessage(hWnd As HandleRef, Msg As UInteger, wParam As IntPtr, lParam As IntPtr) As IntPtr
End Function
<DllImport("user32", CharSet:=Runtime.InteropServices.CharSet.Auto, SetLastError:=True, ExactSpelling:=True)>
Private Shared Function SetForegroundWindow(ByVal hwnd As IntPtr) As IntPtr
End Function
Private Const WM_IME_NOTIFY As Integer = &H282
Private Const WM_DESTROY As Integer = &H2
Private Const WM_NCDESTROY As Integer = &H82
Private Const WM_CLOSE As Integer = &H10
Private Const IMN_CLOSESTATUSWINDOW As Integer = &H1
Private Const WM_KILLFOCUS As Integer = &H8
Private Const WM_COMMAND As Integer = &H11
Private Sub TestMSgBoxStuff_Load(sender As System.Object, e As System.EventArgs) Handles MyBase.Load
Dim timer As New Timer()
Timer1.Interval = 10000
'detect the MessageBox every seconds
'Timer1.Tick += New EventHandler(Timer1_Tick)
Timer1.Start()
End Sub
Private Sub Timer1_Tick(sender As System.Object, e As System.EventArgs) Handles Timer1.Tick
'Get the MessageBox handle
Dim handle As IntPtr = FindWindow("#32770", Nothing)
Me.RichTextBox1.AppendText("Handle: " + handle.ToString() + vbLf)
'Get the Text window handle
Dim txtHandle As IntPtr = FindWindowEx(handle, IntPtr.Zero, "Static", Nothing)
Me.RichTextBox1.AppendText(vbTab & "text handle: " + txtHandle.ToString() + vbLf)
Dim len As Integer = GetWindowTextLength(txtHandle)
Dim sb As New StringBuilder()
'Get the text
GetWindowText(txtHandle, sb, len + 1)
Me.RichTextBox1.AppendText(vbTab & "text: " + sb.ToString() + vbLf & vbLf)
Me.RichTextBox1.ScrollToCaret()
SetForegroundWindow(handle)
'close the messagebox WM_CLOSE
Dim lResults As Integer = SendMessage(New HandleRef(Nothing, handle), WM_NCDESTROY, IntPtr.Zero, IntPtr.Zero)
End Sub
End Class
You may be running into User Interface Privilege Isolation. That'll block your messages from going to a higher privilege process. See also ChangeWindowsMessageFilter()
I'd suggest trying to send it a WM_COMMAND instead of a WM_CLOSE; WM_COMMAND is generally treated more gently by the system and may get through. Use BN_CLICKED as the high word of WPARAM and IDOK as the low word (assuming it has an OK button), and the handle to the OK button in LPARAM.. Other button messages are here.

Non-blocking read of stdin?

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!

Resources