Visual Basic Wiki

How to draw the mouse pointer dynamically.frm

70pages on
this wiki
Add New Page
Talk0 Share
This module aims to show you how you can draw your own anti-aliased mouse pointer from Visual Basic code.

It is done in four steps: drawing, scaling, making it transparent and creating it.


In order to facilitate anti-aliasing, it is drawn at a larger resolution than we actually need. This way we can then scale it down to make it smooth and non-jaggy. The key point in this phase is that AutoRedraw is set to True, so the drawing is kept in memory and can be manipulated later.


We create a memory bitmap that will become our cursor image and select it in a device context for drawing. The key calls here are SetStretchBltMode, which turns anti-aliasing on, and StretchBlt, which does the actual scaling.

Making it transparent

Normally you'd supply an And-mask, but we want full alpha for our anti-aliasing. Since Windows XP, this is possible by using a bitmap with an alpha channel for the Xor-mask and ignoring the And-mask. In this case, we derive our alpha values from the colour values, using red as a key colour.

Creating it

All the actual work is already done, we just call CreateIconIndirect to create a cursor from our bitmap. We set it to the system default cursor as a demonstration, and clean up.B9A171


Pretty obvious once you know the principle, so public domain.B9A171


VERSION 4.00 Begin VB.Form DemoForm ClientHeight = 1935 ClientLeft = 1680 ClientTop = 1560 ClientWidth = 2415 Height = 2385 Left = 1620 ScaleHeight = 129 ScaleMode = 3 'Pixel ScaleWidth = 161 Top = 1170 Width = 2535 WindowState = 2 'Maximized Begin VB.PictureBox Arrow AutoRedraw = -1 'True BackColor = &H000000FF& BorderStyle = 0 'None DrawWidth = 4 FillColor = &H00FFFFFF& FillStyle = 0 'Solid ForeColor = &H00000000& Height = 1920 Left = 480 ScaleHeight = 128 ScaleMode = 3 'Pixel ScaleWidth = 128 TabIndex = 0 Top = 0 Visible = 0 'False Width = 1920 End Begin VB.Timer Tik Interval = 100 Left = 0 Top = 0 End End Attribute VB_Name = "DemoForm" Attribute VB_Creatable = False Attribute VB_Exposed = False Option Explicit Private Type BitmapV5Header bV5Size As Long bV5Width As Long bV5Height As Long bV5Planes As Integer bV5BitCount As Integer bV5Compression As Long bV5SizeImage As Long bV5XPelsPerMeter As Long bV5YPelsPerMeter As Long bV5ClrUsed As Long bV5ClrImportant As Long bV5RedMask As Long bV5GreenMask As Long bV5BlueMask As Long bV5AlphaMask As Long bV5CSType As Long bV5EndpointsRedX As Long bV5EndpointsRedY As Long bV5EndpointsRedZ As Long bV5EndpointsGreenX As Long bV5EndpointsGreenY As Long bV5EndpointsGreenZ As Long bV5EndpointsBlueX As Long bV5EndpointsBlueY As Long bV5EndpointsBlueZ As Long bV5GammaRed As Long bV5GammaGreen As Long bV5GammaBlue As Long bV5Intent As Long bV5ProfileData As Long bV5ProfileSize As Long bV5Reserved As Long 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 GetCursorPos Lib "User32" (XY As Long) As Long Private Declare Function Polygon Lib "GDI32" (ByVal hDC As Long, lpPoints As Long, ByVal nCount As Long) As Long Private Declare Function SetSystemCursor Lib "User32" (ByVal hCursor As Long, ByVal ID As Long) As Long Private Declare Function GetDC Lib "User32" (ByVal hWnd As Long) As Long Private Declare Function CreateDIBSection Lib "GDI32" (ByVal hDC As Long, BI As BitmapV5Header, ByVal Usage As Long, pBits As Long, ByVal FileMapping As Long, ByVal Offset As Long) As Long Private Declare Function CreateCompatibleDC Lib "GDI32" (ByVal hDC As Long) As Long Private Declare Function ReleaseDC Lib "User32" (ByVal hWnd As Long, ByVal hDC As Long) As Long Private Declare Function SelectObject Lib "GDI32" (ByVal hDC As Long, ByVal Object As Long) As Long Private Declare Function SetStretchBltMode Lib "GDI32" (ByVal hDC As Long, ByVal StretchMode As Long) As Long Private Declare Function StretchBlt Lib "GDI32" (ByVal hDC As Long, _ ByVal X As Long, ByVal Y As Long, ByVal Width As Long, ByVal Height As Long, _ ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, _ ByVal SrcWidth As Long, ByVal SrcHeight As Long, ByVal RasterOp As Long) As Long Private Declare Function DeleteDC Lib "GDI32" (ByVal hDC As Long) As Long Private Declare Function Peek Lib "Kernel32" Alias "RtlMoveMemory" (Dest As Long, ByVal Source As Long, ByVal Size As Long) As Long Private Declare Function Poke Lib "Kernel32" Alias "RtlMoveMemory" (ByVal Dest As Long, Source As Long, ByVal Size As Long) As Long Private Declare Function CreateBitmap Lib "GDI32" (ByVal Width As Long, ByVal Height As Long, ByVal Planes As Long, ByVal BitCount As Long, ByVal lpBits As Long) As Long Private Declare Function CreateIconIndirect Lib "User32" (IconInfo As IconInfo) As Long Private Declare Function DeleteObject Lib "GDI32" (ByVal Object As Long) As Long Dim OX As Double, OY As Double, A As Double Private Const ocrNormal = 32512 Private Const biBitFields = 3 Private Const dibRGBColors = 0 Private Const Halftone = 4 Private Sub Tik_Timer() Dim X As Double, Y As Double Dim sA As Double, cA As Double Dim P(1 To 14) As Long Dim BI As BitmapV5Header, I As Long Dim hDC As Long, hMemDC As Long Dim hBitmap As Long, hOldBitmap As Long, hMonoBitmap As Long Dim II As IconInfo 'Update cursor shape and draw it GetCursorPos P(1) X = P(1) Y = P(2) Select Case False Case X = OX, Y = OY Case Else: Exit Sub End Select A = (Cos(A) * (X - OX) + Sin(A) * (Y - OY)) / 100 + A OX = X OY = Y sA = Sin(A) cA = Cos(A) P(1) = ((1 + sA) * 58 And -4) + 10 P(2) = ((1 - cA) * 58 And -4) + 10 X = P(1) - cA * 24 - sA * 56 Y = P(2) - sA * 24 + cA * 56: P(3) = X: P(4) = Y X = X + cA * 18: Y = Y + sA * 18: P(5) = X: P(6) = Y X = X - sA * 32: Y = Y + cA * 32: P(7) = X: P(8) = Y X = X + cA * 12: Y = Y + sA * 12: P(9) = X: P(10) = Y X = X + sA * 32: Y = Y - cA * 32: P(11) = X: P(12) = Y X = X + cA * 18: Y = Y + sA * 18: P(13) = X: P(14) = Y Arrow.DrawWidth = 6 Arrow.ForeColor = 224 Arrow.FillColor = 192 Arrow.BackColor = vbRed Polygon Arrow.hDC, P(1), 7 For I = 1 To 14 P(I) = P(I) - 8 Next Arrow.DrawWidth = 4 Arrow.ForeColor = vbBlack Arrow.FillColor = vbWhite Polygon Arrow.hDC, P(1), 7 'Our cursor will be BGRA. Note that contrary to the documentation RGBA doesn't work. BI.bV5Size = Len(BI) BI.bV5Width = 32 BI.bV5Height = 32 BI.bV5Planes = 1 BI.bV5BitCount = 32 BI.bV5Compression = biBitFields BI.bV5RedMask = vbBlue BI.bV5GreenMask = vbGreen BI.bV5BlueMask = vbRed BI.bV5AlphaMask = Not vbWhite 'Shrink the bitmap to create a small anti-aliased bitmap suitable for use as a cursor hDC = GetDC(0) hBitmap = CreateDIBSection(hDC, BI, dibRGBColors, I, 0, 0) hMemDC = CreateCompatibleDC(hDC) ReleaseDC 0, hDC hOldBitmap = SelectObject(hMemDC, hBitmap) SetStretchBltMode hMemDC, Halftone StretchBlt hMemDC, 0, 0, 32, 32, Arrow.hDC, 0, 0, 128, 128, vbSrcCopy SelectObject hMemDC, hOldBitmap DeleteDC hMemDC 'Calculate alpha values, using red as a key colour For I = I To I + 4095 Step 4 Dim C As Long Peek C, I, 4 If C And vbYellow Then Poke I + 3, 255, 1 Else Poke I, 0, 4 Poke I + 1, C Xor vbBlue, 3 End If Next 'Create cursor and clean up hMonoBitmap = CreateBitmap(32, 32, 1, 1, 0) II.xHotspot = P(1) \ 4 II.yHotspot = P(2) \ 4 II.hBmMask = hMonoBitmap II.hBmColor = hBitmap SetSystemCursor CreateIconIndirect(II), ocrNormal DeleteObject hBitmap DeleteObject hMonoBitmap End Sub


Ad blocker interference detected!

Wikia is a free-to-use site that makes money from advertising. We have a modified experience for viewers using ad blockers

Wikia is not accessible if you’ve made further modifications. Remove the custom ad blocker rule(s) and the page will load as expected.