Fandom

Visual Basic Wiki

How to draw the mouse pointer dynamically.frm/code

< How to draw the mouse pointer dynamically.frm

70pages on
this wiki
Add New Page
Talk0 Share

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.