18 June 2013

VB6 - Dynamic cursor

For a drawing application I needed to be able to set the cursor dynamically to reflect the current size and color of the brush. I was working in VB6 (love it!) and with GDI, and the following does what I wanted. It uses a number of Windows API methods which signatures can be found on MSDN. All methods called in the code below are API methods. First, some constants and the type IconInfo that is needed for the Windows API:
Private Const GCL_HCURSOR = -12
Private Const BLACKNESS = 66
Private Const WHITENESS = 16711778
Private Const BLACK_BRUSH = 4
Private Const BLACK_PEN = 7
Private Const DC_BRUSH = 18
Private Const DC_PEN = 1

Private Type IconInfo
  IsIcon As Boolean
  Hotspot As PointL
  MaskBitmap As Long
  ColorBitmap As Long
End Type
You need to create a color bitmap of your cursor and a mask bitmap for it's transparancy. The following code creates a round cursor of size pixels and the color color.RgbColor.
'Create color bitmap
Dim colorDc As Long: colorDc = CreateCompatibleDC(mHdc)
mCursorInfo.ColorBitmap = CreateCompatibleBitmap(mHdc, size, size)
Dim prevColorBmp As Long: prevColorBmp = SelectObject(colorDc, mCursorInfo.ColorBitmap)
PatBlt colorDc, 0, 0, size, size, BLACKNESS
SelectObject colorDc, GetStockObject(DC_BRUSH)
SelectObject colorDc, GetStockObject(DC_PEN)
SetDCBrushColor colorDc, color.RgbColor
SetDCPenColor colorDc, color.RgbColor
Ellipse colorDc, 0, 0, size, size
SelectObject colorDc, prevColorBmp
DeleteDC colorDc

'Create mask bitmap
Dim maskDc As Long: maskDc = CreateCompatibleDC(mHdc)
mCursorInfo.MaskBitmap = CreateCompatibleBitmap(mHdc, size, size)
Dim prevMaskBmp As Long: prevMaskBmp = SelectObject(maskDc, mCursorInfo.MaskBitmap)
Rectangle maskDc, -1, -1, size + 1, size + 1
SelectObject maskDc, GetStockObject(BLACK_BRUSH)
SelectObject maskDc, GetStockObject(BLACK_PEN)
Ellipse maskDc, 0, 0, size, size
SelectObject maskDc, prevMaskBmp
DeleteDC maskDc
Then you need to tell Windows to use these as cursor. If I created a cursor before, I destroy it and it's bitmaps to free the memory:
'Create cursor
mCursorInfo.Hotspot.X = size / 2
mCursorInfo.Hotspot.Y = size / 2
mCursor = CreateIconIndirect(mCursorInfo)
If mCursor <= 0 Then
  Debug.Print "Could not create dot."
Else
  origCursor = SetCursor(mCursor)
  SetClassLong mHwnd, GCL_HCURSOR, mCursor
  If prevCursor > 0 Then
    If DestroyIcon(prevCursor) = False Then Debug.Print "Could not delete dot."
    DeleteObject prevInfo.ColorBitmap
    DeleteObject prevInfo.MaskBitmap
  End If
End If

No comments:

Post a Comment