Can we create a Cursor that displays some text instead of an image ?

[Jaafar Tribak]

Hi there.

I have some code that runs a lengthy loop during which the system is temporarly tied up . I was thinking that changing the hourglass cursor while waiting into some informative text such as "Loading in Progress..." would be a nice touch.

Before I start digging any further ,has anyone seen this done before ?

Of course, one could use other means like displaying the text on the statusbar or a cell etc...but changing the cursor is what i am looking for here.

Thanks.

 

[mikerickson]

I suspect that it could be done, but at what risk?

Your OS has programmed the hourglass and millions of users have beta, gamma...omega tested the OS cursor routine.

Everyone knows what the hourglass means.

Substituting a custom text cursor would convey no new information and would not be as heavily tested as their cursor routine.

 

[Jaafar Tribak]

Thanks Mike for the input.

Yes you are right everyone knows what the hourglass means but sometimes if the waiting takes long ,the user may think that the system is hang hence the idea to display a reassuring text .

Plus - this would be a good learning exercise for anyone curious on customizing the native cursor.

 

[ZVI]

Hi Jaafar,
If it wasn't in your etc then what about displaying of the half-transparent form at mouse position nearby of the hourglass icon?
Vladimir

 

[Jaafar Tribak]

Hi Jaafar,
If it wasn't in your etc then what about displaying of the half-transparent form at mouse position nearby of the hourglass icon?
Vladimir

Hi ZVI.

I did try placing a small semi transparent form/window at the mouse pointer position but the result was shaky at best . Fortunatly, while searching the net, I came accross this handy CreateIconIndirect API function which looked promissing but it was all explained in C language . It's taking me quite an amount of translation guessing and experimentation to make it work for VBA.

Thanks for your interest.

 

[Jaafar Tribak]

Workbook example

Ok here the deal:

I have created a Class named CTextCursor with the 3 Methods below for easy use:

1- Add(ByVal Text As String, ByVal Color As Long) - (Defines the cursor text and its color.)

2- Show - (Displays the text cursor.)

3- Destroy - (Deletes the text cursor.)

Usage example :

Option Explicit
 
Private bAbortMacro As Boolean
 
Private CustomTextCursor1 As CTextCursor
Private CustomTextCursor2 As CTextCursor
Private CustomTextCursor3 As CTextCursor
 
Sub StartLongMacro()
 
    Dim t As Single
    Dim lRow As Long
 
    Set CustomTextCursor1 = New CTextCursor
    Set CustomTextCursor2 = New CTextCursor
    Set CustomTextCursor3 = New CTextCursor
 
    CustomTextCursor1.Add Text:="Loading In Progress .", Color:=vbBlack
    CustomTextCursor2.Add Text:="Loading In Progress ..", Color:=vbRed
    CustomTextCursor3.Add Text:="Loading In Progress ...", Color:=vbBlue
 
    bAbortMacro = False
 
    t = Timer
 
    For lRow = 1 To Rows.Count
 
        Select Case True
 
            Case (Timer - t) Mod 3 = 0
                CustomTextCursor1.Show
            Case (Timer - t) Mod 3 = 1
                CustomTextCursor2.Show
            Case (Timer - t) Mod 3 = 2
                CustomTextCursor3.Show
 
        End Select
 
        Randomize
 
        Cells(lRow, 1) = Int((100 * Rnd) + 1)
 
        If bAbortMacro Then Exit For
 
        DoEvents
 
    Next
 
    CustomTextCursor1.Destroy
    CustomTextCursor2.Destroy
    CustomTextCursor3.Destroy
 
End Sub
 
Sub AbortMacro()
 
    bAbortMacro = True
    Columns("A:A").ClearContents
 
End Sub

Class code :

'*******************************
' // This code Creates a Custom Text Cursor.
'*******************************
Option Explicit
 
'=============================
' // Private Declarations..
'=============================
 
Private Type POINTAPI
    x As Long
    y As Long
End Type
 
Private Type BITMAPINFOHEADER '40 bytes
    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
    biRUsed As Long
    biRImportant As Long
End Type
 
' A BITMAPINFO structure for bitmaps with no color palette.
Private Type BITMAPINFO_NoColors
    bmiHeader As BITMAPINFOHEADER
End Type
 
Private Type MemoryBitmap
    hdc As Long
    hBM As Long
    oldhDC As Long
    wid As Long
    hgt As Long
    bitmap_info As BITMAPINFO_NoColors
End Type
 
Private Type ICONINFO
    fIcon As Long
    xHotspot As Long
    yHotspot As Long
    hbmMask As Long
    hbmColor As Long
End Type
 
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 DeleteDC Lib "gdi32" _
(ByVal hdc As Long) _
As Long
 
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) _
As Long
 
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" _
(ByVal hdc As Long, ByVal nWidth As Long, _
ByVal nHeight As Long) _
As Long
 
Private Declare Function CreateDIBSection Lib "gdi32" _
(ByVal hdc As Long, pBitmapInfo As BITMAPINFO_NoColors, _
ByVal un As Long, ByVal lplpVoid As Long, _
ByVal handle As Long, ByVal dw As Long) _
As Long
 
Private Declare Function GetPixel Lib "gdi32.dll" _
(ByVal hdc As Long, ByVal x As Long, _
ByVal y As Long) _
As Long
 
Private Declare Function SetPixel Lib "gdi32.dll" _
(ByVal hdc As Long, ByVal x As Long, _
ByVal y As Long, ByVal crColor As Long) _
As Long
 
Private Declare Function SetBkMode Lib "gdi32.dll" _
(ByVal hdc As Long, ByVal nBkMode As Long) _
As Long
 
Private Declare Function TextOut Lib "gdi32.dll" _
Alias "TextOutA" _
(ByVal hdc As Long, ByVal x As Long, _
ByVal y As Long, ByVal lpString As String, _
ByVal nCount As Long) _
As Long
 
Private Declare Function CreateIconIndirect Lib "user32.dll" _
(ByRef piconinfo As ICONINFO) _
As Long
 
Private Declare Function SetCursor Lib "user32.dll" _
(ByVal hCursor As Long) _
As Long
 
Private Declare Function DestroyIcon Lib "user32.dll" _
(ByVal hIcon As Long) _
As Long
 
Private Declare Function GetTextExtentPoint32 Lib "gdi32" _
Alias "GetTextExtentPoint32A" _
(ByVal hdc As Long, ByVal lpsz As String, _
ByVal cbString As Long, lpSize As POINTAPI) _
As Long
 
Private Declare Function SetTextColor Lib "gdi32.dll" _
(ByVal hdc As Long, ByVal crColor As Long) _
As Long
 
Private Declare Function WindowFromPoint Lib "user32.dll" _
(ByVal xPoint As Long, _
ByVal yPoint As Long) _
As Long
 
Private Declare Function GetWindowThreadProcessId Lib "user32" _
(ByVal hwnd As Long, _
lpdwProcessId As Long) _
As Long
 
Private Declare Function GetCurrentThreadId Lib "kernel32" () _
As Long
 
Private Declare Function GetCursorPos Lib "user32.dll" _
(ByRef lpPoint As POINTAPI) _
As Long
 
Private Const DIB_RGB_COLORS = 0&
Private Const BI_RGB = 0&
 
Private sText As String
Private lTextColor As Long
Private hCursor As Long
 
'=============================
' // Private Procedures ..
'=============================
Private Function TextToBitmap _
( _
Text As String, TextColor As Long _
 _
) As Boolean
 
    Dim memory_bitmap As MemoryBitmap
 
    On Error GoTo errHandler
 
    'Store all the arguments for later use.
    sText = Text
    lTextColor = TextColor
    ' Create the memory bitmap.
    memory_bitmap = MakeMemoryBitmap _
    (Text, TextColor)
    ' Draw on the bitmap.
    DrawOnMemoryBitmap memory_bitmap
 
    'create memory cursor masks.
    Call GetMaskBitmaps(memory_bitmap)
 
    ' Delete the memory bitmap.
    DeleteMemoryBitmap memory_bitmap
 
    'Return TRUE if success.
    TextToBitmap = True
 
    Exit Function
 
errHandler:
    MsgBox Err.Description, vbCritical, "Error"
 
End Function
 
' Make a memory bitmap according to the Font size.
Private Function MakeMemoryBitmap _
( _
Text As String, Color As Long _
) As MemoryBitmap
 
    Dim result As MemoryBitmap
    Dim bytes_per_scanLine As Long
    Dim pad_per_scanLine As Long
    Dim TextSize As POINTAPI
    Dim new_font As Long
 
    ' Create the device context.
    result.hdc = CreateCompatibleDC(0)
 
    'get the text metrics.
    GetTextExtentPoint32 result.hdc, Text, Len(Text), TextSize
 
    ' Define the bitmap.
    With result.bitmap_info.bmiHeader
        .biBitCount = 32
        .biCompression = BI_RGB
        .biPlanes = 1
        .biSize = Len(result.bitmap_info.bmiHeader)
        .biWidth = TextSize.x 'wid
        .biHeight = TextSize.y ' hgt
        bytes_per_scanLine = ((((.biWidth * .biBitCount) + _
        31) \ 32) * 4)
        pad_per_scanLine = bytes_per_scanLine - (((.biWidth _
        * .biBitCount) + 7) \ 8)
        .biSizeImage = bytes_per_scanLine * Abs(.biHeight)
    End With
 
    ' Create the bitmap.
    result.hBM = CreateDIBSection( _
    result.hdc, result.bitmap_info, _
    DIB_RGB_COLORS, ByVal 0&, _
    ByVal 0&, ByVal 0&)
 
    ' Make the device context use the bitmap.
    result.oldhDC = SelectObject(result.hdc, result.hBM)
 
    ' Return the MemoryBitmap structure.
    result.wid = TextSize.x
    result.hgt = TextSize.y
 
    MakeMemoryBitmap = result
 
End Function
 
Private Sub DrawOnMemoryBitmap( _
memory_bitmap As _
MemoryBitmap _
)
 
    SetBkMode memory_bitmap.hdc, 2 'Opaque
    SetTextColor memory_bitmap.hdc, lTextColor
    TextOut memory_bitmap.hdc, 0, 0, Trim(sText), Len(Trim(sText))
 
End Sub
 
' Delete the bitmap and free its resources.
Private Sub DeleteMemoryBitmap( _
memory_bitmap As MemoryBitmap _
)
 
    SelectObject memory_bitmap.hdc, memory_bitmap.oldhDC
    DeleteObject memory_bitmap.hBM
    DeleteDC memory_bitmap.hdc
 
End Sub
 
Private Sub GetMaskBitmaps( _
memory_bitmap As MemoryBitmap _
)
    Dim tIcoInfo As ICONINFO
    Dim hMainDC As Long
    Dim hAndMaskDC As Long
    Dim hXorMaskDC As Long
    Dim hAndMaskBitmap As Long
    Dim hXorMaskBitmap As Long
    Dim hOldMainBmp As Long
    Dim lOldAndMaskBmp As Long
    Dim lOldXorMaskBmp As Long
    Dim x As Long, y As Long
 
    'create the memory DCs.
    hMainDC = memory_bitmap.hdc
    hAndMaskDC = CreateCompatibleDC(hMainDC)
    hXorMaskDC = CreateCompatibleDC(hMainDC)
 
    'create the memory BMPs.
    hAndMaskBitmap = CreateCompatibleBitmap _
    (hMainDC, memory_bitmap.wid, memory_bitmap.hgt)
    hXorMaskBitmap = CreateCompatibleBitmap _
    (hMainDC, memory_bitmap.wid, memory_bitmap.hgt)
 
    'select the Mem BMPs onto the Mem DCs.
     hOldMainBmp = SelectObject(hMainDC, memory_bitmap.hBM)
     lOldAndMaskBmp = SelectObject(hAndMaskDC, hAndMaskBitmap)
     lOldXorMaskBmp = SelectObject(hXorMaskDC, hXorMaskBitmap)
 
    'set the masks pixels in the msks DCs.
    For x = 0 To memory_bitmap.wid
        For y = 0 To memory_bitmap.hgt
            If GetPixel(hMainDC, x, y) = RGB(255, 255, 255) Then
                SetPixel hAndMaskDC, x, y, RGB(255, 255, 255)
                SetPixel hXorMaskDC, x, y, RGB(0, 0, 0)
            Else
                SetPixel hAndMaskDC, x, y, RGB(0, 0, 0)
                SetPixel hXorMaskDC, x, y, lTextColor
            End If
        Next y
    Next x
 
 
    SelectObject hMainDC, hOldMainBmp
    SelectObject hAndMaskDC, lOldAndMaskBmp
    SelectObject hXorMaskDC, lOldXorMaskBmp
 
    'create the custom cursor.
    With tIcoInfo
        .fIcon = False
        .xHotspot = 0
        .yHotspot = 0
        .hbmMask = hAndMaskBitmap
        .hbmColor = hXorMaskBitmap
    End With
 
    hCursor = CreateIconIndirect(tIcoInfo)
 
 
    'cleanup.
    DeleteDC hMainDC
    DeleteDC hAndMaskDC
    DeleteDC hXorMaskDC
    DeleteObject hAndMaskBitmap
    DeleteObject hXorMaskBitmap
    DeleteObject hOldMainBmp
    DeleteObject lOldAndMaskBmp
    DeleteObject lOldXorMaskBmp
 
End Sub
 
 
'=============================
'// Class Methods
'=============================
Public Sub Add(ByVal Text As String, ByVal Color As Long)
 
    Call TextToBitmap(Text, Color)
 
End Sub
 
Public Sub Show()
 
    Dim tPt As POINTAPI
    Dim lWnUnderCurs As Long
 
    GetCursorPos tPt
 
    lWnUnderCurs = WindowFromPoint(tPt.x, tPt.y)
 
    If GetWindowThreadProcessId(lWnUnderCurs, ByVal 0&) _
    = GetCurrentThreadId Then
 
        Call SetCursor(hCursor)
 
    End If
 
End Sub
 
Public Sub Destroy()
 
     DestroyIcon hCursor
 
End Sub

 

[ZVI]

Jaafar, thank you for one more impressive API lesson!
Happy to learn, Vladimir

 

[Leith Ross]

Hello Jaafar,

Outstanding work. Definitely gets your attention and informs you of what is happening. Much better than staring at a hourglass and wondering if the program is running or hung up.

 

[smartmouth]

how can i add this to a script i already have?

i can import the class module easily....
but i cant seem to properly splice (you know what i mean) the code to start at the beginning and destroy at the end.

do we need to Dim it? maybe the whole sheet?
one of the errors i got was a NumRange could no longer be defined. Conflict with your code?

 

[Jaafar Tribak]

how can i add this to a script i already have?

i can import the class module easily....
but i cant seem to properly splice (you know what i mean) the code to start at the beginning and destroy at the end.

do we need to Dim it? maybe the whole sheet?
one of the errors i got was a NumRange could no longer be defined. Conflict with your code?

Hi smartmouth.

Not knowing what your code looks like , it's difficult to know why you are getting that error.

As a general rule, you create and define the text cursor before running the lenghthy code like in a Do Loop or Next For . Then Show the Cursor within the loop repeatedly until the loop is exited. Once the loop is finished, you Destroy the cursor.