Detecting a Keypress outside Vb6 - 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

Related

GetWindowText does not work

I'm trying to retrieve the text from an EDIT control using GetWindowText and GetWindowTextLength. The application retrieves the text from the window under the cursor and it works on all windows with a caption or text with the exception of the EDIT control. The EDIT control is the result window on the Windows XP Calculator, calc.exe.
Dim S As String
Dim L As Long
L = GetWindowTextLength(handle) + 1
Receiving string = GetWindowText(handle, S, L)
EDIT:
According to SPY++ the Edit class control does not receive the EM_GETSELTEXT or the WM_GETTEXT message.The code below retrieves the text from the Edit class control on the Windows XP calc.exe calculator every time that I press a button on my UI. It is not the method that I would have preferred to use, however, it accomplishes my task.
Const EM_SETSEL = &HB1
Const ES_READONLY = &H800
Const WM_COPY = &H301
Const EM_GETSELTEXT = &H43E
Const WM_GETTEXTLENGTH = &HE
Const WM_SETFOCUS As Long = &H7
Dim L As Long
L = SendMessage(EditHwnd, WM_GETTEXTLENGTH, 0&, 0)
SendMessage EditHwnd, WM_SETFOCUS, 0&, 0
SendMessage EditHwnd, EM_SETSEL, 0&, L
SendMessage EditHwnd, ES_READONLY, 0&, 0 ' read only = false
Clipboard.Clear
SendMessage EditHwnd, WM_COPY, 0&, 0
SendMessage EditHwnd, ES_READONLY, 1&, 0 ' read only = true
Receiving string = Clipboard.GetText
Clipboard.Clear
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Function GetText(handle As Long) As String
Dim S As String, L As Integer, cch As Long
L = GetWindowTextLength(handle) + 1
S = String(L, 0)
GetText = Mid(S, 1, GetWindowText(handle, S, L))
End Function
Private Sub Form_Load()
Dim hw As Long
hw = Me.hwnd
MsgBox GetText(hw)
End Sub
But it will not work with controls like EDIT, as it is written in help. ;( In order to get the text of the child window (control), try to get a list of all windows using API EnumWindows/EnumThreadWindows/GetWindowThreadProcessId, to find the desired control.
What is the name of the class to EDIT You need? What is its width and height? I could write code specifically for the search for this control.
this code works fine in Windows XP (virtual machine)
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32.dll" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As Any, ByVal lpsz2 As Any) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Function AttachThreadInput Lib "user32.dll" _
(ByVal idAttach As Long, ByVal idAttachTo As Long, ByVal fAttach As Long) As Long
Private Const WM_GETTEXT As Long = &HD&
Private Const WM_GETTEXTLENGTH As Long = &HE&
Function WindowText(ByVal hWnd As Long) As String
Dim ret As Long
ret = SendMessage(hWnd, WM_GETTEXTLENGTH, 0, ByVal 0&)
WindowText = String(ret, 0)
ret = SendMessage(hWnd, WM_GETTEXT, ret + 1, ByVal WindowText)
End Function
Private Sub Command1_Click()
Dim hCalc As Long, hEdit As Long
hCalc = FindWindow("SciCalc", vbNullString)
hEdit = FindWindowEx(hCalc, 0&, "Edit", vbNullString)
MsgBox WindowText(hEdit)
End Sub

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.

Saving a hexeditor file through Excel using vba and windows api

I need help on this, I don't know much about windows API, and I'm trying to figure out how I can save a file, and overwrite it (already exists with the same name).
What I'm doing is: Find the application first, send some keys like alt, some down keys, enter.(File->Save as->Enter)
When I press enter, it comes a new window asking confirmation about saving the file.
And then excel freezes, without finding "Confirm Save As Window" and pressing "Yes".
It happens in command:
Call SendMessage(SaveButton, BM_CLICK, 0&, ByVal 0&)
Can anyone help me solving this. Is it happening because it focus is still in save as window or something?
Should I use other way to do what I want?
Public Declare PtrSafe Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare PtrSafe Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Public Declare PtrSafe Function FindWindowEx Lib "user32.dll" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Public Declare PtrSafe Function SendMessageByString Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Any) As Long
Public Declare PtrSafe Function SetActiveWindow Lib "user32.dll" (ByVal hWnd As Long) As Long
Public Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdSHow As Long) As Long
Public Declare PtrSafe Function BringWindowToTop Lib "user32" (ByVal lngHWnd As Long) As Long
Public Declare PtrSafe Function EnableWindow Lib "user32.dll" (ByVal hWnd As Long, ByVal fEnable As Long) As Long
Public Declare PtrSafe Function GetActiveWindow Lib "user32" () As Long
Public Declare PtrSafe Function GetFocus Lib "user32.dll" () As Long
Public Declare PtrSafe Function SendDlgItemMessage Lib "user32.dll" Alias "SendDlgItemMessageA" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Const WM_CLOSE As Long = &H10
Public Const SW_SHOW As Integer = 5
Public Const WM_SETTEXT As Long = &HC
Public Const BM_CLICK As Long = &HF5&
Sub PulseAutomation()
CCPUlse = FindWindow(vbNullString, "HxD - [C:\Users\Matthew\Desktop\changelog.txt]")
view13844BringWindowToTop = BringWindowToTop(CCPUlse)
DoEvents
SendKeys "%", True
SendKeys "{DOWN}", True
SendKeys "{DOWN}", True
SendKeys "{DOWN}", True
SendKeys "{DOWN}", True
SendKeys "{DOWN}", True
SendKeys "~", True
Application.Wait (Now + #12:00:01 AM#)
SaveAsWindow = FindWindow(vbNullString, "Save As")
SaveButton = FindWindowEx(SaveAsWindow, 0&, "Button", "&Save")
Call EnableWindow(SaveButton, True)
Call SendMessage(SaveButton, BM_CLICK, 0&, ByVal 0&)
DoEvents
Application.Wait (Now + #12:00:01 AM#)
Dim hWndFind As Long
hWnd = FindWindow(vbNullString, "Confirm Save As")
'get the first child window with the class "Edit" (a textbox to VB)
hWndFind1 = FindWindowEx(hWnd, 0, "DirectUIHWND", vbNullString)
hWndFind2 = FindWindowEx(hWndFind1, 0, "CtrlNotifySink", vbNullString)
hWndFind3 = GetNextWindow(hWndFind2, GW_HWNDNEXT)
hWndFind4 = GetNextWindow(hWndFind3, GW_HWNDNEXT)
hWndFind5 = GetNextWindow(hWndFind4, GW_HWNDNEXT)
hWndFind6 = GetNextWindow(hWndFind5, GW_HWNDNEXT)
hWndFind7 = GetNextWindow(hWndFind6, GW_HWNDNEXT)
hWndFind8 = GetNextWindow(hWndFind7, GW_HWNDNEXT)
hWndFind9 = FindWindowEx(hWndFind8, 0, "Button", vbNullString)
Call SendMessage(hWndFind9, BM_CLICK, 0&, ByVal 0&)
End Sub
Thanks for your advice and your time!
Why are you saving your file like this and not through the VBA method:
Application.DisplayAlerts = False
ActiveWorkbook.Save
Application.DisplayAlerts = True
Wouter
Solution : I used PostMessage instead of SendMessage, for Save button control.
Thanks anyway!

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!

sendmessage not working for jetaudio in vb6

i am trying to implement the Jetaudio API in vb6...
i have taken the values of the constants from the API SDK..
Private Declare Function FindWindow Lib "user32.dll" 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, ByVal lParam As Long) As Long
Private Declare Function RegisterWindowMessage _
Lib "user32" Alias "RegisterWindowMessageA" _
(ByVal lpString As String) As Long
Public Const WM_APP As Long = &H8000
Public Const MyMSG As Long = WM_APP + 740
Public Function GetJetAudioSong()
Dim v As Long
Dim JAhwnd As Long
Dim lngMyMsg As Long
lngMyMsg = RegisterWindowMessage(MyMSG)
JAhwnd = FindWindow("COWON Jet-Audio Remocon Class", "Jet-Audio Remote Control")
v = SendMessage(JAhwnd, lngMyMsg, 0, 995)
MsgBox v
End Function
Now, FindWindow() is working cause JAhwnd is set with a value...
its just the sendmessage() that doesn't seem to be working...
the code is suppose to msgbox the version number for the running Jet Audio instance.
i've been at it for days now and i have no way of making sure weather this error is a VB thing or not... i am taking Jet Audio's SDK's word that the values of the const are correct...
the value of v is always 0 where it should be 6 on my system.
what am i doing wrong?
Don't call RegisterWindowMessage, MyMSG is message number that you should send to the Jet-Audio window.
Private Declare Function FindWindow Lib "user32.dll" 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, ByVal lParam As Long) As Long
Public Const WM_APP As Long = &H8000
Public Const MyMSG As Long = WM_APP + 740
Public Function GetJetAudioSong()
Dim v As Long
Dim JAhwnd As Long
Dim lngMyMsg As Long
JAhwnd = FindWindow("COWON Jet-Audio Remocon Class", "Jet-Audio Remote Control")
v = SendMessage(JAhwnd, MyMSG, 0, 995)
MsgBox v
End Function
What Windows Version?
SendMessage and SendKeys no longer works with VB6 code starting at Windows Vista and above.
Do a Google search for it.
I know this is 2 years too late. Please use this as a future reference for anyone reading this in the future.
The fix for your issue is this:
'[ Use 'ByVal' for your lParam to make sure you are passing the actual value not the Reference
v = SendMessage(JAhwnd, lngMyMsg, 0, ByVal 995)
'[ Or you could perform PostMessage(..) and not use ByVal
v = PostMessage(JAhwnd, lngMyMsg, 0, 995)
Also, i HIGHLY recommend against anyone using SendKeys. API is the correct method to ensure you are sending message to the correct hWnd. I would suggest using SendKeys only if in desperation; it can happen.

Resources