VBForums

FolderExists Issue

k_zeon — Wed, 03 Jun 2026 16:40:33 GMT

Hi All

I recently started to get some errors in my Folderexists function. If the Folder name was not the same case it would cause it to return False.

Code:

Private Const MAX_PATH As Long = 260

Private Const INVALID_HANDLE_VALUE As Long = -1

Private Const FILE_ATTRIBUTE_DIRECTORY As Long = &H10



Private Type FILETIME

    dwLowDateTime As Long

    dwHighDateTime As Long

End Type





Private Type WIN32_FIND_DATA

    dwFileAttributes As Long

    ftCreationTime As FILETIME

    ftLastAccessTime As FILETIME

    ftLastWriteTime As FILETIME

    nFileSizeHigh As Long

    nFileSizeLow As Long

    dwReserved0 As Long

    dwReserved1 As Long

    cFileName As String * MAX_PATH

    cAlternate As String * 14

End Type







Private Declare Function FindFirstFile Lib "kernel32" _

() '                                       Alias "FindFirstFileA" _

                                       (ByVal lpFileName As String, _

                                        lpFindFileData As WIN32_FIND_DATA) As Long



Private Declare Function FindClose Lib "kernel32" _

() '                                   (ByVal hFindFile As Long) As Long







Public Function FolderExists(sFolder As String) As Boolean



    Dim hFile As Long

    Dim WFD As WIN32_FIND_DATA



    'remove training slash before verifying

    sFolder = UnQualifyPath(sFolder)



    'call the API pasing the folder

    hFile = FindFirstFile(sFolder, WFD)



    'if a valid file handle was returned,

    'and the directory attribute is set

    'the folder exists

    FolderExists = (hFile <> INVALID_HANDLE_VALUE) And _

                   (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY)



    'clean up

    Call FindClose(hFile)



End Function



Private Function UnQualifyPath(ByVal sFolder As String) As String



'trim and remove any trailing slash

    sFolder = Trim$(sFolder)



    If Right$(sFolder, 1) = "\" Then

        UnQualifyPath = Left$(sFolder, Len(sFolder) - 1)

    Else

        UnQualifyPath = sFolder

    End If



End Function

i then swapped to

Code:

Private Declare Function PathIsDirectory Lib "shlwapi.dll" Alias "PathIsDirectoryA" _

(ByVal pszPath As String) As Long





Public Function FolderExists(ByVal sFolder As String) As Boolean

    FolderExists = PathIsDirectory(sFolder)

End Function

and it works fine.

Why would the first example now say False if case is incorrect but the folder path is correct.

tks

mousemove and treeview

luca90 — Wed, 03 Jun 2026 14:15:25 GMT

how to, intercept when mousemove cursor go to node key to another node key:

nodekey =1
next move
nodekey =1
no effect

node key=1
next move
node key=a1
then msgbox ="different node!"

VB6 2-nd pass compiler error on BAS module

wqweto — Tue, 02 Jun 2026 19:59:05 GMT

Sharing this Claude generated tool here (to not get it lost) which finds procedures with useless On Error GoTo 0 which trip up VB6 compiler's codegen and result in linker error i.e. the binary produced is non-functional because of 2-nd pass codegen the compiler bombs out. The problem is exacerbated when line numbers are used with such extraneous On Error GoTo 0 i.e. compiling production code with Erl support for error handling might bomb on build server.

Here is the powershell script that you might want to check you projects for potential problems:

Code:

# Find-DanglingOnErrorGoto0.ps1



param(

    [string]$Path

)



# Finds VB6 procedures that have `On Error GoTo 0` but do NOT have a real

# error handler (neither `On Error GoTo ` nor `On Error Resume Next`).



if (-not $Path) {

    @"

Find-DanglingOnErrorGoto0.ps1 - Find VB6 procedures with a dangling 'On Error GoTo 0'.



Reports procedures that contain 'On Error GoTo 0' but never install a real error

handler ('On Error GoTo ' or 'On Error Resume Next') before it.



Usage:

    .\Find-DanglingOnErrorGoto0.ps1 -Path 



Parameters:

    -Path   Folder (searched recursively) or file to scan. Scans *.bas, *.cls,

            *.frm and *.ctl files.



Example:

    .\Find-DanglingOnErrorGoto0.ps1 -Path C:\Projects\MyVB6App

"@ | Write-Output

    return

}



$reProcStart = '^\s*(?:(?:Public|Private|Friend|Static)\s+)*(?:Sub|Function|Property\s+(?:Get|Let|Set))\s+(\w+)'

$reProcEnd   = '^\s*End\s+(?:Sub|Function|Property)\b'

$reGoto0     = '^\s*On\s+Error\s+GoTo\s+0\s*$'

$reResume    = '^\s*On\s+Error\s+Resume\s+Next\b'

$reGotoLabel = '^\s*On\s+Error\s+GoTo\s+(?!0\s*$)\S+'



$files = Get-ChildItem -Path $Path -Recurse -Include *.bas, *.cls, *.frm, *.ctl -File

$results = foreach ($f in $files) {

    $lines = Get-Content -LiteralPath $f.FullName

    $inProc = $false

    $procName = ''

    $procStartLine = 0

    $handlerInstalled = $false   # is a handler active AT THIS POINT

    $danglingLines = @()         # On Error GoTo 0 with no active handler before it



    for ($i = 0; $i -lt $lines.Count; $i++) {

        $line = $lines[$i]

        $lineNo = $i + 1



        if (-not $inProc) {

            $m = [regex]::Match($line, $reProcStart, 'IgnoreCase')

            if ($m.Success) {

                $inProc = $true

                $procName = $m.Groups[1].Value

                $procStartLine = $lineNo

                $handlerInstalled = $false

                $danglingLines = @()

            }

            continue

        }



        if ($line -imatch $reProcEnd) {

            if ($danglingLines.Count -gt 0) {

                [pscustomobject]@{

                    File      = $f.FullName

                    Procedure = $procName

                    ProcLine  = $procStartLine

                    Goto0At   = ($danglingLines -join ',')

                }

            }

            $inProc = $false

            continue

        }



        if ($line -imatch $reResume -or $line -imatch $reGotoLabel) {

            $handlerInstalled = $true       # installs a handler for the rest of the procedure

        } elseif ($line -imatch $reGoto0) {

            # flag only if NO handler was installed anywhere earlier in the procedure;

            # sticky flag, because due to branching (each GoTo 0 sits in a separate branch,

            # followed by Err.Raise/Exit) the top-level handler is actually active on the path

            if (-not $handlerInstalled) { $danglingLines += $lineNo }

        }

    }

}



$results = @($results)

if ($results.Count -gt 0) {

    $results | Sort-Object File, ProcLine | Format-Table -AutoSize

    "Total: $($results.Count) procedure(s) with dangling 'On Error GoTo 0'." | Write-Output

} else {

    "None found." | Write-Output

}

cheers,

Read from Registry to ListView1

scot-65 — Tue, 02 Jun 2026 17:54:37 GMT

I am trying to populate a 2-column ListView using the registry key and data. I am able to "build" the listview and save to the registry. The first column of the list view is the registry subkey and the second column is the data.

This project sat idle for over 13 years and I am basically self-taught. Things have changed.

List View owner draw is true.
rootB is Public const = "HKCU\software\my sorter."
Registry is read from at this time.
There are currently 2 keys (profiles) where each key has 2 subkeys with assigned values (test mode).
The profile argument is the last saved profile.
There are stray comments that have not been removed - my apologies.
Program has issues at the line "GetSubKeyNames()".

Code:

   Private Sub GetREG(ByRef profile As String)

      'If Registry.GetValue(rootB + "\" + profile, "", Nothing) <> Nothing Then



      'clear the ListView box

      ListView1.Items.Clear()



      'rebuild the ListView box

      MessageBox.Show("Profile in argument: " + profile) '===OK.



      Dim RegKey As RegistryKey = Registry.CurrentUser.OpenSubKey("SOFTWARE\My Sorter\" + profile)

      For Each Subkey As String In RegKey.GetSubKeyNames()

         'For Each Subkey In Subkeys

         Dim tempkey As RegistryKey = RegKey.OpenSubKey(Subkey)

         MessageBox.Show("subkey name: ", Subkey)

         'ListView1.Items.Add(Subkey, Registry.GetValue(rootB + "\" + profile, Subkey, ""))



         Dim listItem As New ListViewItem(tempkey.ToString)

         listItem.SubItems.Add(Registry.GetValue(rootB + "\" + profile, tempkey.ToString, ""))

         ListView1.Items.Add(listItem)



      Next

      RegKey.Close()



      'Else

      'MessageBox.Show("No GetValue: " + profile)

      'End If



   End Sub

Nested parenthesis is nothing new to me and I will be able to do so if given the chance.

Show tool tip ballon on each node of a treeview

luca90 — Tue, 02 Jun 2026 17:26:01 GMT

Possibile?
Tks

ADD also a baloon tooltip on treeview

luca90 — Tue, 02 Jun 2026 09:18:31 GMT

i use this code on mosenove treewviev:

Code:

Private Sub TreeView1_MouseMove(Button As Integer, Shift As _

                                Integer, x As Single, y As _

                                Single)

  Dim N As ComctlLib.Node

  

    Set N = TreeView1.HitTest(x, y)

    If Not (N Is Nothing) Then

      

        Set TreeView1.DropHighlight = N

      

      Set N = Nothing

    End If

    

End Sub

possible to add also a tooltip ballon during the mouse move event?

Can't hear WAVE file. No sound, no errors.

OzMaz — Tue, 02 Jun 2026 05:37:14 GMT

Hi,

I'm sure this has been done to death but I need some help to play a WAVE file.

I'm using Windows 11 and VB.NET 2026.

Code:

Try

    'My.Computer.Audio.Play("e:\MyStuff\TestTone.wav", AudioPlayMode.WaitToComplete)

    My.Computer.Audio.Play(A, AudioPlayMode.WaitToComplete)

Catch ex As Exception

    Stop

End Try

If tried both a file and a byte array, no luck.

Any ideas?

[RESOLVED] Determining En Passant

dday9 — Mon, 01 Jun 2026 18:55:52 GMT

It's been a while since I've built any games and so I figured I would set out to create a chess application.

I have the concept of Squares, Moves, Pieces (so far only started on Pawn), and Boards. This is the relevant code:

Chess Board
Keeps track of the squares and pieces

Code:

Namespace Board



    Public Class ChessBoard



        ' private variables

        Private ReadOnly _darkPieces(15) As ChessPiece

        Private ReadOnly _lightPieces(15) As ChessPiece

        Private ReadOnly _squares(63) As Square



        ' private methods

        Private Sub InitializeSquares()

            Dim counter As Integer = 0

            For rank As Byte = 0 To Square.MAX_RANK

                For file As Integer = 0 To Square.FILE_NAMES.Length - 1

                    _squares(counter) = New Square(rank, Convert.ToByte(file))

                    counter += 1

                Next

            Next

        End Sub



        Private Sub InitializePawns()

            Const darkRank As Integer = 6

            Const lightRank As Integer = 1



            Dim index As Integer = 0

            For fileIndex As Byte = 0 To Convert.ToByte(Square.FILE_NAMES.Length - 1)

                _darkPieces(index) = New Pawn(Shades.Dark, New Square(darkRank, fileIndex))

                _lightPieces(index) = New Pawn(Shades.Dark, New Square(lightRank, fileIndex))

            Next

        End Sub



        ' properties

        Public ReadOnly Property Squares As IReadOnlyList(Of Square)

            Get

                Return _squares

            End Get

        End Property



        ' public methods

        Public Function GetSquare(file As Byte, rank As Byte) As Square

            If (file > Square.FILE_NAMES.Length - 1) Then

                Throw New ArgumentOutOfRangeException(NameOf(file))

            End If

            If (rank > Square.MAX_RANK) Then

                Throw New ArgumentOutOfRangeException(NameOf(rank))

            End If



            Return _squares.Single(Function(square) square.File.Equals(file) AndAlso square.Rank.Equals(rank))

        End Function



        Public Function HasEnemyPiece(square As Square, shade As Shades) As Boolean

            Dim opposingPieces As ChessPiece() = If(shade = Shades.Dark, _lightPieces, _darkPieces)



            Return opposingPieces.Any(Function(piece) piece IsNot Nothing AndAlso piece.Square.Equals(square))

        End Function



        Public Function HasFriendlyPiece(square As Square, shade As Shades) As Boolean

            Dim friendlyPieces As ChessPiece() = If(shade = Shades.Dark, _darkPieces, _lightPieces)



            Return friendlyPieces.Any(Function(piece) piece IsNot Nothing AndAlso piece.Square.Equals(square))

        End Function



        Public Function IsEmpty(square As Square) As Boolean

            Return _

                _darkPieces.All(Function(piece) piece Is Nothing OrElse Not piece.Square.Equals(square)) AndAlso

                _lightPieces.All(Function(piece) piece Is Nothing OrElse Not piece.Square.Equals(square))

        End Function



        Public Sub Reset()

            ' WIP

            InitializePawns()

        End Sub



        ' constructor

        Public Sub New()

            InitializeSquares()

        End Sub



    End Class



End Namespace

Square
Represents a physical space on the chess board

Code:

Namespace Board



    Public Class Square

        Implements IEquatable(Of Square)



        ' private variables/constants

        Friend Const FILE_NAMES As String = "ABCDEFGH"



        Friend Const MAX_RANK As Integer = 7



        Private ReadOnly _file As Byte = 0

        Private ReadOnly _rank As Byte = 0



        ' properties

        Public ReadOnly Property Shade As Shades

            Get

                Dim evenRank As Boolean = _rank Mod 2 = 0

                Dim evenFile As Boolean = _file Mod 2 = 0

                Return If(

                    (evenRank AndAlso evenFile) OrElse (Not evenRank AndAlso Not evenFile),

                    Shades.Dark,

                    Shades.Light

                )

            End Get

        End Property



        Public ReadOnly Property File As Byte

            Get

                Return _file

            End Get

        End Property



        Public ReadOnly Property FileName As String

            Get

                Return FILE_NAMES(_file).ToString()

            End Get

        End Property



        Public ReadOnly Property Name As String

            Get

                Return String.Concat(FileName, RankName)

            End Get

        End Property



        Public ReadOnly Property Rank As Byte

            Get

                Return _rank

            End Get

        End Property



        Public ReadOnly Property RankName As String

            Get

                Return (_rank + 1).ToString()

            End Get

        End Property



        ' public methods

        Public Overloads Function Equals(other As Square) As Boolean Implements IEquatable(Of Square).Equals

            If (other Is Nothing) Then

                Return False

            End If

            If (ReferenceEquals(Me, other)) Then

                Return True

            End If

            Return File = other.File AndAlso Rank = other.Rank

        End Function



        Public Overrides Function Equals(obj As Object) As Boolean

            Return Equals(TryCast(obj, Square))

        End Function



        Public Overrides Function GetHashCode() As Integer

            Return HashCode.Combine(File, Rank)

        End Function



        Public Shared Operator =(square1 As Square, square2 As Square) As Boolean

            If (square1 Is Nothing) Then

                Return square2 Is Nothing

            End If

            Return square1.Equals(square2)

        End Operator



        Public Shared Operator <>(square1 As Square, square2 As Square) As Boolean

            If (square1 Is Nothing) Then

                Return square2 IsNot Nothing

            End If

            Return Not square1.Equals(square2)

        End Operator



        Public Overrides Function ToString() As String

            Return Name

        End Function



        Public Sub New(rank As Byte, file As Byte)

            _rank = rank

            _file = file

        End Sub



    End Class



End Namespace

ChessPiece
Parent class representing a chess piece; must be inherited

Code:

Namespace Pieces



    Public MustInherit Class ChessPiece



        Public MustOverride ReadOnly Property PieceType As PieceTypes

        Public ReadOnly Property Shade As Shades

        Public Property Square As Square



        Public MustOverride Function GetMoves(board As ChessBoard) As IEnumerable(Of Move)



        Public Sub New(shade As Shades)

            _Shade = shade

        End Sub



        Public Sub New(shade As Shades, square As Square)

            _Shade = shade

            _Square = square

        End Sub



    End Class



End Namespace

Pawn
Child chess piece for a pawn

Code:

Namespace Pieces



    Public Class Pawn

        Inherits ChessPiece



        ' private variables

        Private Shared ReadOnly PromotionPieceTypes As PieceTypes() = {

            PieceTypes.Queen,

            PieceTypes.Rook,

            PieceTypes.Bishop,

            PieceTypes.Knight

        }



        ' private methods

        Private Sub AddForwardMoves(board As ChessBoard, moves As List(Of Move), targetRank As Byte)

            Dim targetSquare As Square = board.GetSquare(Square.File, targetRank)



            If (Not board.IsEmpty(targetSquare)) Then

                Return

            End If



            If (IsPromotionRank(targetRank)) Then

                AddPromotionMoves(moves, Square, targetSquare, MoveTypes.Promotion)

            Else

                Dim nextMove As New Move(Square, targetSquare, MoveTypes.Normal)

                moves.Add(nextMove)



                If (IsStartingRank(Square.Rank)) Then

                    Dim skipRankNumber As Byte = Convert.ToByte(Square.Rank + If(Shade.Equals(Shades.Dark), 2, -2))

                    Dim skipSquare As Square = board.GetSquare(Square.File, skipRankNumber)



                    If (board.IsEmpty(skipSquare)) Then

                        moves.Add(New Move(Square, skipSquare, MoveTypes.Normal))

                    End If

                End If

            End If

        End Sub



        Private Sub AddPawnCaptureMove(board As ChessBoard, moves As List(Of Move), targetFile As Byte, targetRank As Byte)

            Dim targetSquare As Square = board.GetSquare(targetFile, targetRank)

            If (Not board.HasEnemyPiece(targetSquare, Shade)) Then

                Return

            End If



            If IsPromotionRank(targetRank) Then

                AddPromotionMoves(moves, Square, targetSquare, MoveTypes.PromotionCapture)

            Else

                moves.Add(New Move(Square, targetSquare, MoveTypes.Capture))

            End If

        End Sub



        Private Shared Sub AddPromotionMoves(moves As List(Of Move), fromSquare As Square, toSquare As Square, moveType As MoveTypes)

            For Each promotionPieceType As PieceTypes In PromotionPieceTypes

                moves.Add(New Move(fromSquare, toSquare, moveType, promotionPieceType))

            Next

        End Sub



        Private Function IsStartingRank(rank As Byte) As Boolean

            Return If(Shade.Equals(Shades.Dark), rank = 1, rank = 6)

        End Function



        Private Function IsPromotionRank(rank As Byte) As Boolean

            Return If(Shade.Equals(Shades.Dark), rank = 7, rank = 0)

        End Function



        ' properties

        Public Overrides ReadOnly Property PieceType As PieceTypes = PieceTypes.Pawn



        ' public methods

        Public Overrides Function GetMoves(board As ChessBoard) As IEnumerable(Of Move)

            If (Square Is Nothing) Then

                Return Enumerable.Empty(Of Move)()

            End If



            Dim nextRankNumber As Byte = Convert.ToByte(Square.Rank + If(Shade.Equals(Shades.Dark), -1, 1))

            Dim moves As New List(Of Move)



            AddForwardMoves(board, moves, nextRankNumber)

            If (Square.File > 0) Then

                AddPawnCaptureMove(board, moves, CByte(Square.File - 1), nextRankNumber)

            End If

            If (Square.File < 7) Then

                AddPawnCaptureMove(board, moves, CByte(Square.File + 1), nextRankNumber)

            End If



            Return moves

        End Function



        ' constructor

        Public Sub New(shade As Shades)

            MyBase.New(shade)

        End Sub



        Public Sub New(shade As Shades, square As Square)

            MyBase.New(shade, square)

        End Sub



    End Class



End Namespace

The pawn works for the most part, except I cannot figure out how to handle en passant.

The rules for en passant are that the capturing pawn can take an opponent's pawn if:

The opponent's previously moved piece was a pawn
The opponent's pawn moved forward 2 spaces (which can only happen the first time its moved)
The opponent's pawn falls on the same rank as the capturing pawn

This is essentially game logic, but as you can tell from my setup, I'm trying to lay out all the potential moves of a given piece inside the Pawn class. My issue is that I'm not quite sure how to square those two concepts.

VBMAN - A Modern Network Development Framework for VB6/VBA (Open Source)

woeoio — Mon, 01 Jun 2026 13:53:35 GMT

Hey, ervrybudy, visualbasic!

I'm excited to share that I've just open-sourced **VBMAN**, a network application development framework I've been working on since 2017. It's designed specifically for VB6 and VBA developers who need modern networking capabilities.

## What is VBMAN?

VBMAN is a comprehensive network development framework that brings modern web technologies to the BASIC ecosystem. If you've ever struggled with making HTTP requests, hosting a web server, or handling WebSockets in VB6/VBA, this might save you some headaches.

## Key Features

### Web Development
- **HTTP Server** - Build lightweight web services directly in VB6/VBA
- **HTTP Client** - Modern HTTP/HTTPS requests with JSON support
- **WebSocket** - Real-time bidirectional communication
- **Server-Sent Events (SSE)** - Server-to-client streaming
- **JSON Processing** - Native JSON serialization/deserialization

### Database & Storage
- **Database Access** - Simplified SQL operations
- **Redis Client** - Cache and message broker support
- **INI File Handler** - Structured configuration management

### Industrial IoT Protocols
- **Modbus TCP/RTU** - Master and Slave implementations
- **MQTT Client/Server** - Lightweight messaging for IoT
- **Serial Port** - Direct hardware communication

### Utilities
- **Shadow Window** - Modern UI effects for VB6 forms
- **Collection Tools** - Enhanced data structures
- **Cryptography** - AES, Hash, HMAC support
- **Logging System** - Structured application logging

## Why VBMAN?

I started this project in 2017 because I needed to build network applications for industrial automation, but VB6's built-in networking capabilities were... limited. Rather than migrate everything to .NET, I decided to extend VB6's capabilities.

The framework is designed to feel native to VB6 developers - the API style follows familiar patterns, so you don't need to learn a completely new way of thinking.

## VBMAN2 - The Next Generation

I'm also working on **VBMAN2**, which **includes all VBMAN capabilities** and adds WebView2 support with two-way data binding. This means you can build modern web-based UIs that communicate seamlessly with your VB6/VBA code:

> **Note**: VBMAN2 is a superset of VBMAN - everything in VBMAN works in VBMAN2, plus more. You can seamlessly upgrade when you're ready.

```vb
' Bind UI elements to VB6 code
wv.BindData "username", "#user-name", "textContent"
wv.SetData "username", "John" ' UI updates automatically

' Two-way binding
wv.BindUI Me, "OnSearch", "#search-input", EventName:="input"
```

## Project Info

- **License**: GPL-3.0 (Binary files are free forever, source available for personal use)
- **Documentation**: see gihub
- **Repository**: https://github.com/woeoio/vbman

## Who is this for?

- Maintaining legacy VB6/VBA applications
- Industrial automation systems
- Quick prototyping for internal tools
- Anyone who still enjoys BASIC syntax (no judgment here!)

## Questions?

Happy to answer any questions! The documentation site has detailed API references and examples. I've been using this in production environments for years, so it's battle-tested for industrial scenarios.

---

**Fun fact**: This project started as "BSMAN" (Basic Server Man) back in 2017, with grand plans for ASPMAN, VBSMAN, and VBAMAN sub-projects. Only VBMAN survived... and thrived!

PictureBox.SetPixel Timing

VB-MCU-User — Mon, 01 Jun 2026 12:12:33 GMT

Hi. I'm receiving through a USB connection the data for 16 image pixels at a time. The data comes in as RGB565 in two bytes per pixel for a 160 x 120 pixels image.

If I receive the pixels data with an interval of 1 millisecond between data packets, my vb.net program works fine displaying the image. My USB device can send data a lot faster than this, so if I try to decrease the interval below 1 mS (speed up the data transfer), the display process of the image in the PictureBox starts losing data and it won't display the whole picture. This makes me think that my vb.net program is taking too long to display the image.

How do I speed up my code? What are the lines in the code that are taking more time to process? I remember there is a way to run the code in a second thread. Is this going to help? Any ideas? Thanks.

Code:

For IvarImage = 0 To 15       'PROCESS DATA FOR 16 PIXELS FOR IMAGE IN PICTUREBOX. RGB565 DATA.



   '248 = b11111000, SHIFT 3 SPACES TO THE RIGHT.

   RedValueImage = (ALL64.Item(DevNum).Get_SquaresArray(((IvarImage * 2) + 1)) And 248) >> 3

   '7 = b00000111, SHIFT 3 SPACES TO THE LEFT. 224 = b11100000, SHIFT 5 SPACES TO THE RIGHT.

   GreenValueImage = ((ALL64.Item(DevNum).Get_SquaresArray(((IvarImage * 2) + 1)) And 7) << 3) +

      ((ALL64.Item(DevNum).Get_SquaresArray((IvarImage * 2)) And 224) >> 5)

   '31 = b00011111.

   BlueValueImage = ALL64.Item(DevNum).Get_SquaresArray((IvarImage * 2)) And 31



   'NEED TO SCALE UP COLOR VARIABLES.

   RedValueImage = RedValueImage * 255 / 31            '31 CORRESPONDS TO 5 BITS FOR RED

   GreenValueImage = GreenValueImage * 255 / 63        '63 CORRESPONDS TO 6 BITS FOR GRREN

   BlueValueImage = BlueValueImage * 255 / 31          '31 CORRESPONDS TO 5 BITS FOR BLUE



   Dim pixelColor As Color = Color.FromArgb(RedValueImage, GreenValueImage, BlueValueImage)

   bmpImage.SetPixel(xImage, yImage, pixelColor)



   xImage = xImage + 1         'NEXT POINT. IMAGE SIZE IS 160 X 120 PIXELS.

   If xImage > 159 Then

      xImage = 0

      yImage = yImage + 1

      If yImage > 119 Then

         yImage = 0

      End If

   End If



Next



' Display the generated image in a PictureBox. 16 pixels at a time.

pbxCameraImage.Image = bmpImage

Access Problem!

couttsj — Sat, 30 May 2026 21:30:59 GMT

For the past several days I am having a lot of trouble reaching
a number of web sites, including my provider (Telus) and my bank CIBC). Telus is using a reverse proxy provided by Cloudflare (172.66.0.98), and CIBC is using Telus/Akamai (207.194.199.74). A reverse proxy sits in front of an origin server and ensures that no client ever communicates directly with that origin server.

Some time ago, I had a similar problem with "VBForums.com", and I was able to work around that issue. This problem however is different in that if I wait long enough, it eventually loads (most of the time). As I am preparing this message, now VBForums also has this same problem as I try to post this message.

What is going on?

J.A. Coutts

Addendum:
Browser is Firefox 151.0.2

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,

VS 2015 Free stock API?

groston — Sat, 30 May 2026 03:22:15 GMT

Since many of the Windows 7 desktop gadgets no longer work, I wrote one to show me the current prices of my stock holdings. I use the twelvedata.com API for the data and my program is configured to access the API not more than several hundred times per day (which assumes my computer is on for the entire active stock day), so it is not terribly demanding.

The API worked without issue for several years, but a while ago, it stopped showing the value for the indices DJI, IXIC, and SPX. Today (and I checked this by entering the API URL into my browser), the twelvedata.com API indicated that these index strings are not valid.

Question: Can anyone suggest a free API that will provide the current-ish value for these indices about 50 times per day? Not sure that this is the proper forum in which this question should be asked, and if you have any ideas of better forums where this can be asked, please share.

Line Numbering withiin a subroutine

SteveM22 — Fri, 29 May 2026 18:16:18 GMT

Trying to load an app into the IDE on Win 10. This works on win XP no problem.

I get at Ctrl-F5 an error messages saying a problem on line 700 about licensing in Sub Main.
There seems to be no indicator in the IDE to determine line I am at the subroutine so finding that particular line number in the subroutine becomes tedious.

How can I find it easily?

screen crack animation joke ideas

dz32 — Fri, 29 May 2026 16:42:10 GMT

so this is a joke app I have wanted forever maybe some of the game guys will have some ideas here

- copy the desktop into your own image and take over screen to play with
- play cracking glass sound and draw cracks on the desktop image
- shards of the desktop start dropping away and some demon image from behind starts advancing
- second stage of shards/glass cracking sound
- demon emerges with a sound track
- disappears leaving people blinking at their screens

AI was able to do a pretty good job but it just feels likes it missing something / not everything it could be

ideas?

maybe an demon animation sequence like a video game as it runs and crawls through teh shards or
busts out the rest of the shards with a fist

there are 9 variants, you can choose on the command line by entering 1-9, 5 is the default

Attached Files

screen_crack.zip (1.27 MB)