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, use Tab key to auto-complete, Esc to clear input.
![]()
Here is the complete project zipped: EmbedConsole6.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
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
Here is the complete project zipped: EmbedConsole6.zip
cheers,
</wqw>