VBForums - CodeBank - Visual Basic 6 and earlier

Hosting console in VB6 form

wqweto — Sat, 30 May 2026 18:35:48 GMT

This time it comes with colors.

Place a Timer1 on Form1 and paste this code:

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,

[VB6, VBA, twinBASIC] Intro to Vectored Exception Handling: Crash-proof CopyMemory

fafalone — Sat, 23 May 2026 08:11:55 GMT

It's been a long standing problem that access violations like a bad address for CopyMemory and other exceptions can't be handled by On Error. One solution to that is Vectored Exception Handling (VEH). You can register a procedure to handle true exceptions like access violations, then set it to skip the offending instruction.

This is a small module to introduce the concept that allows you to call CopyMemory safely, your app will not crash even if you supply an invalid address. If an invalid address is provided, the operation is skipped and it returns False.

This works by modifying the CONTEXT structure, which contains among other things the contents of all registers (where things like arguments and return values are actually stored at the assembly code/hardware level), including the instruction pointer register that tells the system exactly what instruction is executing- Eip for 32bit, Rip for 64bit. If an access violation is encountered, we skip the instruction by adding the instruction size-- this is where it gets the most complicated, and to be honest I used Claude AI for the functions to calculate the length, and don't totally understand it, since it's dynamic at runtime and not just looking at the disassembly on disk.

Requirements: This is a standalone module with no dependencies.
The definitions were copied from Windows Development Library for twinBASIC, so if you use that package, you can remove all the declares/types/enums/consts.

Usage Just add modSafeCopy.bas to your project and use CopyMemorySafe in place of CopyMemory. Note you'll have to use VarPtr/StrPtr/ObjPtr since neither VB6 nor tB supports As Any in local functions. You can also use CopyMemorySafe as a function, if the copy is successful without being passed a null pointer and without an exception it returns True.

NOTE: In twinBASIC this currently only works in compiled exes.

Important: For VBA, the document must be saved in a Trusted Location

Download on GitHub

Attached Images

VB6 - Add-in tools

joaquim — Thu, 21 May 2026 13:23:33 GMT

i updated the Tab-strip add-in:
1 - added the windows maximizated, but, seems, these part autor add it on another version: https://www.vbforums.com/showthread....sing-hooking);
2 - added: when we create a form the AutoRedraw is True and ScaleMode is pixels;
3 - added some nice classes(Pixels(GDIPlus), image(DIB's), and more)\functions(APIDoEvents())(add the DLL with Project-References for use them).. PS: we can't use the CConsole class with a form(the form will freeze until we close the Console);
the VB6 can be Absolete, but i love it and we can make allmost everything with it ;)
TabStrip Addin.zip

Attached Files

TabStrip Addin.zip (118.4 KB)

VB6 - Console Project Template

joaquim — Thu, 21 May 2026 13:13:02 GMT

heres my class and a standard\template project.... for be added on VB6 type projects..
add these project on: C:\Program Files (x86)\Microsoft Visual Studio\VB98\Template\Projects (where the VS98 was installed)
Console.zip
do we need VBW and VBF files?
heres a sample:

Code:

Option Explicit



Dim Console As New CConsole



Sub Main()

    'your code goes here:



    Console.Writes "Hello World!!!" 

    Console.Read 'pauses here until enter

    Set Console = Nothing 'clear object

End Sub

Attached Files

Console.zip (4.6 KB)

[VBA/VB6] COM prototyping and monkey patching without dlls

n013 — Tue, 19 May 2026 11:01:00 GMT

For those who daily struggle against the limitations imposed by VBA/VB6 regarding class inheritance, polymorphism, and advanced methods for arrays and objects, as well as for those who have found areas of code that could be handled more elegantly and concisely with more expressive syntax, and for those who have dreamed of safely modifying the behavior of certain DLLs at runtime without code injection or enforced memory protection, today I present the Advanced Scripting Framework (ASF), an abstract runtime layer that even includes its own independent regular expression engine.

Below is an example of what is possible to achieve in a limited language like VBA.

Code:

    // prototypes.vas

    export prototype.COM.Range addStyle(color) {

        this.Interior.Color = color;

    };

    

    export prototype.COM.Worksheet highlight(rng, color) {

        rng.addStyle(color);

    };

    

    // main_prototype.vas

    scwd(wd);

    import { Range_addStyle, Worksheet_highlight } from './prototypes.vas';

    // Prototypes are live immediately after import

    let ws = $1.ActiveSheet;

    let rng = ws.Range('J1:L3');

    rng.addStyle(65535);          // yellow

    ws.highlight(rng, 255);       // red

    return rng.Interior.Color

Here is the driving VBA code:

Code:

    Private Sub module_system_prototype_imports()

        Dim result As Long

        Dim wd As String

        Dim eng As New ASF

        wd = ThisWorkbook.path

        With eng

            .AppAccess = True

            .InjectVariable "wd", wd

            result = CLng(.Execute(wd & "\main_prototype.vas", ThisWorkbook))

        End With

        'Expected: 255

    End Sub

And here is the execution trace:

Code:

    === Runtime Log ===

    RUN Program: 

    CALL: ActiveSheet() -> 

    CALL: range('J1:L3') -> 

    CALL: addstyle(65535) -> 

    CALL: __PROTOTYPE_RANGE_ADDSTYLE(65535) -> 

    CALL: Interior() -> 

    CALL: highlight(, 255) -> 

    CALL: __PROTOTYPE_WORKSHEET_HIGHLIGHT(, 255) -> 

    CALL: addstyle(255) -> 

    CALL: __PROTOTYPE_RANGE_ADDSTYLE(255) -> 

    CALL: Interior() -> 

    CALL: Interior() -> 

    CALL: Color() -> 255

    CALL: @anon() -> 255

ASF comes with 233 Ruberduck tests and its regex engine has over 190 tests. Community testing is now welcome!

Tiny midiplayer

anycoder — Fri, 15 May 2026 07:08:40 GMT

This demonstration shows how to extract basic data from a MIDI file. Currently, it only handles musical information, which can be used to isolate a specific channel or synchronize with other applications or even hardware.

A+

Attached Files

MidiPlayer.zip (7.4 KB)

ai4vb - Ai integration

dz32 — Wed, 13 May 2026 23:24:33 GMT

This is a small project that shows how you can integrate the Claude or ChatGPT api into your programs.

The main classes can be use in many ways. This example shows how to give the AI access to your programs data / API so it can automate your app and generate reports or do searches.

We do this by adding our programs classes to the msscript control, and then giving the AI access to probe and query it. We have designed a way that the AI can automatically discover our API surface then access it dynamically with javascript.

We use an auto generated dump of our class public prototypes to show whats available. There is a source code parser included to create these dumps by pointing it at the project file. If you wanted to keep some api private from the AI you could modify the parser to add function decorators as comments to omit them.

There is a readme.md included and more discussion here: https://sandsprite.com/papers/Agenti...ect_Models.pdf

You will need to generate your own API key for Claude and or Chatgpt to use this. Kinda fun.

repo: https://github.com/dzzie/ai4vb

edit:
added optional async=false
added image analysis example
added database analysis example

Attached Files

ai4vb.zip (417.8 KB)