标准输入的非阻塞读取

Question

我需要让我的基于表单的应用程序定期检查 stdin 的输入，但仍执行其他处理。Scripting.TextStream.Read（） 和 ReadFile（） API 正在阻塞，在 VB6 中是否有读取 stdin 的非阻塞方法？

Timer1设置为每 100 毫秒触发一次，我尝试了：

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

我也试过：

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

我也尝试过ReadConsole（）API，它们都阻止了。

Answer 1

使用 vbAdvance 加载项编译以下示例，并选中"构建为控制台应用程序"选项。

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

Answer 2

恐怕我还没有设法让它工作，但是其他人可能会试一试。这些想法是将异步 I/O 与控制台 std 输入一起使用（我假设您的应用程序的想法是允许人们直接写入控制台窗口，并在输入时读取输入）。

我把所有的API东西都分离到一个模块（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

这依赖于接口（IReadCallback）与主GUI进行通信。

Option Explicit
Public Sub DataRead(ByRef out_sData As String)
    '
End Sub

这是我的示例表单（FAsynchConsoleTest） - 它使用计时器（计时器）和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

不幸的是，虽然使用 FILE_FLAG_OVERLAPPED 的 CreateFile（） 应该创建一个可以与异步 I/O 一起使用的文件句柄，并且句柄似乎有效，但 ReadFileEx（） 返回 0，GetLastError 为 6，即：

//
// MessageId: ERROR_INVALID_HANDLE
//
// MessageText:
//
// The handle is invalid.
//
#define ERROR_INVALID_HANDLE             6L

有趣的是，当这一切发生时，控制台被冻结了。

其他人有什么想法吗？文档似乎建议，如果您将 CreateFile（） 与控制台设备名称一起使用，则会忽略该参数。

Answer 3

wqw 的答案不适用于基于表单的应用程序，但那里为 Peek/ReadConsoleInput 提供的原型允许：

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

如果您的应用程序不是真正的 VB6 控制台应用程序，PeekNamedPipe、GetConsoleMode 和 PeekConsoleInput 都将返回零（尽管可能需要的只是与控制台子系统链接，例如，"C:Program FilesMicrosoft Visual Studiovb98LINK.EXE" /EDIT /SUBSYSTEM:CONSOLE MyApp.exe，我还没有测试过它）。然而，它们仍然有效，至少是偷看...确实如此。

每次传递时只读取一个字节是关键，因为读取 baBuffer 中的内容在第一条记录（INPUT_RECORD结构）之后是有问题的，但一次一个字节不阻塞总比没有好。对我来说，Timer1 设置为 100 毫秒，但更好的设置可能是 55 毫秒，即事件时间片。

同样关键的是，如果标准输入上存在事件，则 ReadConsoleInput 是非阻塞的，而不仅仅是要读取的键。当识别的事件不是键时使用它，可以有效地清除事件，允许应用程序继续。可以使用它从缓冲区读取字节，而无需使用 ReadFile：

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...

除了在构造期间最简单的调试中，这尚未经过读取真实人类输入的测试，但它确实有效，并且应该允许大多数基于 VB6 表单的应用程序有效地使用控制台。谢谢你wqw！