[VB6] How to embed console in a VB6 form
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.
Code:
'=========================================================================
'
' 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.
https://www.vbforums.com/images/ieimages/2023/11/12.png
Here is the complete project zipped: EmbedConsole7.zip
cheers,
</wqw>
Re: [VB6] How to embed console in a VB6 form
Re: [VB6] How to embed console in a VB6 form
Hi,
i miss the file from this line in the project file: Class=cExec; ..\..\UcsFP20\src\UcsFP20\Shared\cExec.cls
Thanks,
Reinhard
Re: [VB6] How to embed console in a VB6 form
Quote:
Originally Posted by
rboeck
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.
Re: [VB6] How to embed console in a VB6 form
Quote:
Originally Posted by
rboeck
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>
Re: [VB6] How to embed console in a VB6 form
thanks，Your code is great
I made a little modification as per my needs
Code:
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
Re: [VB6] How to embed console in a VB6 form
Quote:
Originally Posted by
xxdoc123
thanks，Your code is great
I made a little modification as per my needs
Code:
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>
Re: [VB6] How to embed console in a VB6 form
Quote:
Originally Posted by
wqweto
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
Code:
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
Re: [VB6] How to embed console in a VB6 form
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>
Re: [VB6] How to embed console in a VB6 form
Quote:
Originally Posted by
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>
len（“123好”）=4
lstrlen（“123好”）=5
Re: [VB6] How to embed console in a VB6 form
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
Code:
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>
Re: [VB6] How to embed console in a VB6 form
Quote:
Originally Posted by
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
Code:
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
Re: [VB6] How to embed console in a VB6 form
Re: [VB6] How to embed console in a VB6 form
Btw, this sample is completely superseded by https://www.vbforums.com/showthread....le-in-VB6-form submission.
cheers,
</wqw>
