'[To use a DOS console for output, example to run apps from command-line or execute a file from VB]

'For suggestions,
'E.B. Knoppert, ProFinance WOERDEN Netherlands
'ebknoppert@hotmail.com

// FORM1
Option Explicit

Private Sub Command1_Click()

    CreateDosConsole

End Sub

Private Sub Command2_Click()

    RunDOSApp "test.bat"

End Sub

// MODULE1
Option Explicit

'An app uses 1 console only.
Global hConsOutput As Long
Global hConsInput As Long

Public Const ENABLE_ECHO_INPUT = &H4
Public Const ENABLE_LINE_INPUT = &H2
Public Const STD_INPUT_HANDLE = -10&
Public Const STD_OUTPUT_HANDLE = -11&

Public Type COORD

    X As Integer
    Y As Integer

End Type

Public Type SMALL_RECT

    Left    As Integer
    Top     As Integer
    Right   As Integer
    Bottom  As Integer

End Type

Public Type CONSOLE_SCREEN_BUFFER_INFO

    dwSize              As COORD
    dwCursorPosition    As COORD
    wAttributes         As Integer
    srWindow            As SMALL_RECT
    dwMaximumWindowSize As COORD

End Type

Public Declare Function AllocConsole Lib "kernel32" () As Long
Public Declare Function FreeConsole Lib "kernel32" () As Long
Public Declare Function GetStdHandle Lib "kernel32" (ByVal nStdHandle As Long) As Long
Public Declare Function ReadFileNULL Lib "kernel32" Alias "ReadFile" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Long) As Long
Public Declare Function SetConsoleMode Lib "kernel32" (ByVal hConsoleHandle As Long, ByVal dwMode As Long) As Long
Public 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
Public Declare Function SetConsoleCursorPosition Lib "kernel32" (ByVal hConsoleOutput As Long, dwCursorPosition As COORD) As Long
Public Declare Function GetConsoleScreenBufferInfo Lib "kernel32" (ByVal hConsoleOutput As Long, lpConsoleScreenBufferInfo As CONSOLE_SCREEN_BUFFER_INFO) As Long

'Does not work yet.
Function CSRPOS() As Long

    Dim lpConsoleScreenBufferInfo As CONSOLE_SCREEN_BUFFER_INFO

    GetConsoleScreenBufferInfo hConsOutput, lpConsoleScreenBufferInfo

    CSRPOS = lpConsoleScreenBufferInfo.dwCursorPosition.X

End Function

'Does not work yet.
Function CSRLIN() As Long

    Dim lpConsoleScreenBufferInfo As CONSOLE_SCREEN_BUFFER_INFO

    GetConsoleScreenBufferInfo hConsOutput, lpConsoleScreenBufferInfo

    CSRLIN = lpConsoleScreenBufferInfo.dwCursorPosition.Y

End Function

'Does not work yet.
Sub Locate(ByVal Row As Long, ByVal Column As Long)

    Dim dwCursorPosition As COORD
    dwCursorPosition.X = Row
    dwCursorPosition.Y = Column

    SetConsoleCursorPosition hConsOutput, dwCursorPosition

End Sub

Sub StdOut(ByVal Text As String)

    Dim a As Long
    Dim L As Long
    
    If Len(Text) < 1 Then Exit Sub
    
    'Convert unicode to ansi.
    ReDim ByteBuffer(0 To Len(Text)) As Byte
    
    For a = 1 To Len(Text)
        ByteBuffer(a) = Asc(Mid$(Text, a, 1))
    Next a

    WriteConsole hConsOutput, ByVal VarPtr(ByteBuffer(1)), UBound(ByteBuffer), L, ByVal 0&

End Sub

Function ReadFileKeyBuffer() As String

    Dim T As Byte
    Dim L As Long

    ReadFileNULL hConsInput, T, Len(T), L, ByVal 0&

    If L Then ReadFileKeyBuffer = Chr$(T)

End Function

Function InputCons() As String

    Dim T As String
    Dim B As String

    Do

        T = ReadFileKeyBuffer()

        If T > "" Then

'            Debug.Print Asc(T)

            Select Case Asc(T)
            Case 10
            Case vbKeyBack: If B > "" Then B = Left$(B, Len(B) - 1)
            Case vbKeyReturn: Exit Do
            Case Else:  B = B & T
            End Select

        End If

    Loop

    InputCons = B

End Function

Function RunDOSApp(ByVal FileName As String) As Long

    On Error Resume Next

    Dim a       As Long
    Dim hOut    As Long

    FileName = Trim$(FileName)
    If FileName = "" Then Exit Function

    AllocConsole
    
    RunDOSApp = Shell(FileName, vbNormalFocus)

    FreeConsole

End Function

Sub CreateDosConsole()
    
    On Error Resume Next

    Dim a As Long
    Dim T As String
    
    If hConsOutput Or hConsInput Then Beep: Exit Sub
    
    'Create new console.
    AllocConsole

    'We need handles for in and output
    hConsInput = GetStdHandle(STD_INPUT_HANDLE)
    hConsOutput = GetStdHandle(STD_OUTPUT_HANDLE)

    'Set some attributes.
    SetConsoleMode hConsInput, ENABLE_ECHO_INPUT

    StdOut vbCrLf
    StdOut "Enter filename (with full path and extension) or 'EXIT' to close.." & vbCrLf
    StdOut vbCrLf

    Do

        a = 0
        StdOut CurDir$ & ">"

        'Retrieve
        T = InputCons()

        'You could use T$ to execute any (DOS)app.
        Select Case UCase$(T)
        Case "EXIT": Exit Do
        Case ""
        Case Else

            'You might extend Shell to use the search path.
            a = Shell(T, vbNormalFocus)
            If a Then

                'StdOut a & vbCrLf
                StdOut vbCrLf

            Else

                StdOut "Bad command or filename " & Chr$(34) & T & Chr$(34) & "  Type EXIT to close..." & vbCrLf & vbCrLf

            End If

        End Select

    Loop

    'This will close the console..
    FreeConsole

    hConsOutput = 0
    hConsInput = 0

End Sub
