VBA Class to Make Mouse Cursors from Worksheet Shapes

Jaafar Tribak

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
9,797
Office Version
  1. 2016
Platform
  1. Windows
Hi all,

I am posting here this little project which, as the title says, allows the user to create custom userform mouse icons on the fly out of worksheet shapes.
The user can save the newly created .ico file to disk for later use.


Workbook Demo









- Class code: (Cls_MouseCursorFromShape)
VBA Code: 
Option Explicit

Private Type POINTAPI
        X As Long
        Y As Long
End Type

Private Type uPicDesc
    Size As Long
    Type As Long
    #If Win64 Then
        hPic As LongLong
        hPal As LongLong
    #Else
       hPic As Long
       hPal As Long
    #End If
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    #If Win64 Then
        bmBits As LongLong
    #Else
        bmBits As Long
    #End If
End Type

Private Type ICONINFO
    fIcon As Long
    xHotspot As Long
    yHotspot As Long
    #If Win64 Then
        hbmMask As LongLong
        hbmColor As LongLong
    #Else
        hbmMask As Long
        hbmColor As Long
    #End If
End Type

Private Type GdiplusStartupInput
   GdiplusVersion As Long
  #If Win64 Then
        DebugEventCallback As LongLong
        SuppressBackgroundThread As LongLong
  #Else
        DebugEventCallback As Long
        SuppressBackgroundThread As Long
  #End If
   SuppressExternalCodecs As Long
End Type


#If VBA7 Then

    Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As LongPtr, IPic As IPicture) As LongPtr
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDc As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As LongPtr, ByVal nCount As Long, lpObject As Any) As Long
    Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDc As LongPtr) As Long
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDc As LongPtr) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Private Declare PtrSafe Function GetIconInfo Lib "user32" (ByVal hIcon As LongPtr, piconinfo As ICONINFO) As Long
    Private Declare PtrSafe Function CreateIconIndirect Lib "user32" (piconinfo As ICONINFO) As LongPtr
    Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
    Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal Handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
    Private Declare PtrSafe Function SetPixel Lib "gdi32" (ByVal hDc As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
    Private Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hDc As LongPtr, ByVal X As Long, ByVal Y As Long) As Long
    Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As LongPtr) As Long
    Private Declare PtrSafe Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPtr
    Private Declare PtrSafe Function FillRgn Lib "gdi32" (ByVal hDc As LongPtr, ByVal hRgn As LongPtr, ByVal hBrush As LongPtr) As Long
    Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
    Private Declare PtrSafe Function OffsetRgn Lib "gdi32" (ByVal hRgn As LongPtr, ByVal X As Long, ByVal Y As Long) As Long
    Private Declare PtrSafe Function FrameRgn Lib "gdi32" (ByVal hDc As LongPtr, ByVal hRgn As LongPtr, ByVal hBrush As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    Private Declare PtrSafe Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As LongPtr, ByVal lpCursorName As Long) As Long
    Private Declare PtrSafe Function CopyIcon Lib "user32" (ByVal hIcon As LongPtr) As LongPtr
    Private Declare PtrSafe Function DestroyIcon Lib "user32" (ByVal hIcon As LongPtr) As Long
    Private Declare PtrSafe Function DrawIcon Lib "user32" (ByVal hDc As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal hIcon As LongPtr) As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
   
    'GDI+
    Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" (token As LongPtr, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
    Private Declare PtrSafe Function GdiplusShutdown Lib "gdiplus" (ByVal token As LongPtr) As Long
    Private Declare PtrSafe Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As LongPtr, ByVal hPal As LongPtr, BITMAP As LongPtr) As Long
    Private Declare PtrSafe Function GdipDisposeImage Lib "gdiplus" (ByVal Image As LongPtr) As LongPtr
    Private Declare PtrSafe Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" (ByVal BITMAP As LongPtr, hbmReturn As LongPtr, ByVal background As Long) As Long
    Private Declare PtrSafe Function GdipGetImageThumbnail Lib "gdiplus" (ByVal Image As LongPtr, ByVal thumbWidth As Long, ByVal thumbHeight As Long, thumbImage As LongPtr, ByVal Callback As LongPtr, ByVal callbackData As LongPtr) As Long
   

#Else
    Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDc As Long) As Long
    Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
    Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd 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 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 BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Private Declare Function GetIconInfo Lib "user32" (ByVal hIcon As Long, piconinfo As ICONINFO) As Long
    Private Declare Function CreateIconIndirect Lib "user32" (piconinfo As ICONINFO) As Long
    Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
    Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function CloseClipboard Lib "user32" () As Long
    Private Declare Function EmptyClipboard Lib "user32" () As Long
    Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
    Private Declare Function CopyImage Lib "user32" (ByVal Handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
    Private Declare Function SetPixel Lib "gdi32" (ByVal hDc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
    Private Declare Function GetPixel Lib "gdi32" (ByVal hDc As Long, ByVal X As Long, ByVal Y As Long) As Long
    Private Declare Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As Long) As Long
    Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare Function FillRgn Lib "gdi32" (ByVal hDc As Long, ByVal hRgn As Long, ByVal hBrush As Long) As Long
    Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
    Private Declare Function OffsetRgn Lib "gdi32" (ByVal hRgn As Long, ByVal X As Long, ByVal Y As Long) As Long
    Private Declare Function FrameRgn Lib "gdi32" (ByVal hDc As Long, ByVal hRgn As Long, ByVal hBrush As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
    Private Declare Function CopyIcon Lib "user32" (ByVal hIcon As Long) As Long
    Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
    Private Declare Function DrawIcon Lib "user32" (ByVal hDc As Long, ByVal X As Long, ByVal Y As Long, ByVal hIcon As Long) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long

    'GDI+
    Private Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
    Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
    Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long, ByVal hPal As Long, BITMAP As Long) As Long
    Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As Long
    Private Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" (ByVal BITMAP As Long, hbmReturn As Long, ByVal background As Long) As Long
    Private Declare Function GdipGetImageThumbnail Lib "gdiplus" (ByVal Image As Long, ByVal thumbWidth As Long, ByVal thumbHeight As Long, thumbImage As Long, ByVal Callback As Long, ByVal callbackData As Long) As Long

#End If

Private oUF As MSForms.UserForm
Private oShp As Shape
Private lWidth As Long
Private lHeight As Long
Private bHighlight As Boolean
Private dColor As Double
Private bColorSet As Boolean
Private bShowArrowCursor As Boolean

Private oMouseIcon As StdPicture, oClickMouseIcon1 As StdPicture
Private oClickMouseIcon2 As StdPicture, oClickMouseIcon3 As StdPicture, oClickMouseIcon4 As StdPicture




'___________________________________________CLASS PUBLIC MEMBERS_______________________________________________

Public Property Set ParentForm(ByVal uForm As MSForms.UserForm)
    Set oUF = uForm
End Property

Public Property Set SourceShape(ByVal oShape As Shape)
    Set oShp = oShape
End Property

Public Property Let Width(ByVal Width As Long)
    lWidth = Width
End Property

Public Property Let Height(ByVal Height As Long)
    lHeight = Height
End Property

Public Property Let HighlightOnClick(ByVal Highlight As Boolean)
    bHighlight = Highlight
End Property

Public Property Let ShowArrowCursor(ByVal Show As Boolean)
    bShowArrowCursor = Show
End Property

Public Property Let HighLightColor(ByVal Color As Double)
    bColorSet = True
    dColor = Color
End Property

Public Property Get CursorName() As String
    CursorName = oShp.Name
End Property

Public Function Create() As StdPicture

    #If Win64 Then
        Dim hwnd As LongLong, hSourceBitmap As LongLong
    #Else
        Dim hwnd As Long, hSourceBitmap As Long
    #End If

    Const CLICK_DIAMETER = 64

    Dim bNextRun  As Boolean
    Dim tCurPos As POINTAPI

    If oUF Is Nothing Then Exit Function
    If oShp Is Nothing Then Exit Function
   
    hSourceBitmap = ShapeToBitmap(oShp)

    If hSourceBitmap Then
   
    If bShowArrowCursor Then
        If lWidth < 40 Or lWidth > 120 Then lWidth = 40
        If lHeight < 40 Or lHeight > 120 Then lHeight = 40
    Else
        If lWidth < 16 Or lWidth > 120 Then lWidth = 16
        If lHeight < 16 Or lHeight > 120 Then lHeight = 16
    End If

        If bColorSet = False Then dColor = vbYellow
       
        Set oMouseIcon = BitmapToStdPic(hSourceBitmap, lWidth, lHeight)
        Set oClickMouseIcon1 = BitmapToStdPic(hSourceBitmap, CLICK_DIAMETER, CLICK_DIAMETER, True, 1)
        Set oClickMouseIcon2 = BitmapToStdPic(hSourceBitmap, CLICK_DIAMETER, CLICK_DIAMETER, True, 2)
        Set oClickMouseIcon3 = BitmapToStdPic(hSourceBitmap, CLICK_DIAMETER, CLICK_DIAMETER, True, 3)
        Set oClickMouseIcon4 = BitmapToStdPic(hSourceBitmap, CLICK_DIAMETER, CLICK_DIAMETER, True, 4)
       
        oUF.MousePointer = fmMousePointerCustom
        oUF.MouseIcon = oMouseIcon
       
        Call GetCursorPos(tCurPos)
        Call SetCursorPos(tCurPos.X, tCurPos.Y)

        Call WindowFromAccessibleObject(oUF, hwnd)
       
        Do While IsWindow(hwnd)
            If GetAsyncKeyState(VBA.vbKeyLButton) And bHighlight Then
                Call ShowClickCurosr(bNextRun)
                bNextRun = True
            End If
            DoEvents
        Loop
       
        oUF.MouseIcon = Nothing
       
    End If

End Function




'____________________________________________HELPER ROUTINES________________________________________________________


#If Win64 Then

    Private Function BitmapToStdPic( _
        ByVal hBitmap As LongLong, _
        ByVal Width As Long, _
        ByVal Height As Long, _
        Optional ByVal ShowClickCurosr As Boolean, _
        Optional n As Long _
        ) As StdPicture
   
        Dim hDc As LongLong, hMainDC As LongLong, hAndMaskDC As LongLong, hXorMaskDC As LongLong
        Dim hAndMaskBitmap As LongLong, hXorMaskBitmap As LongLong, ResizedBitmap As LongLong
        Dim hOldMainBitmap As LongLong, hOldAndMaskBitmap As LongLong, hOldXorMaskBitmap As LongLong
        Dim hFillBrush As LongLong, hFrameBrush As LongLong, hRgn As LongLong, hIcon As LongLong

#Else

    Private Function BitmapToStdPic( _
        ByVal hBitmap As Long, _
        ByVal Width As Long, _
        ByVal Height As Long, _
        Optional ByVal ShowClickCurosr As Boolean, _
        Optional n As Long _
        ) As StdPicture
   
        Dim hDc As Long, hMainDC As Long, hAndMaskDC As Long, hXorMaskDC As Long
        Dim hAndMaskBitmap As Long, hXorMaskBitmap As Long, ResizedBitmap As Long
        Dim hOldMainBitmap As Long, hOldAndMaskBitmap As Long, hOldXorMaskBitmap As Long
        Dim hFillBrush As Long, hFrameBrush As Long, hRgn As Long, hIcon As Long

#End If


    Dim tBM As BITMAP, tIcoInfo As ICONINFO
    Dim X As Long, Y As Long, lBitPixel As Long


    ResizedBitmap = ResizeBitmap(hBitmap, Width, Height)
   
    Call GetObjectAPI(ResizedBitmap, LenB(tBM), tBM)
   
    hDc = GetDC(0)
   
    hMainDC = CreateCompatibleDC(hDc)
    hAndMaskDC = CreateCompatibleDC(hDc)
    hXorMaskDC = CreateCompatibleDC(hDc)
   
    hAndMaskBitmap = CreateCompatibleBitmap(hDc, tBM.bmWidth, tBM.bmHeight)
    hXorMaskBitmap = CreateCompatibleBitmap(hDc, tBM.bmWidth, tBM.bmHeight)
   
    Call ReleaseDC(0, hDc)
   
    hOldMainBitmap = SelectObject(hMainDC, ResizedBitmap)
    hOldAndMaskBitmap = SelectObject(hAndMaskDC, hAndMaskBitmap)
    hOldXorMaskBitmap = SelectObject(hXorMaskDC, hXorMaskBitmap)
   
    If ShowClickCurosr Then
        If 20 * n > tBM.bmWidth Or 20 * n > tBM.bmHeight Then n = 0
        hRgn = CreateEllipticRgn(0, 0, 20 * n, 20 * n)
        hFillBrush = CreateSolidBrush(dColor)
        hFrameBrush = CreateSolidBrush(vbRed)
        Call OffsetRgn(hRgn, (tBM.bmWidth) / 2 - (20 * n) / 2, (tBM.bmHeight) / 2 - (20 * n) / 2)
        Call FillRgn(hMainDC, hRgn, hFillBrush)
        Call FrameRgn(hMainDC, hRgn, hFrameBrush, 2, 2)
        Call DeleteObject(hRgn)
        Call DeleteObject(hFillBrush)
        Call DeleteObject(hFrameBrush)
    End If

    If bShowArrowCursor Then
        hIcon = CopyIcon(LoadCursor(0, 32512))
        Call DrawIcon(hMainDC, (tBM.bmWidth) / 2, (tBM.bmHeight) / 2, hIcon)
        Call DestroyIcon(hIcon)
    End If

    For X = 0 To tBM.bmWidth
        For Y = 0 To tBM.bmHeight
           lBitPixel = GetPixel(hMainDC, X, Y)
            If lBitPixel = RGB(255, 255, 255) Then
                Call SetPixel(hAndMaskDC, X, Y, RGB(255, 255, 255))
                Call SetPixel(hXorMaskDC, X, Y, RGB(0, 0, 0))
            Else
                Call SetPixel(hAndMaskDC, X, Y, RGB(0, 0, 0))
                Call SetPixel(hXorMaskDC, X, Y, lBitPixel)
            End If
        Next Y
    Next X

    Call SelectObject(hMainDC, hOldMainBitmap)
    Call SelectObject(hAndMaskDC, hOldAndMaskBitmap)
    Call SelectObject(hXorMaskDC, hOldXorMaskBitmap)

    With tIcoInfo
        .fIcon = True
        .xHotspot = tBM.bmWidth / 2
        .yHotspot = tBM.bmHeight / 2
        .hbmMask = hAndMaskBitmap
        .hbmColor = hXorMaskBitmap
    End With
   
    Set BitmapToStdPic = IconToStdPic(CreateIconIndirect(tIcoInfo))

    Call DeleteDC(hXorMaskDC)
    Call DeleteDC(hAndMaskDC)
    Call DeleteDC(hMainDC)
    Call DeleteObject(hOldMainBitmap)
    Call DeleteObject(hAndMaskBitmap)
    Call DeleteObject(hOldXorMaskBitmap)

End Function



#If Win64 Then

    Private Function IconToStdPic( _
        ByVal Icon As LongLong _
        ) As StdPicture
   
        Dim hPtr As LongLong

#Else

    Private Function IconToStdPic( _
        ByVal Icon As Long _
        ) As StdPicture
   
        Dim hPtr As Long

#End If


    Const IMAGE_ICON = 1
    Const PICTYPE_ICON = 3
    Const LR_COPYRETURNORG = &H4
    Const S_OK = 0

    Dim IID_IDispatch As GUID, uPicInfo As uPicDesc
    Dim IPic As StdPicture
   
    hPtr = CopyImage(Icon, IMAGE_ICON, 0, 0, LR_COPYRETURNORG)

    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With

    With uPicInfo
        .Size = Len(uPicInfo)
        .Type = PICTYPE_ICON
        .hPic = hPtr
        .hPal = 0
    End With

    If OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic) = S_OK Then
        Set IconToStdPic = IPic
    End If

End Function



#If Win64 Then
    Private Function ShapeToBitmap( _
        ByVal oShape As Shape _
        ) As LongLong
       
        Dim hPtr As LongLong

#Else

    Private Function ShapeToBitmap( _
        ByVal oShape As Shape _
        ) As Long
       
        Dim hPtr As Long

#End If
   
   
    Const IMAGE_BITMAP = 0
    Const PICTYPE_BITMAP = 1
    Const LR_COPYRETURNORG = &H4
    Const CF_BITMAP = 2

    On Error GoTo errHandler
   
    oShape.CopyPicture xlScreen, xlBitmap
   
    If OpenClipboard(0) Then
        If IsClipboardFormatAvailable(CF_BITMAP) Then
            hPtr = GetClipboardData(CF_BITMAP)
            hPtr = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
            If hPtr Then
                ShapeToBitmap = hPtr
            End If
        End If
    End If

errHandler:

    Call OpenClipboard(0)
    Call EmptyClipboard
    Call CloseClipboard

End Function



#If Win64 Then
    Private Function ResizeBitmap( _
        ByVal hSourceBitmap As LongLong, _
        ByVal Width As Long, _
        ByVal Height As Long _
        ) As LongLong

        Dim lGDIP As LongLong, lBitmap As LongLong, lThumb As LongLong
   
#Else

    Private Function ResizeBitmap( _
        ByVal hSourceBitmap As Long, _
        ByVal Width As Long, _
        ByVal Height As Long _
        ) As Long

        Dim lGDIP As Long, lBitmap As Long, lThumb As Long
   
  #End If

   Const S_OK = 0&
   
    Dim tSI As GdiplusStartupInput
    Dim lRes As Long
   
    tSI.GdiplusVersion = 1
    lRes = GdiplusStartup(lGDIP, tSI)

   If lRes = S_OK Then
      lRes = GdipCreateBitmapFromHBITMAP(hSourceBitmap, 0, lBitmap)
      If lRes = S_OK Then
         lRes = GdipGetImageThumbnail(lBitmap, Width, Height, lThumb, 0, 0)
         If lRes = S_OK Then
            lRes = GdipCreateHBITMAPFromBitmap(lThumb, hSourceBitmap, 0)
             ResizeBitmap = hSourceBitmap
            GdipDisposeImage lThumb
         End If
         GdipDisposeImage lBitmap
      End If
      GdiplusShutdown lGDIP
   End If

   If lRes Then Err.Raise 5

End Function



Private Sub ShowClickCurosr(ByVal NextRun As Boolean)

    Dim tCurPos As POINTAPI
   
    If NextRun = False Then NextRun = True: Exit Sub

    oUF.MouseIcon = oClickMouseIcon1
    Call GetCursorPos(tCurPos)
    Call SetCursorPos(tCurPos.X, tCurPos.Y)
    Call Delay(0.05)

    oUF.MouseIcon = oClickMouseIcon2
    Call GetCursorPos(tCurPos)
    Call SetCursorPos(tCurPos.X, tCurPos.Y)
    Call Delay(0.05)

    oUF.MouseIcon = oClickMouseIcon3
    Call GetCursorPos(tCurPos)
    Call SetCursorPos(tCurPos.X, tCurPos.Y)
    Call Delay(0.05)

    oUF.MouseIcon = oClickMouseIcon4
    Call GetCursorPos(tCurPos)
    Call SetCursorPos(tCurPos.X, tCurPos.Y)
    Call Delay(0.05)

    oUF.MouseIcon = oMouseIcon
    Call GetCursorPos(tCurPos)
    Call SetCursorPos(tCurPos.X, tCurPos.Y)

End Sub


Private Sub Delay(ByVal HowLong As Single)

    #If Win64 Then
        Dim hwnd As LongLong
    #Else
        Dim hwnd As Long
    #End If

    Dim t As Single
   
    Call WindowFromAccessibleObject(oUF, hwnd)
   
    t = Timer
    Do
        DoEvents
    Loop Until Timer - t >= HowLong Or IsWindow(hwnd) = 0

End Sub


Public Sub SaveCursorToDisk(ByVal FilePathName As String)

    Dim sFilePath As String, sFileName As String, sExtensionName As String
   
    If Not oMouseIcon Is Nothing Then
        With CreateObject("Scripting.FileSystemObject")
            sFilePath = .GetParentFolderName(FilePathName)
            sFileName = .GetBaseName(FilePathName)
            sExtensionName = .GetExtensionName(FilePathName)
            If .FolderExists(sFilePath) Then
                If UCase(sExtensionName) <> UCase("ico") Then
                    sExtensionName = "ico"
                End If
            Else
                MsgBox "Cursor not saved to disk." & vbCrLf & "Invalid file path.", , "Error!"
                Exit Sub
            End If
            stdole.SavePicture oMouseIcon, sFilePath & "\" & sFileName & "." & sExtensionName
        End With
    End If

End Sub





- Class usage example (In UserForm Module)
VBA Code: 
Option Explicit

Private oCursorFromShape As Cls_MouseCursorFromShape


Private Sub btn_Circle_Click()

    Set oCursorFromShape = New Cls_MouseCursorFromShape
   
    With oCursorFromShape
        Set .ParentForm = Me
        Set .SourceShape = Sheet1.Shapes("Circle")
        .Width = 32
        .Height = 32
        .HighlightOnClick = True
        .HighLightColor = vbGreen
        .ShowArrowCursor = True
        .Create
        .SaveCursorToDisk Environ("Temp") & "\Circle.ico"
    End With

End Sub


Private Sub btn_Cross_Click()

    Set oCursorFromShape = New Cls_MouseCursorFromShape
   
    With oCursorFromShape
        Set .SourceShape = Sheet1.Shapes("Cross")
        Set .ParentForm = Me
        .Width = 100
        .Height = 100
        .HighlightOnClick = True
        .HighLightColor = vbYellow
        .ShowArrowCursor = True
        .Create
    End With

End Sub


Private Sub btn_Freeform_Click()

    Set oCursorFromShape = New Cls_MouseCursorFromShape
   
    With oCursorFromShape
        Set .ParentForm = Me
        Set .SourceShape = Sheet1.Shapes("Freeform")
        .Width = 64
        .Height = 64
        '.HighlightOnClick = True
        .Create
    End With

End Sub


Private Sub btn_Clock_Click()

    Set oCursorFromShape = New Cls_MouseCursorFromShape
   
    With oCursorFromShape
        Set .ParentForm = Me
        Set .SourceShape = Sheet1.Shapes("Clock")
        .Width = 64
        .Height = 64
        .HighlightOnClick = True
        .HighLightColor = vbRed
        .ShowArrowCursor = True
        .Create
    End With

End Sub


Private Sub btn_Hello_Click()

    Set oCursorFromShape = New Cls_MouseCursorFromShape
   
    With oCursorFromShape
        Set .ParentForm = Me
        Set .SourceShape = Sheet1.Shapes("Hello")
        .Width = 64
        .Height = 64
        .HighlightOnClick = True
        .HighLightColor = vbMagenta
        .ShowArrowCursor = False
        .Create
    End With

End Sub


Private Sub btn_Save_Click()

    Dim vFile As Variant

    If oCursorFromShape Is Nothing Then
        MsgBox "Create a custom cursor first.", , "error."
        Exit Sub
    End If

    vFile = Application.GetSaveAsFilename(InitialFileName:=oCursorFromShape.CursorName, _
    fileFilter:="Icon files (*.ico), *.ico")
    If vFile <> False Then
        oCursorFromShape.SaveCursorToDisk FilePathName:=vFile
    End If

End Sub
 

Excel Facts

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.
Sort by date Sort by votes
A couple of code corrections affecting how to set the mouse icon size :

Workbook update


Correct Class code:
VBA Code: 
Option Explicit

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Type uPicDesc
    Size As Long
    Type As Long
    #If Win64 Then
        hPic As LongLong
        hPal As LongLong
    #Else
       hPic As Long
       hPal As Long
    #End If
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    #If Win64 Then
        bmBits As LongLong
    #Else
        bmBits As Long
    #End If
End Type

Private Type ICONINFO
    fIcon As Long
    xHotspot As Long
    yHotspot As Long
    #If Win64 Then
        hbmMask As LongLong
        hbmColor As LongLong
    #Else
        hbmMask As Long
        hbmColor As Long
    #End If
End Type

Private Type GdiplusStartupInput
   GdiplusVersion As Long
  #If Win64 Then
        DebugEventCallback As LongLong
        SuppressBackgroundThread As LongLong
  #Else
        DebugEventCallback As Long
        SuppressBackgroundThread As Long
  #End If
   SuppressExternalCodecs As Long
End Type


#If VBA7 Then

    Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As LongPtr, IPic As IPicture) As LongPtr
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDc As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As LongPtr, ByVal nCount As Long, lpObject As Any) As Long
    Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDc As LongPtr) As Long
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDc As LongPtr) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Private Declare PtrSafe Function GetIconInfo Lib "user32" (ByVal hIcon As LongPtr, piconinfo As ICONINFO) As Long
    Private Declare PtrSafe Function CreateIconIndirect Lib "user32" (piconinfo As ICONINFO) As LongPtr
    Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
    Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal Handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
    Private Declare PtrSafe Function SetPixel Lib "gdi32" (ByVal hDc As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
    Private Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hDc As LongPtr, ByVal X As Long, ByVal Y As Long) As Long
    Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As LongPtr) As Long
    Private Declare PtrSafe Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPtr
    Private Declare PtrSafe Function FillRgn Lib "gdi32" (ByVal hDc As LongPtr, ByVal hRgn As LongPtr, ByVal hBrush As LongPtr) As Long
    Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
    Private Declare PtrSafe Function OffsetRgn Lib "gdi32" (ByVal hRgn As LongPtr, ByVal X As Long, ByVal Y As Long) As Long
    Private Declare PtrSafe Function FrameRgn Lib "gdi32" (ByVal hDc As LongPtr, ByVal hRgn As LongPtr, ByVal hBrush As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    Private Declare PtrSafe Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As LongPtr, ByVal lpCursorName As Long) As Long
    Private Declare PtrSafe Function CopyIcon Lib "user32" (ByVal hIcon As LongPtr) As LongPtr
    Private Declare PtrSafe Function DestroyIcon Lib "user32" (ByVal hIcon As LongPtr) As Long
    Private Declare PtrSafe Function DrawIcon Lib "user32" (ByVal hDc As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal hIcon As LongPtr) As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
   
    'GDI+
    Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" (token As LongPtr, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
    Private Declare PtrSafe Function GdiplusShutdown Lib "gdiplus" (ByVal token As LongPtr) As Long
    Private Declare PtrSafe Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As LongPtr, ByVal hPal As LongPtr, BITMAP As LongPtr) As Long
    Private Declare PtrSafe Function GdipDisposeImage Lib "gdiplus" (ByVal Image As LongPtr) As LongPtr
    Private Declare PtrSafe Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" (ByVal BITMAP As LongPtr, hbmReturn As LongPtr, ByVal background As Long) As Long
    Private Declare PtrSafe Function GdipGetImageThumbnail Lib "gdiplus" (ByVal Image As LongPtr, ByVal thumbWidth As Long, ByVal thumbHeight As Long, thumbImage As LongPtr, ByVal Callback As LongPtr, ByVal callbackData As LongPtr) As Long
   

#Else
    Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDc As Long) As Long
    Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
    Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd 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 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 BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Private Declare Function GetIconInfo Lib "user32" (ByVal hIcon As Long, piconinfo As ICONINFO) As Long
    Private Declare Function CreateIconIndirect Lib "user32" (piconinfo As ICONINFO) As Long
    Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
    Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function CloseClipboard Lib "user32" () As Long
    Private Declare Function EmptyClipboard Lib "user32" () As Long
    Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
    Private Declare Function CopyImage Lib "user32" (ByVal Handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
    Private Declare Function SetPixel Lib "gdi32" (ByVal hDc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
    Private Declare Function GetPixel Lib "gdi32" (ByVal hDc As Long, ByVal X As Long, ByVal Y As Long) As Long
    Private Declare Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As Long) As Long
    Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare Function FillRgn Lib "gdi32" (ByVal hDc As Long, ByVal hRgn As Long, ByVal hBrush As Long) As Long
    Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
    Private Declare Function OffsetRgn Lib "gdi32" (ByVal hRgn As Long, ByVal X As Long, ByVal Y As Long) As Long
    Private Declare Function FrameRgn Lib "gdi32" (ByVal hDc As Long, ByVal hRgn As Long, ByVal hBrush As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
    Private Declare Function CopyIcon Lib "user32" (ByVal hIcon As Long) As Long
    Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
    Private Declare Function DrawIcon Lib "user32" (ByVal hDc As Long, ByVal X As Long, ByVal Y As Long, ByVal hIcon As Long) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long

    'GDI+
    Private Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
    Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
    Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long, ByVal hPal As Long, BITMAP As Long) As Long
    Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As Long
    Private Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" (ByVal BITMAP As Long, hbmReturn As Long, ByVal background As Long) As Long
    Private Declare Function GdipGetImageThumbnail Lib "gdiplus" (ByVal Image As Long, ByVal thumbWidth As Long, ByVal thumbHeight As Long, thumbImage As Long, ByVal Callback As Long, ByVal callbackData As Long) As Long

#End If

Private oUF As MSForms.UserForm
Private oShp As Shape
Private lWidth As Long
Private lHeight As Long
Private bHighlight As Boolean
Private dColor As Double
Private bColorSet As Boolean
Private bShowArrowCursor As Boolean

Private oMouseIcon As StdPicture, oClickMouseIcon1 As StdPicture
Private oClickMouseIcon2 As StdPicture, oClickMouseIcon3 As StdPicture, oClickMouseIcon4 As StdPicture




'___________________________________________CLASS PUBLIC MEMBERS_______________________________________________

Public Property Set ParentForm(ByVal uForm As MSForms.UserForm)
    Set oUF = uForm
End Property

Public Property Set SourceShape(ByVal oShape As Shape)
    Set oShp = oShape
End Property

Public Sub SmallIcon()
    lWidth = 32: lHeight = 32
End Sub

Public Sub BigIcon()
    lWidth = 64: lHeight = 64
End Sub

Public Property Let HighlightOnClick(ByVal Highlight As Boolean)
    bHighlight = Highlight
End Property

Public Property Let ShowArrowCursor(ByVal Show As Boolean)
    bShowArrowCursor = Show
End Property

Public Property Let HighLightColor(ByVal Color As Double)
    bColorSet = True
    dColor = Color
End Property

Public Property Get CursorName() As String
    CursorName = oShp.Name
End Property

Public Function Create() As StdPicture

    #If Win64 Then
        Dim hwnd As LongLong, hSourceBitmap As LongLong
    #Else
        Dim hwnd As Long, hSourceBitmap As Long
    #End If

    Const CLICK_DIAMETER = 64

    Dim bNextRun  As Boolean
    Dim tCurPos As POINTAPI

    If oUF Is Nothing Then Exit Function
    If oShp Is Nothing Then Exit Function
   
    hSourceBitmap = ShapeToBitmap(oShp)

    If hSourceBitmap Then

        If lWidth = 0 Then lWidth = 32: lHeight = 32

        If bColorSet = False Then dColor = vbYellow
       
        Set oMouseIcon = BitmapToStdPic(hSourceBitmap, lWidth, lHeight)
        Set oClickMouseIcon1 = BitmapToStdPic(hSourceBitmap, CLICK_DIAMETER, CLICK_DIAMETER, True, 1)
        Set oClickMouseIcon2 = BitmapToStdPic(hSourceBitmap, CLICK_DIAMETER, CLICK_DIAMETER, True, 2)
        Set oClickMouseIcon3 = BitmapToStdPic(hSourceBitmap, CLICK_DIAMETER, CLICK_DIAMETER, True, 3)
        Set oClickMouseIcon4 = BitmapToStdPic(hSourceBitmap, CLICK_DIAMETER, CLICK_DIAMETER, True, 4)
       
        oUF.MousePointer = fmMousePointerCustom
        oUF.MouseIcon = oMouseIcon
       
        Call GetCursorPos(tCurPos)
        Call SetCursorPos(tCurPos.X, tCurPos.Y)

        Call WindowFromAccessibleObject(oUF, hwnd)
       
        Do While IsWindow(hwnd)
            If GetAsyncKeyState(VBA.vbKeyLButton) And bHighlight Then
                Call ShowClickCurosr(bNextRun)
                bNextRun = True
            End If
            DoEvents
        Loop
       
        oUF.MouseIcon = Nothing
       
    End If

End Function




'____________________________________________HELPER ROUTINES________________________________________________________


#If Win64 Then

    Private Function BitmapToStdPic( _
        ByVal hBitmap As LongLong, _
        ByVal Width As Long, _
        ByVal Height As Long, _
        Optional ByVal ShowClickCurosr As Boolean, _
        Optional n As Long _
        ) As StdPicture
   
        Dim hDc As LongLong, hMainDC As LongLong, hAndMaskDC As LongLong, hXorMaskDC As LongLong
        Dim hAndMaskBitmap As LongLong, hXorMaskBitmap As LongLong, ResizedBitmap As LongLong
        Dim hOldMainBitmap As LongLong, hOldAndMaskBitmap As LongLong, hOldXorMaskBitmap As LongLong
        Dim hFillBrush As LongLong, hFrameBrush As LongLong, hRgn As LongLong, hIcon As LongLong

#Else

    Private Function BitmapToStdPic( _
        ByVal hBitmap As Long, _
        ByVal Width As Long, _
        ByVal Height As Long, _
        Optional ByVal ShowClickCurosr As Boolean, _
        Optional n As Long _
        ) As StdPicture
   
        Dim hDc As Long, hMainDC As Long, hAndMaskDC As Long, hXorMaskDC As Long
        Dim hAndMaskBitmap As Long, hXorMaskBitmap As Long, ResizedBitmap As Long
        Dim hOldMainBitmap As Long, hOldAndMaskBitmap As Long, hOldXorMaskBitmap As Long
        Dim hFillBrush As Long, hFrameBrush As Long, hRgn As Long, hIcon As Long

#End If


    Dim tBM As BITMAP, tIcoInfo As ICONINFO
    Dim X As Long, Y As Long, lBitPixel As Long


    ResizedBitmap = ResizeBitmap(hBitmap, Width, Height)
   
    Call GetObjectAPI(ResizedBitmap, LenB(tBM), tBM)
   
    hDc = GetDC(0)
   
    hMainDC = CreateCompatibleDC(hDc)
    hAndMaskDC = CreateCompatibleDC(hDc)
    hXorMaskDC = CreateCompatibleDC(hDc)
   
    hAndMaskBitmap = CreateCompatibleBitmap(hDc, tBM.bmWidth, tBM.bmHeight)
    hXorMaskBitmap = CreateCompatibleBitmap(hDc, tBM.bmWidth, tBM.bmHeight)
   
    Call ReleaseDC(0, hDc)
   
    hOldMainBitmap = SelectObject(hMainDC, ResizedBitmap)
    hOldAndMaskBitmap = SelectObject(hAndMaskDC, hAndMaskBitmap)
    hOldXorMaskBitmap = SelectObject(hXorMaskDC, hXorMaskBitmap)
   
    If ShowClickCurosr Then
        If 20 * n > tBM.bmWidth Or 20 * n > tBM.bmHeight Then n = 0
        hRgn = CreateEllipticRgn(0, 0, 20 * n, 20 * n)
        hFillBrush = CreateSolidBrush(dColor)
        hFrameBrush = CreateSolidBrush(vbRed)
        Call OffsetRgn(hRgn, (tBM.bmWidth) / 2 - (20 * n) / 2, (tBM.bmHeight) / 2 - (20 * n) / 2)
        Call FillRgn(hMainDC, hRgn, hFillBrush)
        Call FrameRgn(hMainDC, hRgn, hFrameBrush, 2, 2)
        Call DeleteObject(hRgn)
        Call DeleteObject(hFillBrush)
        Call DeleteObject(hFrameBrush)
    End If

    If bShowArrowCursor Then
        hIcon = CopyIcon(LoadCursor(0, 32512))
        Call DrawIcon(hMainDC, (tBM.bmWidth) / 2, (tBM.bmHeight) / 2, hIcon)
        Call DestroyIcon(hIcon)
    End If

    For X = 0 To tBM.bmWidth
        For Y = 0 To tBM.bmHeight
           lBitPixel = GetPixel(hMainDC, X, Y)
            If lBitPixel = RGB(255, 255, 255) Then
                Call SetPixel(hAndMaskDC, X, Y, RGB(255, 255, 255))
                Call SetPixel(hXorMaskDC, X, Y, RGB(0, 0, 0))
            Else
                Call SetPixel(hAndMaskDC, X, Y, RGB(0, 0, 0))
                Call SetPixel(hXorMaskDC, X, Y, lBitPixel)
            End If
        Next Y
    Next X

    Call SelectObject(hMainDC, hOldMainBitmap)
    Call SelectObject(hAndMaskDC, hOldAndMaskBitmap)
    Call SelectObject(hXorMaskDC, hOldXorMaskBitmap)

    With tIcoInfo
        .fIcon = True
        .xHotspot = tBM.bmWidth / 2
        .yHotspot = tBM.bmHeight / 2
        .hbmMask = hAndMaskBitmap
        .hbmColor = hXorMaskBitmap
    End With
   
    Set BitmapToStdPic = IconToStdPic(CreateIconIndirect(tIcoInfo))

    Call DeleteDC(hXorMaskDC)
    Call DeleteDC(hAndMaskDC)
    Call DeleteDC(hMainDC)
    Call DeleteObject(hOldMainBitmap)
    Call DeleteObject(hAndMaskBitmap)
    Call DeleteObject(hOldXorMaskBitmap)

End Function



#If Win64 Then

    Private Function IconToStdPic( _
        ByVal Icon As LongLong _
        ) As StdPicture
   
        Dim hPtr As LongLong

#Else

    Private Function IconToStdPic( _
        ByVal Icon As Long _
        ) As StdPicture
   
        Dim hPtr As Long

#End If


    Const IMAGE_ICON = 1
    Const PICTYPE_ICON = 3
    Const LR_COPYRETURNORG = &H4
    Const S_OK = 0

    Dim IID_IDispatch As GUID, uPicInfo As uPicDesc
    Dim IPic As StdPicture
   
    hPtr = CopyImage(Icon, IMAGE_ICON, 0, 0, LR_COPYRETURNORG)

    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With

    With uPicInfo
        .Size = Len(uPicInfo)
        .Type = PICTYPE_ICON
        .hPic = hPtr
        .hPal = 0
    End With

    If OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic) = S_OK Then
        Set IconToStdPic = IPic
    End If

End Function



#If Win64 Then
    Private Function ShapeToBitmap( _
        ByVal oShape As Shape _
        ) As LongLong
       
        Dim hPtr As LongLong

#Else

    Private Function ShapeToBitmap( _
        ByVal oShape As Shape _
        ) As Long
       
        Dim hPtr As Long

#End If
   
   
    Const IMAGE_BITMAP = 0
    Const PICTYPE_BITMAP = 1
    Const LR_COPYRETURNORG = &H4
    Const CF_BITMAP = 2

    On Error GoTo errHandler
   
    oShape.CopyPicture xlScreen, xlBitmap
   
    If OpenClipboard(0) Then
        If IsClipboardFormatAvailable(CF_BITMAP) Then
            hPtr = GetClipboardData(CF_BITMAP)
            hPtr = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
            If hPtr Then
                ShapeToBitmap = hPtr
            End If
        End If
    End If

errHandler:

    Call OpenClipboard(0)
    Call EmptyClipboard
    Call CloseClipboard

End Function



#If Win64 Then
    Private Function ResizeBitmap( _
        ByVal hSourceBitmap As LongLong, _
        ByVal Width As Long, _
        ByVal Height As Long _
        ) As LongLong

        Dim lGDIP As LongLong, lBitmap As LongLong, lThumb As LongLong
   
#Else

    Private Function ResizeBitmap( _
        ByVal hSourceBitmap As Long, _
        ByVal Width As Long, _
        ByVal Height As Long _
        ) As Long

        Dim lGDIP As Long, lBitmap As Long, lThumb As Long
   
  #End If

   Const S_OK = 0&
   
    Dim tSI As GdiplusStartupInput
    Dim lRes As Long
   
    tSI.GdiplusVersion = 1
    lRes = GdiplusStartup(lGDIP, tSI)

   If lRes = S_OK Then
      lRes = GdipCreateBitmapFromHBITMAP(hSourceBitmap, 0, lBitmap)
      If lRes = S_OK Then
         lRes = GdipGetImageThumbnail(lBitmap, Width, Height, lThumb, 0, 0)
         If lRes = S_OK Then
            lRes = GdipCreateHBITMAPFromBitmap(lThumb, hSourceBitmap, 0)
             ResizeBitmap = hSourceBitmap
            GdipDisposeImage lThumb
         End If
         GdipDisposeImage lBitmap
      End If
      GdiplusShutdown lGDIP
   End If

   If lRes Then Err.Raise 5

End Function



Private Sub ShowClickCurosr(ByVal NextRun As Boolean)

    Dim tCurPos As POINTAPI
   
    If NextRun = False Then NextRun = True: Exit Sub

    oUF.MouseIcon = oClickMouseIcon1
    Call GetCursorPos(tCurPos)
    Call SetCursorPos(tCurPos.X, tCurPos.Y)
    Call Delay(0.1)

    oUF.MouseIcon = oClickMouseIcon2
    Call GetCursorPos(tCurPos)
    Call SetCursorPos(tCurPos.X, tCurPos.Y)
    Call Delay(0.1)

    oUF.MouseIcon = oClickMouseIcon3
    Call GetCursorPos(tCurPos)
    Call SetCursorPos(tCurPos.X, tCurPos.Y)
    Call Delay(0.1)

    oUF.MouseIcon = oClickMouseIcon4
    Call GetCursorPos(tCurPos)
    Call SetCursorPos(tCurPos.X, tCurPos.Y)
    Call Delay(0.1)

    oUF.MouseIcon = oMouseIcon
    Call GetCursorPos(tCurPos)
    Call SetCursorPos(tCurPos.X, tCurPos.Y)

End Sub


Private Sub Delay(ByVal HowLong As Single)

    #If Win64 Then
        Dim hwnd As LongLong
    #Else
        Dim hwnd As Long
    #End If

    Dim t As Single
   
    Call WindowFromAccessibleObject(oUF, hwnd)
   
    t = Timer
    Do
        DoEvents
    Loop Until Timer - t >= HowLong Or IsWindow(hwnd) = 0

End Sub


Public Sub SaveCursorToDisk(ByVal FilePathName As String)

    Dim sFilePath As String, sFileName As String, sExtensionName As String
   
    If Not oMouseIcon Is Nothing Then
        With CreateObject("Scripting.FileSystemObject")
            sFilePath = .GetParentFolderName(FilePathName)
            sFileName = .GetBaseName(FilePathName)
            sExtensionName = .GetExtensionName(FilePathName)
            If .FolderExists(sFilePath) Then
                If UCase(sExtensionName) <> UCase("ico") Then
                    sExtensionName = "ico"
                End If
            Else
                MsgBox "Cursor not saved to disk." & vbCrLf & "Invalid file path.", , "Error!"
                Exit Sub
            End If
            stdole.SavePicture oMouseIcon, sFilePath & "\" & sFileName & "." & sExtensionName
        End With
    End If

End Sub




UserForm code:
VBA Code: 
Option Explicit

Private oCursorFromShape As Cls_MouseCursorFromShape

Private Sub btn_Circle_Click()

    Set oCursorFromShape = New Cls_MouseCursorFromShape
   
    With oCursorFromShape
        Set .ParentForm = Me
        Set .SourceShape = Sheet1.Shapes("Circle")
        .BigIcon
        .HighlightOnClick = True
        .HighLightColor = vbGreen
        .ShowArrowCursor = True
        .Create
        .SaveCursorToDisk Environ("Temp") & "\Circle.ico"
    End With

End Sub


Private Sub btn_Cross_Click()

    Set oCursorFromShape = New Cls_MouseCursorFromShape
   
    With oCursorFromShape
        Set .SourceShape = Sheet1.Shapes("Cross")
        Set .ParentForm = Me
        .BigIcon
        .HighlightOnClick = True
        .HighLightColor = vbYellow
        .ShowArrowCursor = True
        .Create
    End With

End Sub


Private Sub btn_Freeform_Click()

    Set oCursorFromShape = New Cls_MouseCursorFromShape
   
    With oCursorFromShape
        Set .ParentForm = Me
        Set .SourceShape = Sheet1.Shapes("Freeform")
        .SmallIcon
        '.HighlightOnClick = True
        .Create
    End With

End Sub


Private Sub btn_Clock_Click()

    Set oCursorFromShape = New Cls_MouseCursorFromShape
   
    With oCursorFromShape
        Set .ParentForm = Me
        Set .SourceShape = Sheet1.Shapes("Clock")
        .BigIcon
        .HighlightOnClick = True
        .HighLightColor = vbRed
        .ShowArrowCursor = True
        .Create
    End With

End Sub


Private Sub btn_Hello_Click()

    Set oCursorFromShape = New Cls_MouseCursorFromShape
   
    With oCursorFromShape
        Set .ParentForm = Me
        Set .SourceShape = Sheet1.Shapes("Hello")
        .BigIcon
        .HighlightOnClick = True
        .HighLightColor = vbMagenta
        .ShowArrowCursor = False
        .Create
    End With

End Sub


Private Sub btn_Save_Click()

    Dim vFile As Variant

    If oCursorFromShape Is Nothing Then
        MsgBox "Create a custom cursor first.", , "error."
        Exit Sub
    End If

    vFile = Application.GetSaveAsFilename(InitialFileName:=oCursorFromShape.CursorName, _
    fileFilter:="Icon files (*.ico), *.ico")
    If vFile <> False Then
        oCursorFromShape.SaveCursorToDisk FilePathName:=vFile
    End If

End Sub
 
Upvote 0
Jaafar, you're my truly master. Little grasshopper here. I'll be trying this in a while, but looks very promising.
 
Upvote 0
You must log in or register to reply here.

Similar threads

Jaafar Tribak
  • Question Question
KeyPress Event for Worksheet Cells (Subclassing Without Crashing)
Replies
0
Views
252
Jaafar Tribak
Jaafar Tribak
M
  • Question Question
Please help me to correct Excel VBA code!
Replies
1
Views
328
Minh Tuan VN
M
S
  • Solved
Hide userform title bar, and locking the userform into a relative position on the application.
2
Replies
16
Views
483
Jaafar Tribak
Jaafar Tribak
Jaafar Tribak
  • Question Question
Capturing the Paste Event (API Hooking - Redirection)
Replies
4
Views
790
Jaafar Tribak
Jaafar Tribak
T
  • Solved
Chart point must move to point of click in chart
Replies
2
Views
635
tigger_na
T

Forum statistics

Threads
1,223,886
Messages
6,175,196
Members
452,616
Latest member
intern444

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top