Hosting console in VB6 form

[wqweto]

This time it comes with colors.



Place a Timer1 on Form1 and paste this code:

'--- Form1
Option Explicit
DefObj A-Z
Private Const MODULE_NAME As String = "Form1"

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

Private Declare Function AllocConsole Lib "kernel32" () As Long
Private Declare Function FreeConsole Lib "kernel32" () As Long
Private Declare Function GetConsoleWindow Lib "kernel32" () As Long
Private Declare Function SetConsoleCtrlHandler Lib "kernel32" (ByVal HandlerRoutine As Long, ByVal Add As Long) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileW" (ByVal lpFileName As Long, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetConsoleScreenBufferInfo Lib "kernel32" (ByVal hConsoleOutput As Long, lpInfo As CONSOLE_SCREEN_BUFFER_INFO) As Long
Private Declare Function SetConsoleScreenBufferSize Lib "kernel32" (ByVal hConsoleOutput As Long, ByVal dwSize As Long) As Long
Private Declare Function SetConsoleWindowInfo Lib "kernel32" (ByVal hConsoleOutput As Long, ByVal bAbsolute As Long, lpConsoleWindow As SMALL_RECT) As Long
Private Declare Function ReadConsoleOutput Lib "kernel32" Alias "ReadConsoleOutputW" (ByVal hConsoleOutput As Long, lpBuffer As Any, ByVal dwBufferSize As Long, ByVal dwBufferCoord As Long, lpReadRegion As SMALL_RECT) As Long
Private Declare Function WriteConsoleInput Lib "kernel32" Alias "WriteConsoleInputW" (ByVal hConsoleInput As Long, lpBuffer As INPUT_RECORD, ByVal nLength As Long, lpNumberOfEventsWritten As Long) As Long
Private Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" (ByVal lpApplicationName As String, ByVal lpCommandLine As String, ByVal lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As String, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CreateJobObject Lib "kernel32" Alias "CreateJobObjectW" (ByVal lpJobAttributes As Long, ByVal lpName As Long) As Long
Private Declare Function SetInformationJobObject Lib "kernel32" (ByVal hJob As Long, ByVal JobObjectInformationClass As Long, lpJobObjectInformation As Any, ByVal cbJobObjectInformationLength As Long) As Long
Private Declare Function AssignProcessToJobObject Lib "kernel32" (ByVal hJob As Long, ByVal hProcess As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nW As Long, ByVal nH As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hDC As Long, ByVal nBkMode As Long) As Long
Private Declare Function TextOutW Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As Long, ByVal nCount As Long) As Long
Private Declare Function GetTextMetrics Lib "gdi32" Alias "GetTextMetricsA" (ByVal hDC As Long, lpMetrics As TEXTMETRIC) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As Long, lpBitsInfo As Any, ByVal wUsage As Long, lpBits As Long, ByVal Handle As Long, ByVal dw As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" (ByVal uCode As Long, ByVal uMapType As Long) As Long
Private Declare Function GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long
Private Declare Function ToUnicode Lib "user32" (ByVal wVirtKey As Long, ByVal wScanCode As Long, lpKeyState As Byte, ByVal pwszBuff As Long, ByVal cchBuff As Long, ByVal wFlags As Long) As Long
'--- GDI+
Private Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As Any, ByVal outputbuf As Long) As Long
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hBitmap As Long, ByVal hPalette As Long, hGdipBmp As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As Long
Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal image As Long, ByVal fileName As Long, clsidEncoder As Any, encoderParams As Any) As Long

Private Type COORD
    X                   As Integer
    Y                   As Integer
End Type

Private Type SMALL_RECT
    Left                As Integer
    Top                 As Integer
    Right               As Integer
    Bottom              As Integer
End Type

Private Type RECT
    Left                As Long
    Top                 As Long
    Right               As Long
    Bottom              As Long
End Type

Private Type CONSOLE_SCREEN_BUFFER_INFO
    dwSize              As COORD
    dwCursorPosition    As COORD
    wAttributes         As Integer
    srWindow            As SMALL_RECT
    dwMaximumWindowSize As COORD
End Type

Private Type CHAR_INFO
    UnicodeChar         As Integer
    Attributes          As Integer
End Type

Private Type KEY_EVENT_RECORD
    bKeyDown            As Long
    wRepeatCount        As Integer
    wVirtualKeyCode     As Integer
    wVirtualScanCode    As Integer
    UnicodeChar         As Integer
    dwControlKeyState   As Long
End Type

Private Type INPUT_RECORD
    EventType           As Integer
    Padding             As Integer
    KeyEvent            As KEY_EVENT_RECORD
End Type

Private Type STARTUPINFO
    cb                  As Long
    lpReserved          As Long
    lpDesktop           As Long
    lpTitle             As Long
    dwX                 As Long
    dwY                 As Long
    dwXSize             As Long
    dwYSize             As Long
    dwXCountChars       As Long
    dwYCountChars       As Long
    dwFillAttribute     As Long
    dwFlags             As Long
    wShowWindow         As Integer
    cbReserved2         As Integer
    lpReserved2         As Long
    hStdInput           As Long
    hStdOutput          As Long
    hStdError           As Long
End Type

Private Type PROCESS_INFORMATION
    hProcess            As Long
    hThread             As Long
    dwProcessId         As Long
    dwThreadId          As Long
End Type

Private Type TEXTMETRIC
    tmHeight            As Long
    tmAscent            As Long
    tmDescent           As Long
    tmInternalLeading   As Long
    tmExternalLeading   As Long
    tmAveCharWidth      As Long
    tmMaxCharWidth      As Long
    tmWeight            As Long
    tmOverhang          As Long
    tmDigitizedAspectX  As Long
    tmDigitizedAspectY  As Long
    tmFirstChar         As Byte
    tmLastChar          As Byte
    tmDefaultChar       As Byte
    tmBreakChar         As Byte
    tmItalic            As Byte
    tmUnderlined        As Byte
    tmStruckOut         As Byte
    tmPitchAndFamily    As Byte
    tmCharSet           As Byte
End Type

Private Type BITMAPINFOHEADER
    biSize              As Long
    biWidth             As Long
    biHeight            As Long
    biPlanes            As Integer
    biBitCount          As Integer
    biCompression       As Long
    biSizeImage         As Long
    biXPelsPerMeter     As Long
    biYPelsPerMeter     As Long
    biClrUsed           As Long
    biClrImportant      As Long
End Type

Private Type JOBOBJECT_EXTENDED_LIMIT_INFORMATION
    '--- BasicLimitInformation
    PerProcessUserTimeLimit As Currency
    PerJobUserTimeLimit     As Currency
    LimitFlags              As Long
    MinimumWorkingSetSize   As Long
    MaximumWorkingSetSize   As Long
    ActiveProcessLimit      As Long
    Affinity                As Long
    PriorityClass           As Long
    SchedulingClass         As Long
    dwPadding1              As Long
    '--- IoInfo
    ReadOperationCount      As Currency
    WriteOperationCount     As Currency
    OtherOperationCount     As Currency
    ReadTransferCount       As Currency
    WriteTransferCount      As Currency
    OtherTransferCount      As Currency
    '--- rest
    ProcessMemoryLimit      As Long
    JobMemoryLimit          As Long
    PeakProcessMemoryUsed   As Long
    PeakJobMemoryUsed       As Long
End Type

'=========================================================================
' Constants and member vars
'=========================================================================

Private Const LNG_CONSOLE_COLS      As Long = 120
Private Const LNG_CONSOLE_ROWS      As Long = 30

Private m_uCtx                  As UcsConsoleContext
Private m_aColors(0 To 15)      As Long

Private Type UcsConsoleContext
    hConOut             As Long
    hConIn              As Long
    hMemDC              As Long
    hDib                As Long
    lpBits              As Long
    hOldDib             As Long
    Font                As IFont
    hOldFont            As Long
    CellWidth           As Long
    CellHeight          As Long
    BmpWidth            As Long
    BmpHeight           As Long
    ProcessInfo         As PROCESS_INFORMATION
    hJob                As Long
    CharInfo()          As CHAR_INFO
    ScreenInfo          As CONSOLE_SCREEN_BUFFER_INFO
End Type

Private Sub PrintError(sFunction As String)
    #If ImplUseDebugLog 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

Private Sub Form_Load()
    On Error GoTo EH
    Me.ScaleMode = vbPixels
    Me.KeyPreview = True
    Me.BackColor = vbBlack
    pvConsoleInit m_uCtx
    Me.Width = Me.Width - Me.ScaleWidth * Screen.TwipsPerPixelX + m_uCtx.BmpWidth * Screen.TwipsPerPixelX
    Me.Height = Me.Height - Me.ScaleHeight * Screen.TwipsPerPixelY + m_uCtx.BmpHeight * Screen.TwipsPerPixelY
    Timer1.Interval = 30
    Timer1.Enabled = True
    Exit Sub
EH:
    PrintError "Form_Load"
End Sub

Private Sub Timer1_Timer()
    On Error GoTo EH
    pvConsoleRender m_uCtx
    Form_Paint
    If m_uCtx.ProcessInfo.hProcess <> 0 Then
        If WaitForSingleObject(m_uCtx.ProcessInfo.hProcess, 0) = 0 Then
            Unload Me
        End If
    End If
    Exit Sub
EH:
    PrintError "Timer1_Timer"
End Sub

Private Sub Form_Paint()
    Const SRCCOPY           As Long = &HCC0020

    On Error GoTo EH
    Call BitBlt(Me.hDC, 0, 0, m_uCtx.BmpWidth, m_uCtx.BmpHeight, m_uCtx.hMemDC, 0, 0, SRCCOPY)
    SaveBitmapAsPng m_uCtx.hDib, Environ$("TEMP") & "\aaa.png"
    Exit Sub
EH:
    PrintError "Form_Paint"
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    On Error GoTo EH
    Select Case KeyCode + Shift * &H10000
    Case vbKeyF4 + vbAltMask * &H10000
        Exit Sub
    Case vbKeyV + vbCtrlMask * &H10000, vbKeyInsert + vbShiftMask * &H10000
        If Clipboard.GetFormat(vbCFText) Then
            pvConsoleSendText m_uCtx.hConIn, Clipboard.GetText()
        End If
    Case Else
        pvConsoleSendKey m_uCtx.hConIn, 0, KeyCode, Shift
    End Select
    KeyCode = 0
    Exit Sub
EH:
    PrintError "Form_KeyDown"
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    On Error GoTo EH
    If Button = vbRightButton Then
        Form_KeyDown vbKeyV, vbCtrlMask
    End If
    Exit Sub
EH:
    PrintError "Form_MouseDown"
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error GoTo EH
    Timer1.Enabled = False
    pvConsoleTerminate m_uCtx
    Exit Sub
EH:
    PrintError "Form_Unload"
End Sub

'= private ===============================================================

Private Function pvConsoleInit(uCtx As UcsConsoleContext) As Boolean
    Const SW_HIDE           As Long = 0
    Const GENERIC_READ      As Long = &H80000000
    Const GENERIC_WRITE     As Long = &H40000000
    Const FILE_SHARE_READ   As Long = 1
    Const FILE_SHARE_WRITE  As Long = 2
    Const OPEN_EXISTING     As Long = 3
    Const OPAQUE            As Long = 2
    Const DIB_RGB_COLORS    As Long = 0
    Const JobObjectExtendedLimitInformation As Long = 9
    Const JOB_OBJECT_LIMIT_KILL_ON_JOB_CLOSE As Long = &H2000
    Dim vSplit          As Variant
    Dim lIdx            As Long
    Dim uMetric         As TEXTMETRIC
    Dim uRect           As SMALL_RECT
    Dim uBmpHeader      As BITMAPINFOHEADER
    Dim uStartup        As STARTUPINFO
    Dim uLimit          As JOBOBJECT_EXTENDED_LIMIT_INFORMATION
    
    If m_aColors(15) = 0 Then
        vSplit = Split("&H0 &H800000 &H8000 &H808000 &H80 &H800080 &H8080 &HC0C0C0 &H808080 &HFF0000 &HFF00 &HFFFF00 &HFF &HFF00FF &HFFFF &HFFFFFF")
        For lIdx = 0 To 15
            m_aColors(lIdx) = vSplit(lIdx)
        Next
    End If
    With uCtx
        Call AllocConsole
        Call ShowWindow(GetConsoleWindow(), SW_HIDE)
        Call SetConsoleCtrlHandler(0, 1)
        .hConOut = CreateFile(StrPtr("CONOUT$"), GENERIC_READ Or GENERIC_WRITE, FILE_SHARE_READ Or FILE_SHARE_WRITE, 0, OPEN_EXISTING, 0, 0)
        .hConIn = CreateFile(StrPtr("CONIN$"), GENERIC_READ Or GENERIC_WRITE, FILE_SHARE_READ Or FILE_SHARE_WRITE, 0, OPEN_EXISTING, 0, 0)
        Call SetConsoleWindowInfo(.hConOut, 1, uRect)
        Call SetConsoleScreenBufferSize(.hConOut, MakeCoord(LNG_CONSOLE_COLS, LNG_CONSOLE_ROWS))
        uRect.Right = LNG_CONSOLE_COLS - 1
        uRect.Bottom = LNG_CONSOLE_ROWS - 1
        Call SetConsoleWindowInfo(.hConOut, 1, uRect)
        .hMemDC = CreateCompatibleDC(0)
        Set .Font = New StdFont
        .Font.Name = "Consolas"
        .Font.Size = 11
        .hOldFont = SelectObject(.hMemDC, .Font.hFont)
        Call GetTextMetrics(.hMemDC, uMetric)
        .CellWidth = uMetric.tmAveCharWidth
        .CellHeight = uMetric.tmHeight + uMetric.tmExternalLeading
        .BmpWidth = LNG_CONSOLE_COLS * .CellWidth
        .BmpHeight = LNG_CONSOLE_ROWS * .CellHeight
        With uBmpHeader
            .biSize = LenB(uBmpHeader)
            .biPlanes = 1
            .biBitCount = 32
            .biWidth = uCtx.BmpWidth
            .biHeight = -uCtx.BmpHeight
            .biSizeImage = (4 * uCtx.BmpWidth) * uCtx.BmpHeight
        End With
        .hDib = CreateDIBSection(.hMemDC, uBmpHeader, DIB_RGB_COLORS, .lpBits, 0, 0)
        .hOldDib = SelectObject(.hMemDC, .hDib)
        Call SetBkMode(.hMemDC, OPAQUE)
        ReDim .CharInfo(0 To LNG_CONSOLE_COLS * LNG_CONSOLE_ROWS - 1)
        uStartup.cb = LenB(uStartup)
        Call CreateProcess(vbNullString, "cmd.exe", 0, 0, 0, 0, 0, vbNullString, uStartup, .ProcessInfo)
        If .ProcessInfo.hProcess <> 0 Then
            .hJob = CreateJobObject(0, 0)
            If .hJob <> 0 Then
                uLimit.LimitFlags = JOB_OBJECT_LIMIT_KILL_ON_JOB_CLOSE
                Call SetInformationJobObject(.hJob, JobObjectExtendedLimitInformation, uLimit, LenB(uLimit))
                Call AssignProcessToJobObject(.hJob, .ProcessInfo.hProcess)
            End If
            '--- success
            pvConsoleInit = True
        End If
    End With
End Function

Private Sub pvConsoleRender(uCtx As UcsConsoleContext)
    Dim uPrevScreen     As CONSOLE_SCREEN_BUFFER_INFO
    Dim uPrevInfo()     As CHAR_INFO
    Dim uRegion         As SMALL_RECT
    Dim lRow            As Long
    Dim lCol            As Long
    Dim lIdx            As Long
    Dim lAttr           As Long
    Dim lLastFg         As Long
    Dim lLastBg         As Long
    Dim lCode           As Long
    Dim sChar           As String
    Dim lFg             As Long
    Dim lBg             As Long
    Dim uRect           As RECT
    Dim hBrush          As Long
    Dim bDirty          As Boolean
    
    With uCtx
        If .hConOut = 0 Then
            Exit Sub
        End If
        uPrevScreen = .ScreenInfo
        If GetConsoleScreenBufferInfo(.hConOut, .ScreenInfo) = 0 Then
            Exit Sub
        End If
        bDirty = uPrevScreen.dwCursorPosition.X <> .ScreenInfo.dwCursorPosition.X Or uPrevScreen.dwCursorPosition.Y <> .ScreenInfo.dwCursorPosition.Y
        uPrevInfo = .CharInfo
        uRegion.Right = LNG_CONSOLE_COLS - 1
        uRegion.Bottom = LNG_CONSOLE_ROWS - 1
        Call ReadConsoleOutput(.hConOut, .CharInfo(0), MakeCoord(LNG_CONSOLE_COLS, LNG_CONSOLE_ROWS), 0, uRegion)
        lLastFg = -1
        lLastBg = -1
        For lRow = 0 To LNG_CONSOLE_ROWS - 1
            For lCol = 0 To LNG_CONSOLE_COLS - 1
                lIdx = lRow * LNG_CONSOLE_COLS + lCol
                If uPrevInfo(lIdx).UnicodeChar <> .CharInfo(lIdx).UnicodeChar Or uPrevInfo(lIdx).Attributes <> .CharInfo(lIdx).Attributes _
                        Or bDirty And uPrevScreen.dwCursorPosition.X = lCol And uPrevScreen.dwCursorPosition.Y = lRow Then
                    lAttr = .CharInfo(lIdx).Attributes
                    lFg = m_aColors(lAttr And &HF)
                    lBg = m_aColors((lAttr \ &H10) And &HF)
                    If lFg <> lLastFg Then
                        Call SetTextColor(.hMemDC, lFg)
                        lLastFg = lFg
                    End If
                    If lBg <> lLastBg Then
                        Call SetBkColor(.hMemDC, lBg)
                        lLastBg = lBg
                    End If
                    lCode = .CharInfo(lIdx).UnicodeChar And &HFFFF&
                    If lCode = 0 Then
                        lCode = 32
                    End If
                    sChar = ChrW$(lCode)
                    Call TextOutW(.hMemDC, lCol * .CellWidth, lRow * .CellHeight, StrPtr(sChar), 1)
                    bDirty = True
                End If
            Next
        Next
        If bDirty Then
            uRect.Left = .ScreenInfo.dwCursorPosition.X * .CellWidth
            uRect.Right = uRect.Left + .CellWidth
            uRect.Bottom = (.ScreenInfo.dwCursorPosition.Y + 1) * .CellHeight
            uRect.Top = uRect.Bottom - 2
            hBrush = CreateSolidBrush(m_aColors(7))
            Call FillRect(.hMemDC, uRect, hBrush)
            Call DeleteObject(hBrush)
        End If
    End With
End Sub

Private Sub pvConsoleSendKey(ByVal hConIn As Long, ByVal lUnicodeChar As Long, ByVal lVk As Integer, ByVal Shift As Integer)
    Const SHIFT_PRESSED     As Long = &H10
    Const LEFT_CTRL_PRESSED As Long = &H8
    Const LEFT_ALT_PRESSED  As Long = &H4
    Const KEY_EVENT         As Long = 1
    Dim lScanCode       As Long
    Dim aKeys(0 To 255) As Byte
    Dim aBuf(0 To 7)    As Integer
    Dim lCount          As Long
    Dim lControlState   As Long
    Dim uRecord         As INPUT_RECORD
    Dim lWritten        As Long
    
    If hConIn = 0 Then
        Exit Sub
    End If
    If lUnicodeChar = 0 Then
        lScanCode = MapVirtualKey(lVk, 0)
        Call GetKeyboardState(aKeys(0))
        lCount = ToUnicode(lVk, lScanCode, aKeys(0), VarPtr(aBuf(0)), 8, 0)
        If lCount = 1 Then
            lUnicodeChar = aBuf(0)
        Else
            lUnicodeChar = 0
        End If
    ElseIf lUnicodeChar >= &H80 And lUnicodeChar <= &HFF Then
        lUnicodeChar = AscW(Chr$(lUnicodeChar))
    End If
    If (Shift And vbShiftMask) <> 0 Then
        lControlState = lControlState Or SHIFT_PRESSED
    End If
    If (Shift And vbCtrlMask) <> 0 Then
        lControlState = lControlState Or LEFT_CTRL_PRESSED
    End If
    If (Shift And vbAltMask) <> 0 Then
        lControlState = lControlState Or LEFT_ALT_PRESSED
    End If
    uRecord.EventType = KEY_EVENT
    With uRecord.KeyEvent
        .wRepeatCount = 1
        .wVirtualKeyCode = lVk
        .wVirtualScanCode = lScanCode And &HFFFF&
        .UnicodeChar = lUnicodeChar And &HFFFF&
        .dwControlKeyState = lControlState
        .bKeyDown = 1
    End With
    Call WriteConsoleInput(hConIn, uRecord, 1, lWritten)
    uRecord.KeyEvent.bKeyDown = 0
    Call WriteConsoleInput(hConIn, uRecord, 1, lWritten)
End Sub

Private Sub pvConsoleSendText(ByVal hConIn As Long, ByVal sText As String)
    Dim lIdx            As Long

    sText = Replace(Replace(sText, vbCrLf, vbCr), vbLf, vbCr)
    For lIdx = 1 To Len(sText)
        pvConsoleSendKey hConIn, AscW(Mid$(sText, lIdx, 1)), 0, 0
    Next
End Sub

Private Sub pvConsoleTerminate(uCtx As UcsConsoleContext)
    With uCtx
        If .ProcessInfo.hProcess <> 0 Then
            Call TerminateProcess(.ProcessInfo.hProcess, 0)
            Call CloseHandle(.ProcessInfo.hProcess)
            .ProcessInfo.hProcess = 0
        End If
        If .ProcessInfo.hThread <> 0 Then
            Call CloseHandle(.ProcessInfo.hThread)
            .ProcessInfo.hThread = 0
        End If
        If .hConOut <> 0 Then
            Call CloseHandle(.hConOut)
            .hConOut = 0
        End If
        If .hConIn <> 0 Then
            Call CloseHandle(.hConIn)
            .hConIn = 0
        End If
        If .hMemDC <> 0 Then
            Call SelectObject(.hMemDC, .hOldDib)
            Call SelectObject(.hMemDC, .hOldFont)
            Call DeleteObject(.hDib)
            .hDib = 0
            Call DeleteDC(.hMemDC)
            .hMemDC = 0
        End If
        If .hJob <> 0 Then
            Call CloseHandle(.hJob)
            .hJob = 0
        End If
'        Call FreeConsole
    End With
End Sub

Private Function MakeCoord(ByVal lX As Long, ByVal lY As Long) As Long
    MakeCoord = (lY And &HFFFF&) * &H10000 Or (lX And &HFFFF&)
End Function

Private Function SaveBitmapAsPng(ByVal hDib As Long, ByVal sFile As String) As Boolean
    Dim uStartup(0 To 3) As Long
    Dim hToken          As Long
    Dim hBitmap         As Long
    Dim uEncoder(0 To 3) As Long

    uStartup(0) = 1
    If GdiplusStartup(hToken, uStartup(0), 0) <> 0 Then
        Exit Function
    End If
    If GdipCreateBitmapFromHBITMAP(hDib, 0, hBitmap) = 0 Then
        uEncoder(0) = &H557CF406: uEncoder(1) = &H11D31A04      '--- {557CF406-1A04-11D3-9A73-0000F81EF32E}
        uEncoder(2) = &H739A&: uEncoder(3) = &H2EF31EF8
        If GdipSaveImageToFile(hBitmap, StrPtr(sFile), uEncoder(0), ByVal 0) = 0 Then
            SaveBitmapAsPng = True
        End If
        Call GdipDisposeImage(hBitmap)
    End If
    Call GdiplusShutdown(hToken)
End Function

Supports paste on right mouse click (no copy yet). Saves output bitmap to %TEMP%\aaa.png on each frame.

Win10+ only.

cheers,
</wqw>

[couttsj]

Thanks wqweto. That could be very useful.

J.A. Coutts

[couttsj]

Had difficulty in responding to your post. It turns out that it was waiting for "dl.unicontsoft.com". Just one of the many problems I have been having the last few days.

J.A. Coutts

[wqweto]

Btw, I already integrated this code into my VbVncServer so it now provides an additional virtual monitor which spawns a hidden administrative console and allows support staff to run maintenance commands without interrupting logged on users.



cheers,
</wqw>

[xxdoc123]

Btw, I already integrated this code into my VbVncServer so it now provides an additional virtual monitor which spawns a hidden administrative console and allows support staff to run maintenance commands without interrupting logged on users.



cheers,
</wqw>

It would be perfect if it could support Chinese strings.