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.
Hint: type exit to close console, cls to clear screen.
![]()
Here is the complete project zipped: EmbedConsole.zip
cheers,
</wqw>
Code:
'=========================================================================
'
' EmbedConsole (c) 2023 by wqweto@gmail.com
'
' 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
'=========================================================================
' Constants and member variables
'=========================================================================
Private WithEvents m_oText As TextBox
Private m_oExec As cExec
Private m_sInput 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 Sub pvInit(oText As TextBox, oExec As cExec)
Set m_oText = oText
Set m_oExec = oExec
m_oExec.Run "cmd", vbNullString, StartHidden:=True
#If ImpleUseMST Then
Set m_pTimer = InitFireOnceTimerThunk(Me, pvAddressOfTimerProc.TimerProc)
#Else
Timer1.Enabled = True
#End If
End Sub
Private Sub pvAppendText(ByVal sText As String)
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 = &H7FFF
If .SelStart + Len(sText) > &H7FFF& Then
sText = .Text & sText
.Text = Mid$(sText, InStr(Len(sText) - &H8000&, sText, vbCrLf) + 2)
Else
.SelText = sText
End If
HwndRedraw(.hWnd) = True
.SelStart = &H7FFF
m_lPos = .SelStart
.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
.SelStart = m_lPos + lIdx
HwndRedraw(.hWnd) = True
.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
End Sub
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
Public Function TimerProc() As Long
Const FUNC_NAME As String = "TimerProc"
Dim sText As String
On Error GoTo EH
If InStr(m_sInput, vbCrLf) > 0 Then
m_oExec.WriteInput m_sInput
m_sInput = vbNullString
m_oExec.ReadPendingOutput '--- flush echoed input
End If
sText = m_oExec.ReadPendingError & m_oExec.ReadPendingOutput
If LenB(sText) 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
'=========================================================================
' 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
' Debug.Print Hex(KeyCode + Shift * &H10000), "m_oText_KeyDown", Timer
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
' Debug.Print Hex(KeyAscii), "m_oText_KeyPress", Timer
lIdx = m_oText.SelStart - m_lPos
lSize = m_oText.SelLength
If KeyAscii = vbKeyEscape Then
m_sInput = vbNullString
lIdx = 0
ElseIf KeyAscii = vbKeyReturn Then
m_sInput = m_sInput & vbCrLf
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 < 32 Or KeyAscii = 255 Then
Exit Sub
Else
If lIdx + lSize < 0 Then
lIdx = Len(m_sInput)
End If
pvReplaceSelection lIdx, lSize, ChrW$(KeyAscii)
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"
On Error GoTo EH
pvInit Text1, New cExec
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
Here is the complete project zipped: EmbedConsole.zip
cheers,
</wqw>