Option Explicit

Declare Function AllocConsole Lib "kernel32" () As Long
Declare Function FreeConsole Lib "kernel32" () As Long

Const STD_INPUT_HANDLE = -10&
Const STD_OUTPUT_HANDLE = -11&

Declare Function GetStdHandle Lib "kernel32" ( _
ByVal nStdHandle As Long) As Long

Declare Function WriteConsole Lib "kernel32" _
Alias "WriteConsoleA" (ByVal hConsoleOutput As Long, _
lpBuffer As Any, ByVal nNumberOfCharsToWrite As Long, _
lpNumberOfCharsWritten As Long, lpReserved As Any) As Long

Declare Function ReadConsole Lib "kernel32" _
Alias "ReadConsoleA" (ByVal hConsoleInput As Long, _
lpBuffer As Any, ByVal nNumberOfCharsToRead As Long, _
lpNumberOfCharsRead As Long, lpReserved As Any) As Long

Public Type PINPUT_RECORD
    Type1 As Integer
    Type2 As Integer
    Param1 As Integer
    Param2 As Integer
    Param3 As Integer
    Param4 As Integer
    Param5 As Integer
    Param6 As Integer
    Param7 As Integer
    Param8 As Integer
End Type

Public Const CON_KEY_EVENT& = &H1

Declare Function WaitForSingleObject& Lib "kernel32" (ByVal hObject As Long, _
  ByVal dwTimeout As Long)
Declare Function ReadConsoleInput% Lib "kernel32" Alias "ReadConsoleInputA" _
  (ByVal hConsoleInput As Long, pirBuffer As PINPUT_RECORD, ByVal cInRecords _
  As Long, lpcRead As Long)
  
Sub Main()
 Dim hOutput As Long, hInput As Long
 Dim cWritten As Long, cRead As Long
 Dim strHello As String, bRead As Byte
 'создаём консоль
 AllocConsole

 'получаем дескрипторы ввода и вывода
 hOutput = GetStdHandle(STD_OUTPUT_HANDLE)
 hInput = GetStdHandle(STD_INPUT_HANDLE)

 'строка, которую напишем в консоли
 strHello = "Hello, world!" & vbCrLf & _
 "Press any key to continue . . . "
 
 'пишем
 WriteConsole hOutput, ByVal strHello, _
 Len(strHello), cWritten, 0

 'эту функцию вызываем для того,
 'чтобы консоль не закрылась сразу же
 'ReadConsole hInput, bRead, 1, cRead, 0
 PressAnyKey hInput
 
 'освобождаем память на выходе
 FreeConsole
End Sub 'Main
Public Function PressAnyKey(the_input As Long) As String
 Dim strResult As String
    Do
        strResult = ReadChar(the_input)
        DoEvents
    Loop While strResult = ""
End Function

Public Function ReadChar(the_input As Long) As String

  Dim myEvent As PINPUT_RECORD
  Dim strReturn As String
  Dim length As Long
  
  length = 0

  If Not WaitForSingleObject(the_input, 0) Then
    ReadConsoleInput the_input, myEvent, 1, length
    If myEvent.Type1 = CON_KEY_EVENT Then
      If myEvent.Param1 Then
        If myEvent.Param6 > 0 Then 'RealKey
          strReturn = Chr(myEvent.Param6)
        End If
      End If
    End If
  End If
  
  ReadChar = strReturn

End Function