Non-blocking read of stdin?

Question

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.

Answer 1

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