[VB6] How to embed console in a VB6 form

[wqweto]

This is the cheapest implementation by using cExec redirection of input/output streams to emulate embedded console of cmd.exe into a black colored textbox on a VB6 form, much similar to how VS Code and other editors/IDEs have this in a panel.

'=========================================================================
'
' EmbedConsole (c) 2023 by [email protected]
'
' Emulates embedded console in a VB6 form
'
'=========================================================================
Option Explicit
DefObj A-Z
Private Const MODULE_NAME As String = "Form1"

#Const ImpleUseMST = False

'=========================================================================
' API
'=========================================================================

Private Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcW" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function NtQueryInformationProcess Lib "ntdll" (ByVal ProcessHandle As Long, ByVal InformationClass As Long, ByRef ProcessInformation As Any, ByVal ProcessInformationLength As Long, ByRef ReturnLength As Long) As Long
Private Declare Function ReadProcessMemory Lib "kernel32" (ByVal hProcess As Long, ByVal lpBaseAddress As Long, ByRef lpBuffer As Any, ByVal nSize As Long, ByRef lpNumberOfBytesWritten As Long) As Long

'=========================================================================
' Constants and member variables
'=========================================================================

Private WithEvents m_oText  As TextBox
Private m_oExec             As cExec
Private m_sInput            As String
Private m_sAutoComplete     As String
Private m_lPos              As Long
#If ImpleUseMST Then
    Private m_pTimer        As stdole.IUnknown
#End If

'=========================================================================
' Error handling
'=========================================================================

Private Sub PrintError(sFunction As String)
    #If USE_DEBUG_LOG <> 0 Then
        DebugLog MODULE_NAME, sFunction & "(" & Erl & ")", Err.Description & " &H" & Hex$(Err.Number), vbLogEventTypeError
    #Else
        Debug.Print "Critical error: " & Err.Description & " [" & MODULE_NAME & "." & sFunction & "]"
    #End If
End Sub

'=========================================================================
' Properties
'=========================================================================

#If ImpleUseMST Then
Private Property Get pvAddressOfTimerProc() As Form1
    Set pvAddressOfTimerProc = InitAddressOfMethod(Me, 0)
End Property
#End If

'=========================================================================
' Methods
'=========================================================================

Private Function pvInit(oText As TextBox, oExec As cExec, Optional Error As String) As Boolean
    Set m_oText = oText
    Set m_oExec = oExec
    If Not m_oExec.Run(Environ$("COMSPEC"), StartHidden:=True) Then
        Error = m_oExec.LastError
        GoTo QH
    End If
    #If ImpleUseMST Then
        Set m_pTimer = InitFireOnceTimerThunk(Me, pvAddressOfTimerProc.TimerProc)
    #Else
        Timer1.Enabled = True
    #End If
    '--- success
    pvInit = True
QH:
End Function

Private Sub pvAppendText(ByVal sText As String)
    Dim lPos            As Long
    
    If Left$(sText, 1) = Chr$(vbKeyClear) Then  '--- form feed
        m_oText.Text = vbNullString
        sText = Mid$(sText, 2)
    End If
    With m_oText
        HwndRedraw(.hWnd) = False
        .SelStart = m_lPos
        .SelLength = &H7FFF
        If .SelStart + Len(sText) > &H7FFF& Then
            sText = .Text & sText
            lPos = Len(sText) - &H7FFF& - 2
            If lPos < 1 Then
                lPos = 1
            End If
            .Text = Mid$(sText, InStr(lPos, sText, vbCrLf) + 2)
        Else
            .SelText = sText
        End If
        .SelStart = &H7FFF
        m_lPos = .SelStart
        .SelText = m_sInput
        HwndRedraw(.hWnd) = True
        .SelStart = &H7FFF
        .Refresh
    End With
End Sub

Private Sub pvAppendInput(ByVal sText As String, ByVal lIdx As Long)
    With m_oText
        HwndRedraw(.hWnd) = False
        .SelStart = m_lPos
        .SelLength = &H7FFF
        .SelText = sText
        HwndRedraw(.hWnd) = True
        .SelStart = m_lPos + lIdx
        .Refresh
    End With
End Sub

Private Sub pvReplaceSelection(lIdx As Long, ByVal lSize As Long, Optional sText As String)
    If lIdx < 0 Then
        lSize = lSize + lIdx
        lIdx = 0
    End If
    If lSize >= 0 Then
        m_sInput = Left$(m_sInput, lIdx) & sText & Mid$(m_sInput, lIdx + lSize + 1)
        lIdx = lIdx + Len(sText)
    End If
    m_sAutoComplete = vbNullString
End Sub

Private Function pvGetCurrentDir(ByVal hProcess As Long) As String
    Const ProcessBasicInformation           As Long = 0
    Const sizeof_PBI                        As Long = 6 * 4
    Const offsetof_ProcessParameters        As Long = &H10
    Const offsetof_CurrentDirectory         As Long = &H24
    Const sizeof_UNICODESTRING              As Long = 2 * 4
    Dim lPtr            As Long
    Dim aTemp(0 To 5)   As Long
    Dim sBuffer         As String
    
    If NtQueryInformationProcess(hProcess, ProcessBasicInformation, aTemp(0), sizeof_PBI, 0) < 0 Then
        GoTo QH
    End If
    If ReadProcessMemory(hProcess, aTemp(1) + offsetof_ProcessParameters, lPtr, 4, 0) = 0 Then
        GoTo QH
    End If
    If ReadProcessMemory(hProcess, lPtr + offsetof_CurrentDirectory, aTemp(0), sizeof_UNICODESTRING, 0) = 0 Then
        GoTo QH
    End If
    sBuffer = String$((aTemp(0) And &HFFFF&) \ 2, 0)
    If ReadProcessMemory(hProcess, aTemp(1), ByVal StrPtr(sBuffer), LenB(sBuffer), 0) = 0 Then
        GoTo QH
    End If
    pvGetCurrentDir = sBuffer
QH:
End Function

Private Function pvGetAutoComplete(ByVal sText As String, ByVal lIdx As Long) As String
    Dim lPos            As Long
    Dim sPath           As String
    
    If LenB(m_sAutoComplete) = 0 Then
        sText = Left$(sText, lIdx)
        lPos = InStrRev(sText, " """) + 2
        If lPos = 2 Then
            lPos = InStrRev(sText, " ") + 1
        End If
        sPath = Mid$(sText, lPos)
        If Mid$(sPath, 2, 1) <> ":" And Left$(sPath, 1) <> "\" Then
            sPath = PathCombine(pvGetCurrentDir(m_oExec.hProcess), sPath)
        End If
        m_sAutoComplete = Dir$(sPath & "*", vbDirectory Or vbArchive)
        Do While m_sAutoComplete = "." Or m_sAutoComplete = ".."
            m_sAutoComplete = Dir$
        Loop
        If LenB(m_sAutoComplete) <> 0 Then
            If InStrRev(sText, "\") > lPos Then
                lPos = InStrRev(sText, "\") + 1
            End If
            sText = Left$(sText, lPos - 1)
        End If
    Else
        lPos = Len(m_sAutoComplete)
        m_sAutoComplete = Dir$
        If LenB(m_sAutoComplete) <> 0 Then
            sText = Left$(sText, Len(sText) - lPos)
        End If
    End If
    pvGetAutoComplete = sText & m_sAutoComplete
End Function

Public Function TimerProc() As Long
    Const FUNC_NAME     As String = "TimerProc"
    Dim lPos            As Long
    Dim sEcho           As String
    Dim sText           As String
    
    On Error GoTo EH
    lPos = InStr(m_sInput, vbCrLf)
    Do While lPos > 0
        m_oExec.WriteInput Left$(m_sInput, lPos + 1)
        sEcho = m_oExec.ReadOutput(lPos + 1, TimeoutMs:=100)  '--- flush echoed input
        If sEcho <> Left$(m_sInput, lPos + 1) Then
            sText = sText & sEcho
        End If
        m_lPos = m_lPos + lPos + 2
        m_sInput = Mid$(m_sInput, lPos + 2)
        lPos = InStr(m_sInput, vbCrLf)
    Loop
    sText = sText & m_oExec.ReadPendingError & m_oExec.ReadPendingOutput
    If LenB(sText) <> 0 Then
        pvAppendText sText
    ElseIf m_oExec.AtEndOfOutput() Then
        Unload Me
    End If
    #If ImpleUseMST Then
        Set m_pTimer = InitFireOnceTimerThunk(Me, pvAddressOfTimerProc.TimerProc)
    #End If
    Exit Function
EH:
    PrintError FUNC_NAME
    Resume Next
End Function

'= shared ================================================================

Property Let HwndRedraw(ByVal hWnd As Long, ByVal bValue As Boolean)
    Const WM_SETREDRAW                  As Long = &HB
    If hWnd <> 0 Then
        Call DefWindowProc(hWnd, WM_SETREDRAW, -bValue, ByVal 0)
    End If
End Property

Private Function PathCombine(sPath As String, sFile As String) As String
    PathCombine = sPath & IIf(LenB(sPath) <> 0 And Right$(sPath, 1) <> "\" And LenB(sFile) <> 0, "\", vbNullString) & sFile
End Function

'=========================================================================
' Control events
'=========================================================================

Private Sub m_oText_KeyDown(KeyCode As Integer, Shift As Integer)
    Const FUNC_NAME     As String = "m_oText_KeyDown"
    Dim lIdx            As Long
    Dim lSize           As Long
    
    On Error GoTo EH
    lIdx = m_oText.SelStart - m_lPos
    lSize = m_oText.SelLength
    Select Case KeyCode + Shift * &H10000
    Case vbKeyC + vbCtrlMask * &H10000
        If lSize > 0 Then
            Clipboard.SetText m_oText.SelText
        End If
    Case vbKeyV + vbCtrlMask * &H10000, vbKeyInsert + vbShiftMask * &H10000
        If lIdx + lSize < 0 Then
            lIdx = Len(m_sInput)
        End If
        pvReplaceSelection lIdx, lSize, Clipboard.GetText
        pvAppendInput m_sInput, lIdx
    Case vbKeyDelete
        If lSize > 0 Then
            pvReplaceSelection lIdx, lSize
        Else
            If lIdx < 0 Then
                lIdx = 0
            End If
            pvReplaceSelection lIdx, 1
        End If
        pvAppendInput m_sInput, lIdx
    End Select
    Exit Sub
EH:
    PrintError FUNC_NAME
End Sub

Private Sub m_oText_KeyPress(KeyAscii As Integer)
    Const FUNC_NAME     As String = "m_oText_KeyPress"
    Dim lIdx            As Long
    Dim lSize           As Long
    
    On Error GoTo EH
    lIdx = m_oText.SelStart - m_lPos
    lSize = m_oText.SelLength
    If KeyAscii = vbKeyEscape Then
        m_sInput = vbNullString
        m_sAutoComplete = vbNullString
        lIdx = 0
    ElseIf KeyAscii = vbKeyReturn Then
        m_sInput = m_sInput & vbCrLf
        m_sAutoComplete = vbNullString
    ElseIf KeyAscii = vbKeyBack Then
        If lIdx + lSize < 0 Then
            lIdx = Len(m_sInput)
        ElseIf lSize > 0 Then
            pvReplaceSelection lIdx, lSize
        Else
            lIdx = lIdx - 1
            pvReplaceSelection lIdx, 1
        End If
    ElseIf KeyAscii = vbKeyTab Then
        If lIdx + lSize < 0 Then
            lIdx = Len(m_sInput)
        Else
            lIdx = lIdx + lSize
        End If
        m_sInput = pvGetAutoComplete(m_sInput, lIdx)
        lIdx = Len(m_sInput)
    ElseIf KeyAscii < 32 Or KeyAscii = 255 Then
        Exit Sub
    Else
        If lIdx + lSize < 0 Then
            lIdx = Len(m_sInput)
        End If
        If KeyAscii < 256 Then
            pvReplaceSelection lIdx, lSize, Chr$(KeyAscii)
        Else
            pvReplaceSelection lIdx, lSize, ChrW$(KeyAscii)
        End If
    End If
    pvAppendInput m_sInput, lIdx
    Exit Sub
EH:
    PrintError FUNC_NAME
End Sub

Private Sub Form_Load()
    Const FUNC_NAME     As String = "Form_Load"
    Dim sError          As String
    
    On Error GoTo EH
    If Not pvInit(Text1, New cExec, sError) Then
        MsgBox sError, vbCritical
        Unload Me
    End If
    Exit Sub
EH:
    PrintError FUNC_NAME
End Sub

Private Sub Form_Resize()
    Const FUNC_NAME     As String = "Form_Resize"
    
    On Error GoTo EH
    If WindowState <> vbMinimized Then
        m_oText.Move 0, 0, ScaleWidth, ScaleHeight
    End If
    Exit Sub
EH:
    PrintError FUNC_NAME
End Sub

Private Sub Timer1_Timer()
    TimerProc
End Sub

Hint: type exit to close console, cls to clear screen, use Tab key to auto-complete, Esc to clear input.



Here is the complete project zipped: EmbedConsole7.zip

cheers,
</wqw>

[yokesee]

good job wqweto.

[rboeck]

Hi,

i miss the file from this line in the project file: Class=cExec; ..\..\UcsFP20\src\UcsFP20\Shared\cExec.cls

Thanks,
Reinhard

[jpbro]

Hi,

i miss the file from this line in the project file: Class=cExec; ..\..\UcsFP20\src\UcsFP20\Shared\cExec.cls

Thanks,
Reinhard

Check the link in the first sentence of the first post.

[wqweto]

Hi,

i miss the file from this line in the project file: Class=cExec; ..\..\UcsFP20\src\UcsFP20\Shared\cExec.cls

Thanks,
Reinhard

Ooops, this is so bad. . .

Fixed! Link to complete project in first post.

cheers,
</wqw>

[xxdoc123]

thanks，Your code is great

I made a little modification as per my needs

Private Declare Function WriteFile _
                Lib "kernel32" (ByVal hFile As Long, _
                                ByVal lpBuf As Long, _
                                ByVal cToWrite As Long, _
                                ByRef cWritten As Long, _
                                ByVal lpOverlapped As Any) As Long

Public Function WriteInput(sValue As String) As Boolean
    Dim lWritten As Long
    
    Dim BtTest() As Byte
    Dim Buflen   As Long

    BtTest = StrConv(sValue, vbFromUnicode)
    Buflen = UBound(BtTest) + 1
    
    If m_hWriteInput <> 0 Then
         
        If WriteFile(m_hWriteInput, StrPtr(BtTest), Buflen, lWritten, 0&) <> 0 Then
            Call FlushFileBuffers(m_hWriteInput)
            WriteInput = True
        End If
    End If

End Function

[wqweto]

thanks，Your code is great

I made a little modification as per my needs

Private Declare Function WriteFile _
                Lib "kernel32" (ByVal hFile As Long, _
                                ByVal lpBuf As Long, _
                                ByVal cToWrite As Long, _
                                ByRef cWritten As Long, _
                                ByVal lpOverlapped As Any) As Long

Public Function WriteInput(sValue As String) As Boolean
    Dim lWritten As Long
    
    Dim BtTest() As Byte
    Dim Buflen   As Long

    BtTest = StrConv(sValue, vbFromUnicode)
    Buflen = UBound(BtTest) + 1
    
    If m_hWriteInput <> 0 Then
         
        If WriteFile(m_hWriteInput, StrPtr(BtTest), Buflen, lWritten, 0&) <> 0 Then
            Call FlushFileBuffers(m_hWriteInput)
            WriteInput = True
        End If
    End If

End Function

Fixed this using CharToOemBuffA API instead of StrConv as it was not working here w/ cyrillic characters unless using the correct API in WriteInput.

cheers,
</wqw>

[xxdoc123]

Fixed this using CharToOemBuffA API instead of StrConv as it was not working here w/ cyrillic characters unless using the correct API in WriteInput.

cheers,
</wqw>

thanks

Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long

Public Function WriteInput(sValue As String) As Boolean
    Dim baBuffer()      As Byte
    Dim lWritten        As Long
    
    'ReDim baBuffer(0 To Len(sValue)) As Byte
   
     ReDim baBuffer(0 To lstrlen (sValue)) As Byte

    Call CharToOemBuffA(sValue, baBuffer(0), UBound(baBuffer) + 1)
    If m_hWriteInput <> 0 Then
        If WriteFile(m_hWriteInput, baBuffer(0), UBound(baBuffer), lWritten, 0) <> 0 Then
            WriteInput = True
        End If
    End If
End Function

[wqweto]

What is the point of using lstrlen API instead of builtin Len function? Does it return different size on far-eastern locales?

Such lstrlen API declare would use ANSI<->Unicode trancoding that VB6 does on ByVal ... As String parameters which should not differ from StrConv(..., vbFromUnicode) but I've not tested this on far-eastern locales.

cheers,
</wqw>

[xxdoc123]

What is the point of using lstrlen API instead of builtin Len function? Does it return different size on far-eastern locales?

Such lstrlen API declare would use ANSI<->Unicode trancoding that VB6 does on ByVal ... As String parameters which should not differ from StrConv(..., vbFromUnicode) but I've not tested this on far-eastern locales.

cheers,
</wqw>

len（“123好”）=4
lstrlen（“123好”）=5

[wqweto]

This totally makes sense on second read. My assumption that a Unicode string would have exactly Len characters when converted to Multibyte character set is completely wrong and this works in very specific cases only.

The correct way would be to first query how many bytes output buffer needs to have for the conversion to succeed like WideCharToMultiByte API but unfortunately both CharToOemBuffA and OemToCharBuffA are legacy ones that are not instrumented to facilitate this. What they expect is that output buffer can overlap/conincide with input buffer i.e. CP_ACP<->CP_OEM conversion does not increase/reduce output buffer size and can be done in-place.

And this is what the latest WriteInput impl uses

    baBuffer = StrConv(sValue, vbFromUnicode, LOCALE_SYSTEM_DEFAULT)
    Call CharToOemBuffA(baBuffer(0), baBuffer(0), UBound(baBuffer) + 1)

.... i.e. convert to CP_ACP with built-in StrConv and then in-place convert CP_ACP->CP_OEM using CharToOemBuffA API.

JFYI, using StrConv w/o specifying 3-rd (locale) parameter uses LOCALE_USER_DEFAULT which is different than API declares calling ByVal .. As String and most of the ANSI controls.

cheers,
</wqw>

[xxdoc123]

This totally makes sense on second read. My assumption that a Unicode string would have exactly Len characters when converted to Multibyte character set is completely wrong and this works in very specific cases only.

The correct way would be to first query how many bytes output buffer needs to have for the conversion to succeed like WideCharToMultiByte API but unfortunately both CharToOemBuffA and OemToCharBuffA are legacy ones that are not instrumented to facilitate this. What they expect is that output buffer can overlap/conincide with input buffer i.e. CP_ACP<->CP_OEM conversion does not increase/reduce output buffer size and can be done in-place.

And this is what the latest WriteInput impl uses

    baBuffer = StrConv(sValue, vbFromUnicode, LOCALE_SYSTEM_DEFAULT)
    Call CharToOemBuffA(baBuffer(0), baBuffer(0), UBound(baBuffer) + 1)

.... i.e. convert to CP_ACP with built-in StrConv and then in-place convert CP_ACP->CP_OEM using CharToOemBuffA API.

JFYI, using StrConv w/o specifying 3-rd (locale) parameter uses LOCALE_USER_DEFAULT which is different than API declares calling ByVal .. As String and most of the ANSI controls.

cheers,
</wqw>

Worked perfectly, thank you

[fafalone]

Link is broken

[wqweto]

Btw, this sample is completely superseded by https://www.vbforums.com/showthread....le-in-VB6-form submission.

cheers,
</wqw>