Cool Class for making Floating Shapes !

Jaafar Tribak · Jun 23, 2019

Hi,

I coded this class recently and thought I would post it here.

Workbook demo.

Basically, it is just a standard userform (manipulated with the windows API) that implements a custom Interface (IFloatingShape) for easy & flexible use.

One good thing about this API based class is that it doesn't use timers, loops, subclassing etc- all of which could compromise the stability of the code... Plus the entire code is self-contained in the userform module... Just plug & play.

The class should allow the user to create an 'unlimited' number of clones of worksheet shapes ... these clone shapes floate over the worksheet screen area so they don't scroll out of view.

I have added some Properties to the floating shapes such as optional tooltip, context menu,onaction macro ,custom mouse icon etc...

1- Interface:

Code:

Option Explicit

Public Property Set SeedShape(ByVal Shape As Shape)

End Property

Public Property Let FloatingShapeName(ByVal ShapeName As String)

End Property

Public Property Get FloatingShapeName() As String

End Property

Public Property Let FloatingShapeClickMacro(ByVal Macro As String)

End Property

Public Property Let StickToParentWorksheet(ByVal Stick As Boolean)

End Property

Public Property Get Index() As Integer

End Property

Public Property Get FloatingShapesCount() As Integer

End Property

Public Property Let TooltipText(ByVal vNewValue As String)

End Property

Public Sub DeleteAllFloatingShapes()

End Sub

Public Sub Create()

End Sub

2- UserForm Code:

Code:

Option Explicit

Implements IFloatingShape

Private WithEvents ws As Worksheet
Private WithEvents wb As Workbook
Private WithEvents cmb As CommandBars

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type uPicDesc
    Size As Long
    Type As Long
    #If VBA7 Then
        hPic As LongPtr
        hPal As LongPtr
    #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 InitCommonControlsEx
   Size As Long
   ICC As Long
End Type

Private Type TOOLINFO
   cbSize    As Long
   uFlags    As Long
   #If VBA7 Then
        hwnd      As LongPtr
        uId       As LongPtr
        cRect     As RECT
        hinst     As LongPtr
   #Else
        hwnd      As Long
        uId       As Long
        cRect     As RECT
        hinst     As Long
   #End If
   lpszText  As String
End Type

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongPtr) As LongPtr
    #Else
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
    #End If

    Private Declare PtrSafe Function OleCreatePictureIndirectAut Lib "oleaut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare PtrSafe Function OleCreatePictureIndirectPro Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    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 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 LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As LongPtr
    Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As Long
    Private Declare PtrSafe Function DrawMenuBar Lib "user32.dll" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function WindowFromAccessibleObject Lib "Oleacc" (ByVal pacc As IAccessible, phwnd As LongPtr) As Long
    Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As LongPtr, ByVal crKey As Long, ByVal bAlpha As Long, ByVal dwFlags As Long) As Long
    Private Declare PtrSafe Function SetParent Lib "user32" (ByVal hWndChild As LongPtr, ByVal hWndNewParent As LongPtr) As LongPtr
    Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
    Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
    Private Declare PtrSafe Sub ReleaseCapture Lib "user32" ()
    Private Declare PtrSafe Function SetFocus Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
    Private Declare PtrSafe Function ClientToScreen Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetSystemMenu Lib "user32" (ByVal hwnd As LongPtr, ByVal bRevert As Long) As LongPtr
    Private Declare PtrSafe Function RemoveMenu Lib "user32" (ByVal hMenu As LongPtr, ByVal nPosition As Long, ByVal wFlags As Long) As Long
    Private Declare PtrSafe Function IsWindowVisible Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function CreatePopupMenu Lib "user32" () As LongPtr
    Private Declare PtrSafe Function DestroyMenu Lib "user32" (ByVal hMenu As LongPtr) As Long
    Private Declare PtrSafe Function SetMenuItemBitmaps Lib "user32" (ByVal hMenu As LongPtr, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As LongPtr, ByVal hBitmapChecked As LongPtr) As Long
    Private Declare PtrSafe Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As LongPtr, ByVal wFlags As Long, ByVal wIDNewItem As LongPtr, ByVal lpNewItem As Any) As Long
    Private Declare PtrSafe Function TrackPopupMenuEx Lib "user32" (ByVal hMenu As LongPtr, ByVal un As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal hwnd As LongPtr, ByVal lpTPMParams As Long) As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function CreateIconFromResourceEx Lib "user32.dll" (ByRef presbits As Any, ByVal dwResSize As Long, ByVal fIcon As Long, ByVal dwVer As Long, ByVal cxDesired As Long, ByVal cyDesired As Long, ByVal Flags As Long) As LongPtr
    Private Declare PtrSafe Function DestroyIcon Lib "user32" (ByVal hIcon As LongPtr) As Long
    Private Declare PtrSafe Function SetCursor Lib "user32" (ByVal hDragCursor As LongPtr) As LongPtr
    Private Declare PtrSafe Function ClipCursor Lib "user32" (lpRect As Any) As Long
    Private Declare PtrSafe Function InitCommonControlsEx Lib "comctl32.dll" (iccex As InitCommonControlsEx) As Long
    Private Declare PtrSafe Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
    Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByRef lParam As Any) As LongPtr
    Private Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
    Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr

    Private hwnd As LongPtr, hDragCursor As LongPtr, hClickCursor As LongPtr, hToolTip As LongPtr

#Else

    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
    Private Declare Function OleCreatePictureIndirectAut Lib "oleaut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare Function OleCreatePictureIndirectPro Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) 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 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 LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
    Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
    Private Declare Function DrawMenuBar Lib "user32.dll" (ByVal hwnd As Long) As Long
    Private Declare Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As Long) As Long
    Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Long, ByVal dwFlags As Long) As Long
    Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
    Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
    Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Sub ReleaseCapture Lib "user32" ()
    Private Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
    Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
    Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
    Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
    Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
    Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function CreatePopupMenu Lib "user32" () As Long
    Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
    Private Declare Function SetMenuItemBitmaps Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long
    Private Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long
    Private Declare Function TrackPopupMenuEx Lib "user32" (ByVal hMenu As Long, ByVal un As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal hwnd As Long, ByVal lpTPMParams As Long) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function CreateIconFromResourceEx Lib "user32.dll" (ByRef presbits As Any, ByVal dwResSize As Long, ByVal fIcon As Long, ByVal dwVer As Long, ByVal cxDesired As Long, ByVal cyDesired As Long, ByVal Flags As Long) As Long
    Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
    Private Declare Function SetCursor Lib "user32" (ByVal hDragCursor As Long) As Long
    Private Declare Function ClipCursor Lib "user32" (lpRect As Any) As Long
    Private Declare Function InitCommonControlsEx Lib "comctl32.dll" (iccex As InitCommonControlsEx) As Long
    Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
    Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
    Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wFlag As Long) As Long
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long

    Private hwnd As Long, hDragCursor As Long, hClickCursor As Long, hToolTip As Long

#End If


Private Enum ARG_TYPE
    °Shape
    °ICON
    °FaceID
End Enum

Private Enum ICON_TYPE
    °TTNoIcon
    °TTIconInfo
    °TTIconWarning
    °TTIconError
End Enum

Private Const GWL_STYLE As Long = (-16)
Private Const GWL_EXSTYLE = (-20)
Private Const WS_CAPTION = &HC00000
Private Const WS_DLGFRAME = &H400000
Private Const WS_THICKFRAME = &H40000
Private Const WS_EX_DLGMODALFRAME = &H1&
Private Const WS_EX_CLIENTEDGE = &H200
Private Const WS_EX_LAYERED = &H80000
Private Const SWP_NOSIZE = &H1
Private Const SWP_SHOWWINDOW = &H40
Private Const SWP_HIDEWINDOW = &H80
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2
Private Const LWA_COLORKEY = &H1
Private Const IMAGE_BITMAP = 0
Private Const IMAGE_ICON = 1
Private Const PICTYPE_BITMAP = 1
Private Const PICTYPE_ICON = 3
Private Const LR_COPYRETURNORG = &H4
Private Const CF_BITMAP = 2
Private Const S_OK = 0
Private Const TPM_RETURNCMD = &H100&
Private Const MF_BYPOSITION = &H400
Private Const MF_STRING = &H0&
Private Const MF_SEPARATOR = &H800&
Private Const MF_GRAYED = &H1&
Private Const CW_USEDEFAULT = &H80000000
Private Const WS_POPUP = &H80000000
Private Const WM_USER = &H400
Private Const TTS_BALLOON = &H40
Private Const TTS_CLOSE = &H80
Private Const TTM_ADDTOOL = (WM_USER + 4)
Private Const TTM_SETDELAYTIME = (WM_USER + 3)
Private Const TTM_TRACKACTIVATE = (WM_USER + 17)
Private Const TTM_TRACKPOSITION = (WM_USER + 18)
Private Const TTM_SETTITLEA = (WM_USER + 32)
Private Const TTF_TRACK = &H20
Private Const TTF_ABSOLUTE = &H80
Private Const TOOLTIP_SHOW_DELAY = 4 'Secs

Private oShape As Shape
Private sShapeName As String
Private sOnActionMacro As String
Private sToolTipText As String
Private sngTooltipStartTime As Single
Private bStickToParentWorksheet As Boolean
Private bInitFormActivation As Boolean
Private bFormMoving As Boolean
Private bStickPropSet As Boolean
Private bStartMouseMoving As Boolean



Private Property Set IFloatingShape_SeedShape(ByVal RHS As Shape)
    Set oShape = RHS
End Property

Private Property Let IFloatingShape_FloatingShapeName(ByVal RHS As String)
    sShapeName = RHS
End Property

Private Property Get IFloatingShape_FloatingShapeName() As String
    IFloatingShape_FloatingShapeName = sShapeName
End Property

Private Property Let IFloatingShape_FloatingShapeClickMacro(ByVal RHS As String)
    sOnActionMacro = RHS
End Property

Private Property Let IFloatingShape_StickToParentWorksheet(ByVal RHS As Boolean)
    bStickPropSet = True
    bStickToParentWorksheet = RHS
End Property

Private Property Get IFloatingShape_Index() As Integer
    IFloatingShape_Index = FloatingShapeIndex
End Property

Private Property Get IFloatingShape_FloatingShapesCount() As Integer
    IFloatingShape_FloatingShapesCount = FloatingShapesCount
End Property

Private Property Let IFloatingShape_ToolTipText(ByVal RHS As String)
    sToolTipText = RHS
End Property

Private Sub IFloatingShape_DeleteAllFloatingShapes()
    Call DeleteAllFloatingShapes
End Sub

Private Sub IFloatingShape_Create()
    Me.Show vbModeless
End Sub


[COLOR=#008000]'PRIVATE ROUTINES.[/COLOR]
Private Sub UserForm_Initialize()
    Call WindowFromAccessibleObject(Me, hwnd)
    Set wb = ThisWorkbook
    Me.StartUpPosition = 0
    Me.Tag = "Floating"
    Call SetWindowPos(hwnd, 0, -500, 0, 0, 0, SWP_NOSIZE)
    hClickCursor = BuildClickCursor
    hDragCursor = BuildDragCursor
    Me.MousePointer = fmMousePointerCustom
    Me.MouseIcon = PicFromObject(hClickCursor, °ICON)
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = 1 Then
        DestroyIcon hClickCursor
        DestroyIcon hDragCursor
        Call DestroyWindow(GetProp(Application.hwnd, "ToolTip"))
    Else
        Cancel = True
    End If
End Sub

Private Sub UserForm_Activate()
 
    Dim tShapeRect As RECT, tClipAreaRect As RECT, tPt As POINTAPI

    If bInitFormActivation = False Then
        bInitFormActivation = True
        
        Call SetWindowLong(hwnd, GWL_STYLE, (GetWindowLong(hwnd, GWL_STYLE) _
        And (Not WS_CAPTION) And (Not WS_DLGFRAME) And (Not WS_THICKFRAME)))
        
        Call DrawMenuBar(hwnd)
        
        Call SetWindowLong(hwnd, GWL_EXSTYLE, (GetWindowLong(hwnd, GWL_EXSTYLE) _
        And (Not WS_EX_DLGMODALFRAME) And (Not WS_EX_CLIENTEDGE) Or WS_EX_LAYERED))
        
        Call SetLayeredWindowAttributes(hwnd, vbWhite, 0, LWA_COLORKEY)
        
        Call SetWindowPos(hwnd, 0, 0, 0, 0, 0, SWP_NOSIZE)
        
        tClipAreaRect = GetRealVisibleRangeRectPix
        With tClipAreaRect
            tPt.x = .Left
            tPt.y = .Top
            Call ScreenToClient(hwnd, tPt)
        End With
        
        With tShapeRect
            .Left = ObjRect(oShape).Left
            .Top = ObjRect(oShape).Top
            .Right = ObjRect(oShape).Right
            .Bottom = ObjRect(oShape).Bottom
            If bStickToParentWorksheet Or bStickPropSet = False Then
                Set ws = oShape.ControlFormat.Parent
                If ActiveSheet Is oShape.ControlFormat.Parent Then
                    Call SetWindowPos(hwnd, 0, tPt.x, tPt.y, .Right - .Left, .Bottom - .Top, SWP_SHOWWINDOW)
                Else
                    Call SetWindowPos(hwnd, 0, tPt.x, tPt.y, .Right - .Left, .Bottom - .Top, SWP_HIDEWINDOW)
                End If
            Else
                Call SetWindowPos(hwnd, 0, tPt.x, tPt.y, .Right - .Left, .Bottom - .Top, SWP_SHOWWINDOW)
            End If
        End With
        
        Me.PictureSizeMode = fmPictureSizeModeStretch
        Me.Picture = PicFromObject(oShape, °Shape)
        
    End If

End Sub


Private Sub UserForm_Layout()

    Dim tShapeRect As RECT, tClipAreaRect As RECT, tCursorPos As POINTAPI
    
    If bFormMoving Then
        Call GetWindowRect(hwnd, tShapeRect)
        Call GetCursorPos(tCursorPos)
        tClipAreaRect = GetRealVisibleRangeRectPix
        With tClipAreaRect
            .Left = .Left + (tCursorPos.x - tShapeRect.Left)
            .Top = .Top + (tCursorPos.y - tShapeRect.Top)
            .Right = .Right - (tShapeRect.Right - tCursorPos.x)
            .Bottom = .Bottom - (tShapeRect.Bottom - tCursorPos.y) - 10
        End With
        Call ClipCursor(tClipAreaRect)
    End If

End Sub


Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)

    Call SetFocus(hwnd)
    If Button = 1 Then
        Call RemoveToolTip
        Call SetCursor(hDragCursor)
        Call ReleaseCapture
        Call PostMessage(hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0)
    End If
    
    If IsWindow(hToolTip) = 0 And bStartMouseMoving = False Then
        If Len(sToolTipText) Then
            bStartMouseMoving = True
            Call AddToolTip
        End If
    End If
End Sub


Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    
    #If VBA7 Then
        Dim hMenu As LongPtr
    #Else
        Dim hMenu As Long
    #End If
   
    Dim lShowPopupMenu As Long, lFlags As Long, i As Long
    Dim oFaceIdPic1 As StdPicture, oFaceIdPic2 As StdPicture, oFaceIdPic3 As StdPicture
    Dim tCursorPos As POINTAPI
    
    bFormMoving = True
    For i = 0 To 1
        Call RemoveMenu(GetSystemMenu(hwnd, True), 0, MF_BYPOSITION)
    Next i
    If Button = 2 Then
        Call RemoveToolTip
        hMenu = CreatePopupMenu()
        Call AppendMenu(hMenu, MF_STRING, 1, "Floating Shape &Info")
        Call AppendMenu(hMenu, MF_SEPARATOR, 0, "")
        Call AppendMenu(hMenu, MF_STRING, 2, "Delete &This Floating Shape.")
        Call AppendMenu(hMenu, MF_SEPARATOR, 0, "")
        If FloatingShapesCount = 1 Then
            lFlags = MF_STRING Or MF_GRAYED
        Else
            lFlags = MF_STRING
        End If
        Call AppendMenu(hMenu, lFlags, 3, "Delete &All Floating Shapes.")
        Set oFaceIdPic1 = PicFromObject(984, °FaceID)
        Set oFaceIdPic2 = PicFromObject(1953, °FaceID)
        Set oFaceIdPic3 = PicFromObject(7674, °FaceID)
        Call SetMenuItemBitmaps(hMenu, 0, MF_BYPOSITION, oFaceIdPic1, oFaceIdPic1)
        Call SetMenuItemBitmaps(hMenu, 2, MF_BYPOSITION, oFaceIdPic2, oFaceIdPic2)
        Call SetMenuItemBitmaps(hMenu, 4, MF_BYPOSITION, oFaceIdPic3, oFaceIdPic3)
        Call GetCursorPos(tCursorPos)
        lShowPopupMenu = TrackPopupMenuEx(hMenu, TPM_RETURNCMD, tCursorPos.x, tCursorPos.y, hwnd, ByVal 0&)
        
        If lShowPopupMenu = 1 Then
            Call DisplayShapeInfo(tCursorPos)
        ElseIf lShowPopupMenu = 2 Then
            Unload Me
        ElseIf lShowPopupMenu = 3 Then
            Call DeleteAllFloatingShapes
        End If
        Call DestroyMenu(hMenu)
    End If
 
End Sub


Private Sub UserForm_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)

    bFormMoving = False
    If Len(sOnActionMacro) Then
        On Error Resume Next
        Call Application.Run(sOnActionMacro, Me)
    End If

End Sub


Private Function PicFromObject(ByVal Objt As Variant, ByVal ObjType As ARG_TYPE) As IPicture

    #If VBA7 Then
        Dim hPtr As LongPtr, hLib As LongPtr
    #Else
        Dim hPtr As Long, hLib As Long
    #End If

    Dim IID_IDispatch As GUID, uPicinfo As uPicDesc
    Dim iPic As IPicture, lRet As Long, lPictype As Long
    
    On Error GoTo errHandler
    
    Select Case ObjType
        Case °Shape
            Objt.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
            OpenClipboard 0
            hPtr = GetClipboardData(CF_BITMAP)
            hPtr = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
            EmptyClipboard
            CloseClipboard
            lPictype = PICTYPE_BITMAP
        Case °FaceID
            CommandBars.FindControl(ID:=Objt).CopyFace
            Call OpenClipboard(0)
            hPtr = GetClipboardData(CF_BITMAP)
            hPtr = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
            EmptyClipboard
            CloseClipboard
            lPictype = PICTYPE_BITMAP
        Case °ICON
            hPtr = CopyImage(Objt, IMAGE_ICON, 0, 0, 0)
            lPictype = PICTYPE_ICON
    End Select
    
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    With uPicinfo
        .Size = Len(uPicinfo)
        .Type = lPictype
        .hPic = hPtr
        .hPal = 0
    End With
    hLib = LoadLibrary("oleAut32.dll")
    If hLib Then
        lRet = OleCreatePictureIndirectAut(uPicinfo, IID_IDispatch, True, iPic)
    Else
        lRet = OleCreatePictureIndirectPro(uPicinfo, IID_IDispatch, True, iPic)
    End If
    Call FreeLibrary(hLib)
    If lRet = S_OK Then
        Set PicFromObject = iPic
    End If
    Exit Function
    
errHandler:
    Call FreeLibrary(hLib)
    EmptyClipboard
    CloseClipboard
    
End Function


Private Sub DisplayShapeInfo(CurPos As POINTAPI)

    Dim tShapeRect As RECT
    Dim oSeedShape As Shape
    Dim sFloatingShapeName As String, sParentSheetName As String, sMsg As String
    Dim iTotalFolatingShapes As Integer
    Dim sngLeft As Single, sngTop As Single
    Dim bHasToolTip As Boolean, bIsStuckToParentSheet As Boolean
        
    Call GetWindowRect(hwnd, tShapeRect)
    
    iTotalFolatingShapes = FloatingShapesCount
    Set oSeedShape = oShape
    sFloatingShapeName = sShapeName
    bHasToolTip = IIf(Len(sToolTipText), True, False)
    bIsStuckToParentSheet = bStickToParentWorksheet
    sngLeft = ((tShapeRect.Left - ActiveWindow.PointsToScreenPixelsX(0)) * 72 / 96) / (ActiveWindow.Zoom / 100)
    sngTop = ((tShapeRect.Top - ActiveWindow.ActivePane.PointsToScreenPixelsY(0)) * 72 / 96) / (ActiveWindow.Zoom / 100)

    sMsg = vbNewLine & vbNewLine & vbNewLine
    sMsg = sMsg & "* Floating Shape Name:" & String(16, Chr(32)) & "[ " & sFloatingShapeName & " ]" & vbNewLine
    sMsg = sMsg & String(3, Chr(32)) & String(30, Chr(32)) & vbNewLine
    sMsg = sMsg & "* SeedShape Name:                       " & "[ " & oSeedShape.Name & " ]" & vbNewLine
    sMsg = sMsg & String(3, Chr(32)) & String(30, Chr(32)) & vbNewLine
    sMsg = sMsg & "* Index:" & String(44, Chr(32)) & "[ " & FloatingShapeIndex & " ]" & vbNewLine
    sMsg = sMsg & String(3, Chr(32)) & String(30, Chr(32)) & vbNewLine
    sMsg = sMsg & "* Left (In Points):" & String(29, Chr(32)) & "[ " & sngLeft & " ]" & vbNewLine
    sMsg = sMsg & String(3, Chr(32)) & String(30, Chr(32)) & vbNewLine
    sMsg = sMsg & "* Top (In Points):" & String(29, Chr(32)) & "[ " & sngTop & " ]" & vbNewLine
    sMsg = sMsg & String(3, Chr(32)) & String(30, Chr(32)) & vbNewLine
    sMsg = sMsg & "* HasToolTip: " & String(34, Chr(32)) & "[ " & bHasToolTip & " ]" & vbNewLine
    sMsg = sMsg & String(3, Chr(32)) & String(30, Chr(32)) & vbNewLine
    
    sParentSheetName = IIf(bStickToParentWorksheet Xor bStickPropSet, "N/A", oShape.ControlFormat.Parent.Name)
    
    sMsg = sMsg & "* Parent Worksheet: " & String(22, Chr(32)) & "[ " & sParentSheetName & " ]" & vbNewLine
    sMsg = sMsg & String(3, Chr(32)) & String(30, Chr(32)) & vbNewLine
    sMsg = sMsg & "* StuckToParentWorksheet:" & String(11, Chr(32)) & "[ " & CBool(Not (bStickToParentWorksheet Xor bStickPropSet)) & " ]" & vbNewLine
    sMsg = sMsg & String(3, Chr(32)) & String(30, Chr(32)) & vbNewLine
    sMsg = sMsg & "* HasClickMacro:" & String(29, Chr(32)) & "[ " & CBool(Len(sOnActionMacro)) & " ]" & vbNewLine
    sMsg = sMsg & String(3, Chr(32)) & String(30, Chr(32)) & vbNewLine
    sMsg = sMsg & "* Total Floating Shapes:" & String(17, Chr(32)) & "[ " & FloatingShapesCount & " ]"
    
    MsgBox sMsg, vbInformation, "Info For Floating Shape :  '" & sFloatingShapeName & "'"

End Sub

Private Function ObjRect(ByVal Obj As Object) As RECT

    Dim oPane  As Pane
    Set oPane = ThisWorkbook.Windows(1).ActivePane
    
    With Obj
        ObjRect.Left = oPane.PointsToScreenPixelsX(.Left - 1)
        ObjRect.Top = oPane.PointsToScreenPixelsY(.Top - 1)
        ObjRect.Right = oPane.PointsToScreenPixelsX(.Left + .Width)
        ObjRect.Bottom = oPane.PointsToScreenPixelsY(.Top + .Height + 1)
    End With

End Function


Private Function GetRealVisibleRangeRectPix() As RECT

    #If VBA7 Then
        Static hWbk As LongPtr
        Dim hDesk As LongPtr, hVert As LongPtr, hHoriz As LongPtr
    #Else
        Static hWbk As Long
        Dim hDesk As Long, hVert As Long, hHoriz As Long
    #End If
    
    Dim tDeskRect As RECT, WrkbookRect As RECT, VerRect As RECT, HorizRect As RECT, tPt1 As POINTAPI, tpt2 As POINTAPI


    hDesk = FindWindowEx(Application.hwnd, 0, "XLDESK", vbNullString)
    Call GetWindowRect(hDesk, tDeskRect)
    If hWbk = 0 Then hWbk = GetThisWorkbookHwnd
    
    Call GetClientRect(hWbk, WrkbookRect)
    tPt1.x = WrkbookRect.Left: tPt1.y = WrkbookRect.Top
    tpt2.x = WrkbookRect.Right: tpt2.y = WrkbookRect.Bottom
    Call ClientToScreen(hWbk, tPt1)
    Call ClientToScreen(hWbk, tpt2)
    WrkbookRect.Left = tPt1.x: WrkbookRect.Top = tPt1.y
    WrkbookRect.Right = tpt2.x: WrkbookRect.Bottom = tpt2.y
     hVert = FindWindowEx(hWbk, 0, "NUIScrollbar", "Vertical")
     hHoriz = FindWindowEx(hWbk, 0, "NUIScrollbar", "Horizontal")
    If IsWindowVisible(hHoriz) Or ThisWorkbook.Windows(1).DisplayWorkbookTabs Then
        Call GetWindowRect(hHoriz, HorizRect)
    End If
    If IsWindowVisible(hVert) Then
        Call GetWindowRect(hVert, VerRect)
    End If
    
    With Application.ActiveWindow
        GetRealVisibleRangeRectPix.Left = Application.Max(.ActivePane.PointsToScreenPixelsX(.VisibleRange.Cells(1, 1).Left) + (.Zoom / 100), tDeskRect.Left)
        GetRealVisibleRangeRectPix.Top = Application.Max(.ActivePane.PointsToScreenPixelsY(.VisibleRange.Cells(1, 1).Top) + (.Zoom / 100), tDeskRect.Top)
        GetRealVisibleRangeRectPix.Right = Application.Min(WrkbookRect.Right - (VerRect.Right - VerRect.Left), tDeskRect.Right)
        GetRealVisibleRangeRectPix.Bottom = Application.Min(WrkbookRect.Bottom - (HorizRect.Bottom - HorizRect.Top), tDeskRect.Bottom)
    End With

End Function


#If VBA7 Then
    Private Function GetThisWorkbookHwnd() As LongPtr
#Else
    Private Function GetThisWorkbookHwnd() As Long
#End If

    Dim sCaption As String
    
    On Error GoTo xit
    sCaption = ThisWorkbook.Windows(1).Caption
    ThisWorkbook.Windows(1).Caption = "@@{}@@"
    GetThisWorkbookHwnd = FindWindowEx(FindWindowEx(Application.hwnd, 0, "XLDESK", vbNullString), 0, "EXCEL7", "@@{}@@")
xit:
    ThisWorkbook.Windows(1).Caption = sCaption

End Function


Private Function FloatingShapesCount() As Integer

    Dim i As Long
    
    For i = 0 To UserForms.Count - 1
        If UserForms(i).Tag = "Floating" Then
            FloatingShapesCount = FloatingShapesCount + 1
        End If
    Next i

End Function


Private Function FloatingShapeIndex() As Integer

    Dim i As Long
    
    For i = 0 To UserForms.Count - 1
        If UserForms(i) Is Me Then
            FloatingShapeIndex = i + 1
            Exit Function
        End If
    Next i

End Function


Private Sub DeleteAllFloatingShapes()

    Dim oCol As New Collection, oElement As Object, i As Long
    
    For i = 0 To UserForms.Count - 1
        If UserForms(i).Tag = "Floating" Then
            oCol.Add UserForms(i)
        End If
    Next i
    For Each oElement In oCol
        Unload oElement
    Next

End Sub


#If VBA7 Then
    Private Function BuildDragCursor() As LongPtr
#Else
    Private Function BuildDragCursor() As Long
#End If

    ReDim longs(0 To 186) As Long
    
    longs(0) = 0: longs(1) = 40: longs(2) = 32: longs(3) = 64: longs(4) = 262145: longs(5) = 0: longs(6) = 640: longs(7) = 0: longs(8) = 0: longs(9) = 16: longs(10) = 0: longs(11) = 0: longs(12) = 8388608: longs(13) = 32768: longs(14) = 8421376: longs(15) = 128: longs(16) = 8388736: longs(17) = 32896: longs(18) = 12632256: longs(19) = 8421504: longs(20) = 16711680: longs(21) = 65280: longs(22) = 16776960: longs(23) = 255: longs(24) = 16711935: longs(25) = 65535: longs(26) = 16777215: longs(27) = 0: longs(28) = 0: longs(29) = 0
    longs(30) = 0: longs(31) = 0: longs(32) = 0: longs(33) = 0: longs(34) = 0: longs(35) = 0: longs(36) = 151587072: longs(37) = 151587081: longs(38) = 9: longs(39) = 0: longs(40) = -1869611008: longs(41) = -1869574000: longs(42) = 144: longs(43) = 0: longs(44) = 2304: longs(45) = 0: longs(46) = 9: longs(47) = 0: longs(48) = 9437184: longs(49) = 0: longs(50) = 144: longs(51) = 0: longs(52) = 2304: longs(53) = 0: longs(54) = 9: longs(55) = 0: longs(56) = 9437184: longs(57) = 0: longs(58) = 144: longs(59) = 0
    longs(60) = 2304: longs(61) = 0: longs(62) = 9: longs(63) = 0: longs(64) = 9437184: longs(65) = 0: longs(66) = 144: longs(67) = 0: longs(68) = 2304: longs(69) = 0: longs(70) = 9: longs(71) = 0: longs(72) = -1869611008: longs(73) = -1869574000: longs(74) = 144: longs(75) = 0: longs(76) = 151587072: longs(77) = 151587081: longs(78) = 9: longs(79) = 150994944: longs(80) = 144: longs(81) = 0: longs(82) = 0: longs(83) = -1728053248: longs(84) = 153: longs(85) = 0: longs(86) = 0: longs(87) = -1728053248: longs(88) = 153: longs(89) = 0
    longs(90) = 0: longs(91) = -1727463424: longs(92) = 144: longs(93) = 0: longs(94) = 0: longs(95) = -1727463280: longs(96) = 144: longs(97) = 0: longs(98) = 0: longs(99) = -1718026087: longs(100) = 0: longs(101) = 0: longs(102) = 0: longs(103) = -1717989223: longs(104) = 0: longs(105) = 0: longs(106) = 0: longs(107) = -1868981863: longs(108) = 0: longs(109) = 0: longs(110) = 0: longs(111) = -1717986919: longs(112) = 37017: longs(113) = 0: longs(114) = 0: longs(115) = -1717986919: longs(116) = 153: longs(117) = 0: longs(118) = 0: longs(119) = -1717986919
    longs(120) = 144: longs(121) = 0: longs(122) = 0: longs(123) = -1717986919: longs(124) = 0: longs(125) = 0: longs(126) = 0: longs(127) = -1868981863: longs(128) = 0: longs(129) = 0: longs(130) = 0: longs(131) = 10066329: longs(132) = 0: longs(133) = 0: longs(134) = 0: longs(135) = 9476505: longs(136) = 0: longs(137) = 0: longs(138) = 0: longs(139) = 39321: longs(140) = 0: longs(141) = 0: longs(142) = 0: longs(143) = 37017: longs(144) = 0: longs(145) = 0: longs(146) = 0: longs(147) = 153: longs(148) = 0: longs(149) = 0
    longs(150) = 0: longs(151) = 144: longs(152) = 0: longs(153) = 0: longs(154) = 0: longs(155) = -1: longs(156) = -1: longs(157) = -1079317761: longs(158) = 2136339967: longs(159) = -1073745921: longs(160) = 2147481599: longs(161) = -1073745921: longs(162) = 2147481599: longs(163) = -1073745921: longs(164) = 2147481599: longs(165) = -1073745921: longs(166) = 2136339967: longs(167) = -1079317761: longs(168) = -32770: longs(169) = -49156: longs(170) = -49156: longs(171) = -32776: longs(172) = -32904: longs(173) = -208: longs(174) = -240: longs(175) = -255: longs(176) = -57600: longs(177) = -49408: longs(178) = -33024: longs(179) = -256
    longs(180) = -255: longs(181) = -253: longs(182) = -249: longs(183) = -241: longs(184) = -225: longs(185) = -193: longs(186) = -129:
    
    BuildDragCursor = CreateIconFromResourceEx(longs(0), UBound(longs) * 4 + 4, 0&, &H30000, 0, 0, 0&)

End Function


#If VBA7 Then
    Private Function BuildClickCursor() As LongPtr
#Else
    Private Function BuildClickCursor() As Long
#End If

    ReDim longs(0 To 609) As Long
    
    longs(0) = 40: longs(1) = 24: longs(2) = 48: longs(3) = 2097153: longs(4) = 0: longs(5) = 2400: longs(6) = 0: longs(7) = 0: longs(8) = 0: longs(9) = 0: longs(10) = 0: longs(11) = 0: longs(12) = 0: longs(13) = 0: longs(14) = 16711680: longs(15) = 16711680: longs(16) = 0: longs(17) = 16711680: longs(18) = 197263360: longs(19) = -1644167168: longs(20) = -65536: longs(21) = -65536: longs(22) = -65536: longs(23) = -65536: longs(24) = -65536: longs(25) = -65536: longs(26) = -65536: longs(27) = -1711268579: longs(28) = 7453: longs(29) = 8527133
    longs(30) = 0: longs(31) = 15539742: longs(32) = 16719390: longs(33) = 0: longs(34) = 0: longs(35) = 0: longs(36) = 0: longs(37) = 0: longs(38) = 83820544: longs(39) = 83821572: longs(40) = 0: longs(41) = 1476329472: longs(42) = -65536: longs(43) = -1179648: longs(44) = -3473408: longs(45) = -1271659516: longs(46) = -65536: longs(47) = -65536: longs(48) = -65536: longs(49) = -65536: longs(50) = -4193790: longs(51) = -1899773: longs(52) = -604045312: longs(53) = 16711680: longs(54) = 0: longs(55) = 16718362: longs(56) = 16712194: longs(57) = 0: longs(58) = 0: longs(59) = 0
    longs(60) = 0: longs(61) = 0: longs(62) = 83820544: longs(63) = 16712708: longs(64) = 0: longs(65) = -1426128896: longs(66) = -65536: longs(67) = -65536: longs(68) = 1694433280: longs(69) = 16711680: longs(70) = 16711680: longs(71) = 16711680: longs(72) = 16711680: longs(73) = 16711680: longs(74) = -1711341568: longs(75) = -65536: longs(76) = -65536: longs(77) = 1241448448: longs(78) = 16712965: longs(79) = 0: longs(80) = 16711680: longs(81) = 0: longs(82) = 0: longs(83) = 0: longs(84) = 0: longs(85) = 0: longs(86) = 0: longs(87) = 16712708: longs(88) = 16711680: longs(89) = -2015232000
    longs(90) = -2686976: longs(91) = 648609792: longs(92) = 16711680: longs(93) = 16711680: longs(94) = 16711680: longs(95) = 16711680: longs(96) = 16711680: longs(97) = 16711680: longs(98) = 16713222: longs(99) = 1425999623: longs(100) = -3930104: longs(101) = 1744764928: longs(102) = 16711680: longs(103) = 0: longs(104) = 0: longs(105) = 0: longs(106) = 0: longs(107) = 0: longs(108) = 0: longs(109) = 0: longs(110) = 16711680: longs(111) = 16711680: longs(112) = 16711680: longs(113) = -425394176: longs(114) = -6814716: longs(115) = 8520708: longs(116) = 9110532: longs(117) = 0: longs(118) = 16711680: longs(119) = 16711680
    longs(120) = 16711680: longs(121) = 0: longs(122) = 13510439: longs(123) = 10491157: longs(124) = -7400942: longs(125) = -1566701046: longs(126) = 13573662: longs(127) = 6173491: longs(128) = 15411754: longs(129) = 0: longs(130) = 0: longs(131) = 0: longs(132) = 0: longs(133) = 0: longs(134) = 16711680: longs(135) = 16711680: longs(136) = -268500992: longs(137) = -65536: longs(138) = -587268096: longs(139) = 16711680: longs(140) = 16711680: longs(141) = 16711680: longs(142) = 0: longs(143) = 0: longs(144) = 0: longs(145) = 16711680: longs(146) = 16720418: longs(147) = 16717077: longs(148) = -3863026: longs(149) = -642839540
    longs(150) = 6434607: longs(151) = 11611180: longs(152) = 15672356: longs(153) = 0: longs(154) = 0: longs(155) = 0: longs(156) = 0: longs(157) = 0: longs(158) = 16711680: longs(159) = 805240832: longs(160) = -65536: longs(161) = -65536: longs(162) = 16711680: longs(163) = 16711680: longs(164) = 16711680: longs(165) = 0: longs(166) = 0: longs(167) = 0: longs(168) = 0: longs(169) = 0: longs(170) = 16715792: longs(171) = 16713479: longs(172) = -620822528: longs(173) = -269676014: longs(174) = 1884694825: longs(175) = 9051678: longs(176) = 10753558: longs(177) = 0: longs(178) = 0: longs(179) = 83820544
    longs(180) = 83820544: longs(181) = 0: longs(182) = 251592704: longs(183) = -1241579520: longs(184) = -4520699: longs(185) = -1095760378: longs(186) = 5397: longs(187) = 5654: longs(188) = 16711680: longs(189) = 0: longs(190) = 0: longs(191) = 0: longs(192) = 0: longs(193) = 0: longs(194) = 16714250: longs(195) = 16713222: longs(196) = 822018048: longs(197) = -206363355: longs(198) = -10016471: longs(199) = 10622486: longs(200) = 12129043: longs(201) = 0: longs(202) = 0: longs(203) = 33488896: longs(204) = 16711680: longs(205) = 65535: longs(206) = -2030108672: longs(207) = -64251: longs(208) = -65536: longs(209) = 16783898
    longs(210) = 4883: longs(211) = 3855: longs(212) = 0: longs(213) = 0: longs(214) = 0: longs(215) = 0: longs(216) = 0: longs(217) = 0: longs(218) = 16711680: longs(219) = 0: longs(220) = 16711680: longs(221) = -208333033: longs(222) = -10147286: longs(223) = 10753815: longs(224) = 11998228: longs(225) = 0: longs(226) = 0: longs(227) = 16711680: longs(228) = 0: longs(229) = 16711680: longs(230) = -1073807360: longs(231) = -65536: longs(232) = 1224739852: longs(233) = 4883: longs(234) = 2827: longs(235) = 2827: longs(236) = 12593: longs(237) = 0: longs(238) = 0: longs(239) = 0
    longs(240) = 0: longs(241) = 0: longs(242) = 16711680: longs(243) = 16711680: longs(244) = 16711680: longs(245) = -320464872: longs(246) = -10081493: longs(247) = 10819608: longs(248) = 11605269: longs(249) = 0: longs(250) = 0: longs(251) = 16062488: longs(252) = 14811136: longs(253) = 1597505536: longs(254) = -1594425344: longs(255) = 1459552256: longs(256) = 13041664: longs(257) = 9049108: longs(258) = 13901342: longs(259) = 16719390: longs(260) = 16718105: longs(261) = 16719133: longs(262) = 16719390: longs(263) = 16726329: longs(264) = 16725044: longs(265) = 16711680: longs(266) = 16711680: longs(267) = 65535: longs(268) = 16711680: longs(269) = -842588385
    longs(270) = -9228240: longs(271) = 10887714: longs(272) = 11410974: longs(273) = 0: longs(274) = 0: longs(275) = 16715792: longs(276) = 586813456: longs(277) = -12448756: longs(278) = -692976122: longs(279) = 16711680: longs(280) = 14421261: longs(281) = 747770900: longs(282) = -758247408: longs(283) = 15469580: longs(284) = 12521745: longs(285) = 16715021: longs(286) = 16716563: longs(287) = 16721446: longs(288) = 16719904: longs(289) = 16711680: longs(290) = 16719390: longs(291) = 12395042: longs(292) = 16711680: longs(293) = -1546775789: longs(294) = -8377043: longs(295) = 11017758: longs(296) = 11541018: longs(297) = 0: longs(298) = 0: longs(299) = 16715792
    longs(300) = 1157565452: longs(301) = -11072500: longs(302) = -2816506: longs(303) = -64765: longs(304) = -65536: longs(305) = -10022125: longs(306) = -65536: longs(307) = 16711680: longs(308) = 11995658: longs(309) = 536741382: longs(310) = 16320520: longs(311) = 11409175: longs(312) = 733614353: longs(313) = 16711680: longs(314) = -1663823856: longs(315) = -8249055: longs(316) = 15990784: longs(317) = -1814425584: longs(318) = -6216411: longs(319) = 12261914: longs(320) = 12523287: longs(321) = 0: longs(322) = 0: longs(323) = 16714507: longs(324) = 436144907: longs(325) = -8254709: longs(326) = -65536: longs(327) = -65536: longs(328) = -65536: longs(329) = -9826802
    longs(330) = -65536: longs(331) = 16711680: longs(332) = 427368480: longs(333) = -7071720: longs(334) = 9310224: longs(335) = 1048454180: longs(336) = -763289568: longs(337) = 14352384: longs(338) = 1995309313: longs(339) = -4191220: longs(340) = 769065474: longs(341) = -1949821418: longs(342) = -3926249: longs(343) = 13046547: longs(344) = 12326679: longs(345) = 0: longs(346) = 0: longs(347) = 16712194: longs(348) = 16711680: longs(349) = 1509883904: longs(350) = -419495936: longs(351) = -553713664: longs(352) = 12190981: longs(353) = 1503597331: longs(354) = -892269813: longs(355) = 7542294: longs(356) = 2085889060: longs(357) = -9561317: longs(358) = 8458256: longs(359) = -2088426460
    longs(360) = -8052704: longs(361) = 10753044: longs(362) = 1223820035: longs(363) = -1702394: longs(364) = -1178921964: longs(365) = 1806899995: longs(366) = 1911688204: longs(367) = 14880784: longs(368) = 13178904: longs(369) = 0: longs(370) = 0: longs(371) = 16711937: longs(372) = 16711680: longs(373) = 16711680: longs(374) = 16711680: longs(375) = 16711680: longs(376) = 15007744: longs(377) = 1958088463: longs(378) = -3601653: longs(379) = 9442838: longs(380) = 765728535: longs(381) = -172028402: longs(382) = 14549506: longs(383) = 851253015: longs(384) = -4844524: longs(385) = 1635394339: longs(386) = -108515280: longs(387) = -5555911: longs(388) = -447850665: longs(389) = 684144
    longs(390) = 16721446: longs(391) = 16721446: longs(392) = 16723502: longs(393) = 0: longs(394) = 0: longs(395) = 16713993: longs(396) = 16713993: longs(397) = 65535: longs(398) = 16716563: longs(399) = 11997457: longs(400) = 14484484: longs(401) = -1263399153: longs(402) = -3666932: longs(403) = 11603213: longs(404) = 1241448448: longs(405) = -65536: longs(406) = 402587648: longs(407) = -1883301864: longs(408) = -7526617: longs(409) = -4712938: longs(410) = -1110632167: longs(411) = -1414442928: longs(412) = 460421754: longs(413) = 4167318: longs(414) = 16740464: longs(415) = 16728128: longs(416) = 16729156: longs(417) = 0: longs(418) = 0: longs(419) = 0
    longs(420) = 0: longs(421) = 100597760: longs(422) = 16711680: longs(423) = 33488896: longs(424) = 265029126: longs(425) = -625078256: longs(426) = -3272431: longs(427) = 12388874: longs(428) = -2063663104: longs(429) = -65536: longs(430) = -65536: longs(431) = -1111745251: longs(432) = -465745848: longs(433) = -553776116: longs(434) = 33488896: longs(435) = 104857: longs(436) = 0: longs(437) = 16711680: longs(438) = 16711680: longs(439) = 0: longs(440) = 0: longs(441) = 0: longs(442) = 0: longs(443) = 0: longs(444) = 0: longs(445) = 0: longs(446) = 16711680: longs(447) = 16711680: longs(448) = 299631106: longs(449) = -574551028
    longs(450) = -3470067: longs(451) = 11995658: longs(452) = 1724846867: longs(453) = -3271917: longs(454) = 1860175623: longs(455) = 13700622: longs(456) = 4599342: longs(457) = 16711680: longs(458) = 16711680: longs(459) = 16721446: longs(460) = 0: longs(461) = 0: longs(462) = 0: longs(463) = 0: longs(464) = 0: longs(465) = 0: longs(466) = 0: longs(467) = 0: longs(468) = 0: longs(469) = 0: longs(470) = 16718362: longs(471) = 16716306: longs(472) = 298584843: longs(473) = -710076906: longs(474) = -4843753: longs(475) = 10229784: longs(476) = 750000409: longs(477) = -4515559: longs(478) = 13438221: longs(479) = 14882326
    longs(480) = 2056288: longs(481) = 16711680: longs(482) = 16711680: longs(483) = 0: longs(484) = 0: longs(485) = 0: longs(486) = 0: longs(487) = 0: longs(488) = 0: longs(489) = 0: longs(490) = 0: longs(491) = 0: longs(492) = 0: longs(493) = 0: longs(494) = 16718362: longs(495) = 16716563: longs(496) = 500304651: longs(497) = -390721006: longs(498) = -4779245: longs(499) = 10687765: longs(500) = 701567249: longs(501) = -2093554: longs(502) = 14944778: longs(503) = 16717848: longs(504) = 16711680: longs(505) = 65535: longs(506) = 65535: longs(507) = 0: longs(508) = 0: longs(509) = 0
    longs(510) = 0: longs(511) = 0: longs(512) = 0: longs(513) = 0: longs(514) = 0: longs(515) = 0: longs(516) = 0: longs(517) = 0: longs(518) = 16712965: longs(519) = 16715535: longs(520) = 637468672: longs(521) = -65279: longs(522) = -65022: longs(523) = 132644864: longs(524) = -1812001009: longs(525) = -59625: longs(526) = 16717334: longs(527) = 16725301: longs(528) = 0: longs(529) = 0: longs(530) = 0: longs(531) = 0: longs(532) = 0: longs(533) = 0: longs(534) = 0: longs(535) = 0: longs(536) = 0: longs(537) = 0: longs(538) = 0: longs(539) = 0
    longs(540) = 0: longs(541) = 0: longs(542) = 16712965: longs(543) = 16725301: longs(544) = 16711680: longs(545) = -2097212653: longs(546) = -60139: longs(547) = -608823272: longs(548) = -1965413846: longs(549) = 1224679199: longs(550) = 16719390: longs(551) = 16729413: longs(552) = 0: longs(553) = 0: longs(554) = 0: longs(555) = 0: longs(556) = 0: longs(557) = 0: longs(558) = 0: longs(559) = 0: longs(560) = 0: longs(561) = 0: longs(562) = 0: longs(563) = 0: longs(564) = 0: longs(565) = 0: longs(566) = 16727100: longs(567) = 16726072: longs(568) = 0: longs(569) = 5913660
    longs(570) = 1247624509: longs(571) = -729925833: longs(572) = 6635070: longs(573) = 0: longs(574) = 0: longs(575) = 0: longs(576) = 0: longs(577) = 0: longs(578) = 0: longs(579) = 0: longs(580) = 0: longs(581) = 0: longs(582) = 0: longs(583) = 0: longs(584) = 0: longs(585) = 0: longs(586) = 4161791: longs(587) = 2031871: longs(588) = 2039807: longs(589) = 9388031: longs(590) = 13598718: longs(591) = 13598716: longs(592) = 13631484: longs(593) = 15204344: longs(594) = 15204345: longs(595) = 15204337: longs(596) = 15204339: longs(597) = 15171558: longs(598) = 10977248: longs(599) = 487392
    longs(600) = 1001970: longs(601) = 2050302: longs(602) = 4145406: longs(603) = 16728318: longs(604) = 16730110: longs(605) = 16732158: longs(606) = 16732158: longs(607) = 16732158: longs(608) = 16719871: longs(609) = 16728063:
        
    BuildClickCursor = CreateIconFromResourceEx(longs(0), UBound(longs) * 4 + 4, 1&, &H30000, 0, 0, 0&)

End Function


Private Sub AddToolTip()

    Dim tTooltipPos As POINTAPI, tIccex As InitCommonControlsEx, tToolInfo As TOOLINFO

        Call RemoveToolTip
        With tIccex
            .Size = LenB(tIccex)
            .ICC = &H4 + &H8 + &HFF
        End With
        Call InitCommonControlsEx(tIccex)
        hToolTip = CreateWindowEx(0, "tooltips_class32", 0, WS_POPUP Or TTS_BALLOON Or TTS_CLOSE, _
        CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, 0, 0, GetModuleHandle(vbNullString), 0)
        Call SetProp(Application.hwnd, "ToolTip", hToolTip)
        If hToolTip Then
            With tToolInfo
                .cbSize = LenB(tToolInfo)
                Call GetWindowRect(hwnd, .cRect)
                .hwnd = hwnd
                .uFlags = TTF_TRACK Or IIf(InStr(1, sToolTipText, vbNewLine) Or InStr(1, sToolTipText, vbCr), TTF_ABSOLUTE, 0)
                .uId = hwnd
                .lpszText = sToolTipText
            End With
            Call SendMessage(hToolTip, TTM_SETTITLEA, °TTIconInfo, ByVal sShapeName)
            Call SendMessage(hToolTip, TTM_ADDTOOL, 0, tToolInfo)
            With tTooltipPos
                GetCursorPos tTooltipPos
                .x = tTooltipPos.x
                .y = tToolInfo.cRect.Bottom + 2
                Call SendMessage(hToolTip, TTM_TRACKACTIVATE, True, tToolInfo)
                Call SendMessage(hToolTip, TTM_TRACKPOSITION, ByVal 0&, ByVal MakeDWord(CInt(.x), CInt(.y)))
                sngTooltipStartTime = Timer
                Set cmb = Application.CommandBars
                Call cmb_OnUpdate
            End With
        End If

End Sub


Private Sub cmb_OnUpdate()
    On Error Resume Next
    With Application.CommandBars
        .FindControl(ID:=2040).Enabled = Not .FindControl(ID:=2040).Enabled
    End With
    Call Delay(TOOLTIP_SHOW_DELAY) '4 secs tooltip show delay
End Sub


Private Sub Delay(ByVal HowLong As Single)
    
    Dim MouseLoc As POINTAPI, sngInitTimer As Single
    
    On Error Resume Next
    GetCursorPos MouseLoc
    #If VBA7 And Win64 Then
        Dim lngPtr As LongLong, hwndFromPoint As LongLong
        CopyMemory lngPtr, MouseLoc, LenB(MouseLoc)
        hwndFromPoint = WindowFromPoint(lngPtr)
    #Else
        Dim hwndFromPoint As Long
        hwndFromPoint = WindowFromPoint(MouseLoc.x, MouseLoc.y)
    #End If
    If GetNextWindow(hwnd, 5) <> hwndFromPoint Then
        Set cmb = Nothing: bStartMouseMoving = False
        Call RemoveToolTip
    End If
    If Timer - sngTooltipStartTime >= HowLong Then
        Call RemoveToolTip
    End If
End Sub


Private Sub RemoveToolTip()
    Call DestroyWindow(hToolTip)
End Sub


Private Function MakeDWord(loword As Integer, hiword As Integer) As Long
    MakeDWord = (hiword * &H10000) Or (loword And &HFFFF&)
End Function


Private Sub wb_Activate()
    If bStickToParentWorksheet = False Then
        Call ShowWindow(hwnd, 1)
    Else
        If ActiveSheet Is oShape.ControlFormat.Parent Then
            Call ShowWindow(hwnd, 1)
        End If
    End If
End Sub

Private Sub wb_Deactivate()
    Call ShowWindow(hwnd, 0)
End Sub

Private Sub ws_Activate()
    Call ShowWindow(hwnd, 1)
End Sub

Private Sub ws_Deactivate()
    Call ShowWindow(hwnd, 0)
End Sub

Private Sub wb_BeforeClose(Cancel As Boolean)
    Unload Me
End Sub

3- Code Usage:

Code:

Option Explicit

Private oFloatingShape As IFloatingShape


Public Sub CreateFloatingShapesTest()

    With Sheet1
    
        Select Case Application.Caller
        
            Case "Button 1"
            
                Call MakeFloatingCopyOfShape( _
                    Shape:=.Shapes("Circle"), _
                    FolatingShapeName:="Floating " & .Shapes("Circle").Name, _
                    OnActionMacro:="OnActionMacro", _
                    TooltipText:="Click for OnAction Macro, Right-Click for Info or Drag around. ", _
                    StickToParentWorksheet:=True)
            
            Case "Button 2"
                    Call MakeFloatingCopyOfShape( _
                    Shape:=.Shapes("Rectangle"), _
                    FolatingShapeName:="Floating " & .Shapes("Rectangle").Name, _
                    OnActionMacro:="OnActionMacro", _
                    TooltipText:="Click for OnAction Macro, Right-Click for Info or Drag around. ", _
                    StickToParentWorksheet:=True)        
        
            Case "Button 3"
                    Call MakeFloatingCopyOfShape( _
                    Shape:=.Shapes("Triangle"), _
                    FolatingShapeName:="Floating " & .Shapes("Triangle").Name, _
                    OnActionMacro:="OnActionMacro", _
                    TooltipText:="Click for OnAction Macro, Right-Click for Info or Drag around. ", _
                    StickToParentWorksheet:=True)        
        
            Case "Button 4"
                    Call MakeFloatingCopyOfShape( _
                    Shape:=.Shapes("Star"), _
                    FolatingShapeName:="Floating " & .Shapes("Star").Name, _
                    OnActionMacro:="OnActionMacro", _
                    TooltipText:="Click for OnAction Macro, Right-Click for Info or Drag around. ", _
                    StickToParentWorksheet:=True)        
        
            Case "Button 5"
                    Call MakeFloatingCopyOfShape( _
                    Shape:=.Shapes("Picture 1"), _
                    FolatingShapeName:="Floating " & .Shapes("Picture 1").Name, _
                    OnActionMacro:="OnActionMacro", _
                    TooltipText:="Click for OnAction Macro, Right-Click for Info or Drag around. ", _
                    StickToParentWorksheet:=True)        
            
            Case "Button 6"
                    Call MakeFloatingCopyOfShape( _
                    Shape:=.Shapes("Picture 2"), _
                    FolatingShapeName:="Floating " & .Shapes("Picture 2").Name, _
                    OnActionMacro:="OnActionMacro", _
                    TooltipText:="Click for OnAction Macro, Right-Click for Info or Drag around. ", _
                    StickToParentWorksheet:=True)        
        
        End Select
    
    End With

End Sub


Public Sub DeleteAllFloatingShapes()
    If Not oFloatingShape Is Nothing Then
        oFloatingShape.DeleteAllFloatingShapes
        Set oFloatingShape = Nothing
    End If
End Sub



Public Sub MakeFloatingCopyOfShape( _
    ByVal Shape As Shape, _
    Optional ByVal FolatingShapeName As String, _
    Optional ByVal OnActionMacro As String, _
    Optional ByVal TooltipText As String, _
    Optional ByVal StickToParentWorksheet As Boolean = True _
)

    Set oFloatingShape = New frm_FloatingShape
    
    With oFloatingShape
        Set .SeedShape = Shape
        .FloatingShapeName = FolatingShapeName
        .FloatingShapeClickMacro = OnActionMacro
        .StickToParentWorksheet = True
        .TooltipText = TooltipText
        .Create
    End With

End Sub


[COLOR=#008000]'GENERIC ONACTION MACRO.[/COLOR]
Public Sub OnActionMacro(ByVal Shape As IFloatingShape)
    MsgBox "You Clicked On Floating Shape: '" & Shape.FloatingShapeName & "'"
End Sub

Tested on excel 2016 64bit Win 2010 64bit and excel 2010 32bit Win 7

Norie · Jun 24, 2019

Jaafar

It's Office 365 32-bit.

Yongle · Jun 24, 2019

My setup is same as Norie

Jaafar Tribak · Jun 24, 2019

Norie said:
Jaafar

It's Office 365 32-bit.

@Yongle as well.

I meant the edition and bitness of the Windows Operating System.

Regards.

Norie · Jun 24, 2019

Jaafar

Windows 10 64-bit.

Yongle · Jun 24, 2019

@Jaafar Tribak
I am also Windows 10 64 bit
and build is 17134.829

Jaafar Tribak · Oct 22, 2020

Hi guys,

I have revisited this old thread and have updated the initial code so it doesn't rely on the SetLayeredWindowAttributes API to make the floating shapes layered which was the main reason it didn't work on some systems. Here, I use Region APIs to achieve the background transparency which seems to work ok after testing the code on a couple of different plateforms... Also added some tweaks for parent-child window docking, zoom etc...

Note: This code works best with basic shapes and pictures with little formatting... Shapes with shadows, thick borders, 3D effects or with orientation may not produce accurate floating cloned-shapes.

Workbook Demo

1- Interface (IFloatingShape) :

VBA Code:

Option Explicit

Public Property Set SeedShape(ByVal Shape As Shape)

End Property

Public Property Let FloatingShapeName(ByVal ShapeName As String)

End Property

Public Property Get FloatingShapeName() As String

End Property

Public Property Let FloatingShapeClickMacro(ByVal Macro As String)

End Property

Public Property Let StickToParentWorksheet(ByVal Stick As Boolean)

End Property

Public Property Get Index() As Integer

End Property

Public Property Get FloatingShapesCount() As Integer

End Property

Public Property Let TooltipText(ByVal vNewValue As String)

End Property

Public Sub DeleteAllFloatingShapes()

End Sub

Public Sub Create()

End Sub

2- UserForm Code (frm_FloatingShape)

VBA Code:

Option Explicit

Implements IFloatingShape

Private WithEvents ws As Worksheet
Private WithEvents wb As Workbook
Private WithEvents cmb1 As CommandBars
Private WithEvents cmb2 As CommandBars

Private Enum ARG_TYPE
    °Shape
    °ICON
    °FaceID
End Enum

Private Enum ICON_TYPE
    °TTNoIcon
    °TTIconInfo
    °TTIconWarning
    °TTIconError
End Enum

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom 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 InitCommonControlsEx
   Size As Long
   ICC As Long
End Type

Private Type TOOLINFO
   cbSize    As Long
   uFlags    As Long
   #If Win64 Then
        hWnd      As LongLong
        uId       As LongLong
        cRect     As RECT
        hinst     As LongLong
   #Else
        hWnd      As Long
        uId       As Long
        cRect     As RECT
        hinst     As Long
   #End If
   lpszText  As String
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


#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hWnd As LongLong, ByVal nIndex As Long) As LongLong
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hWnd As LongLong, ByVal nIndex As Long, ByVal dwNewLong As LongLong) As LongLong
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongLong) As LongLong
    #Else
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
    #End If

    Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    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 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 DrawMenuBar Lib "user32.dll" (ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As LongPtr) As Long
    Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hWnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function SetParent Lib "user32" (ByVal hWndChild As LongPtr, ByVal hWndNewParent As LongPtr) As LongPtr
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
    Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
    Private Declare PtrSafe Sub ReleaseCapture Lib "user32" ()
    Private Declare PtrSafe Function SetFocus Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal nCmdShow As Long) As Long
    Private Declare PtrSafe Function ClientToScreen Lib "user32" (ByVal hWnd As LongPtr, lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function ScreenToClient Lib "user32" (ByVal hWnd As LongPtr, lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetSystemMenu Lib "user32" (ByVal hWnd As LongPtr, ByVal bRevert As Long) As LongPtr
    Private Declare PtrSafe Function RemoveMenu Lib "user32" (ByVal hMenu As LongPtr, ByVal nPosition As Long, ByVal wFlags As Long) As Long
    Private Declare PtrSafe Function IsWindowVisible Lib "user32" (ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Function CreatePopupMenu Lib "user32" () As LongPtr
    Private Declare PtrSafe Function DestroyMenu Lib "user32" (ByVal hMenu As LongPtr) As Long
    Private Declare PtrSafe Function SetMenuItemBitmaps Lib "user32" (ByVal hMenu As LongPtr, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As LongPtr, ByVal hBitmapChecked As LongPtr) As Long
    Private Declare PtrSafe Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As LongPtr, ByVal wFlags As Long, ByVal wIDNewItem As LongPtr, ByVal lpNewItem As Any) As Long
    Private Declare PtrSafe Function TrackPopupMenuEx Lib "user32" (ByVal hMenu As LongPtr, ByVal un As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal hWnd As LongPtr, ByVal lpTPMParams As Long) As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function CreateIconFromResourceEx Lib "user32.dll" (ByRef presbits As Any, ByVal dwResSize As Long, ByVal fIcon As Long, ByVal dwVer As Long, ByVal cxDesired As Long, ByVal cyDesired As Long, ByVal Flags As Long) As LongPtr
    Private Declare PtrSafe Function DestroyIcon Lib "user32" (ByVal hIcon As LongPtr) As Long
    Private Declare PtrSafe Function SetCursor Lib "user32" (ByVal hDragCursor As LongPtr) As LongPtr
    Private Declare PtrSafe Function ClipCursor Lib "user32" (lpRect As Any) As Long
    Private Declare PtrSafe Function InitCommonControlsEx Lib "comctl32.dll" (iccex As InitCommonControlsEx) As Long
    Private Declare PtrSafe Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
    Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByRef lParam As Any) As LongPtr
    Private Declare PtrSafe Function IsWindow Lib "user32" (ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hWnd As LongPtr, ByVal wFlag As Long) As LongPtr
    Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPtr
    Private Declare PtrSafe Function CombineRgn Lib "gdi32" (ByVal hDestRgn As LongPtr, ByVal hSrcRgn1 As LongPtr, ByVal hSrcRgn2 As LongPtr, ByVal nCombineMode As Long) As Long
    Private Declare PtrSafe Function SetWindowRgn Lib "user32" (ByVal hWnd As LongPtr, ByVal hRgn As LongPtr, ByVal bRedraw As Long) As Long
    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 CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    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 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 SetActiveWindow Lib "user32" (ByVal hWnd As LongPtr) As LongPtr

    Private hWnd As LongPtr, hDragCursor As LongPtr, hClickCursor As LongPtr, hToolTip As LongPtr

#Else

    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
    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 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 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 DrawMenuBar Lib "user32.dll" (ByVal hWnd As Long) As Long
    Private Declare Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As Long) As Long
    Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
    Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
    Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Sub ReleaseCapture Lib "user32" ()
    Private Declare Function SetFocus Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
    Private Declare Function ClientToScreen Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
    Private Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
    Private Declare Function GetSystemMenu Lib "user32" (ByVal hWnd As Long, ByVal bRevert As Long) As Long
    Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
    Private Declare Function IsWindowVisible Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function CreatePopupMenu Lib "user32" () As Long
    Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
    Private Declare Function SetMenuItemBitmaps Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long
    Private Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long
    Private Declare Function TrackPopupMenuEx Lib "user32" (ByVal hMenu As Long, ByVal un As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal hWnd As Long, ByVal lpTPMParams As Long) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function CreateIconFromResourceEx Lib "user32.dll" (ByRef presbits As Any, ByVal dwResSize As Long, ByVal fIcon As Long, ByVal dwVer As Long, ByVal cxDesired As Long, ByVal cyDesired As Long, ByVal Flags As Long) As Long
    Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
    Private Declare Function SetCursor Lib "user32" (ByVal hDragCursor As Long) As Long
    Private Declare Function ClipCursor Lib "user32" (lpRect As Any) As Long
    Private Declare Function InitCommonControlsEx Lib "comctl32.dll" (iccex As InitCommonControlsEx) As Long
    Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
    Private Declare Function DestroyWindow Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
    Private Declare Function IsWindow Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hWnd As Long, ByVal wFlag As Long) As Long
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
    Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
    Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw 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 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 GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y 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 SetActiveWindow Lib "user32" (ByVal hWnd As Long) As Long

    Private hWnd As Long, hDragCursor As Long, hClickCursor As Long, hToolTip As Long

#End If


Private oShape As Shape
Private sShapeName As String
Private sOnActionMacro As String
Private sToolTipText As String
Private sngTooltipStartTime As Single
Private bStickToParentWorksheet As Boolean
Private bInitFormActivation As Boolean
Private bFormMoving As Boolean
Private bStartMouseMoving As Boolean



'_____________________________________________Interface Members__________________________________________________

Private Property Set IFloatingShape_SeedShape(ByVal RHS As Shape)
    Set oShape = RHS
End Property

Private Property Let IFloatingShape_FloatingShapeName(ByVal RHS As String)
    sShapeName = RHS
End Property

Private Property Get IFloatingShape_FloatingShapeName() As String
    IFloatingShape_FloatingShapeName = sShapeName
End Property

Private Property Let IFloatingShape_FloatingShapeClickMacro(ByVal RHS As String)
    sOnActionMacro = RHS
End Property

Private Property Let IFloatingShape_StickToParentWorksheet(ByVal RHS As Boolean)
    bStickToParentWorksheet = RHS
End Property

Private Property Get IFloatingShape_Index() As Integer
    IFloatingShape_Index = FloatingShapeIndex
End Property

Private Property Get IFloatingShape_FloatingShapesCount() As Integer
    IFloatingShape_FloatingShapesCount = FloatingShapesCount
End Property

Private Property Let IFloatingShape_ToolTipText(ByVal RHS As String)
    sToolTipText = RHS
End Property

Private Sub IFloatingShape_DeleteAllFloatingShapes()
    Call DeleteAllFloatingShapes
End Sub

Private Sub IFloatingShape_Create()

    Const SWP_HIDEWINDOW = &H80
    Const SWP_NOSIZE = &H1
    
    Call WindowFromAccessibleObject(Me, hWnd)
    Set wb = ThisWorkbook
    Set ws = oShape.ControlFormat.Parent
    
    Me.StartUpPosition = 0
    Me.Tag = "Floating"
    hDragCursor = BuildDragCursor
    hClickCursor = BuildClickCursor
    Me.MousePointer = fmMousePointerCustom
    Me.MouseIcon = PicFromObject(hClickCursor, °ICON)
    Call SetWindowPos(hWnd, 0, -200, -200, 0, 0, SWP_NOSIZE + SWP_HIDEWINDOW)

End Sub



'___________________________________________UserForm Event Routines________________________________________________

Private Sub UserForm_Activate()
    Call DispalyForm
End Sub

Private Sub UserForm_Layout()
    Call SetFormClipArea
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = 1 Then
        Call CleanUp
    Else
        Cancel = True
    End If
End Sub

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Call SetFocus(hWnd)
    If Button = 1 Then
        Call SetMouseCapture
    End If
    If IsWindow(hToolTip) = 0 And bStartMouseMoving = False Then
        If Len(sToolTipText) Then
            bStartMouseMoving = True
            Call AddToolTip
        End If
    End If
    Set cmb2 = Application.CommandBars
End Sub

Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Call CreateAndShowRightClickMenu(Button)
End Sub

Private Sub UserForm_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    bFormMoving = False
    If Len(sOnActionMacro) Then
        On Error Resume Next
        Call Application.Run(sOnActionMacro, Me)
    End If
End Sub



'______________________________________________Helper Routines________________________________________________

Private Sub DispalyForm()

    #If Win64 Then
        Dim hRgn As LongLong, hParent As LongLong
    #Else
        Dim hRgn As Long, hParent As Long
    #End If

    Const GWL_STYLE As Long = (-16)
    Const GWL_EXSTYLE = (-20)
    Const WS_CAPTION = &HC00000
    Const WS_SYSMENU = &H80000
    Const WS_THICKFRAME = &H40000
    Const WS_EX_DLGMODALFRAME = &H1&
    Const WS_EX_CLIENTEDGE = &H200
    Const WS_EX_WINDOWEDGE = &H100
    Const SWP_NOSIZE = &H1
    Const SWP_SHOWWINDOW = &H40
    Const SWP_HIDEWINDOW = &H80
    Const WM_SETREDRAW = &HB

    Dim tShapeRect As RECT, tClipAreaRect As RECT, tPt As POINTAPI
    Dim oPic As StdPicture, lTransparentColor As Long

    On Error GoTo errHandler
    
    If bInitFormActivation = False Then
        bInitFormActivation = True
        hParent = FindWindowEx(Application.hWnd, 0, "XLDESK", vbNullString)
        hParent = FindWindowEx(hParent, 0, "EXCEL7", vbNullString)
        'Call SendMessage(hParent, ByVal WM_SETREDRAW, ByVal 0, 0)  ' <== may freeze the screen on some systems !!!
        Application.ScreenUpdating = False
        Call SetWindowLong(hWnd, GWL_STYLE, (GetWindowLong(hWnd, GWL_STYLE) _
        And Not (WS_CAPTION Or WS_THICKFRAME Or WS_SYSMENU)))
        Call DrawMenuBar(hWnd)
        Call SetWindowLong(hWnd, GWL_EXSTYLE, (GetWindowLong(hWnd, GWL_EXSTYLE) _
        And Not (WS_EX_DLGMODALFRAME Or WS_EX_CLIENTEDGE Or WS_EX_WINDOWEDGE)))
        Call SetParent(hWnd, hParent)
        
        Set oPic = CreateStdPicture(oShape, lTransparentColor)
        hRgn = SetRegion(oPic, lTransparentColor)
        Call SetWindowRgn(hWnd, hRgn, True)
        Call DeleteObject(hRgn)
        Me.PictureSizeMode = fmPictureSizeModeStretch
        Set Me.Picture = oPic
        
        Call SetWindowPos(hWnd, 0, 0, 0, 0, 0, SWP_NOSIZE + SWP_HIDEWINDOW)
        tClipAreaRect = GetRealVisibleRangeRectPix
        
        With tClipAreaRect
            tPt.X = .Left
            tPt.Y = .Top
            Call ScreenToClient(hWnd, tPt)
        End With
        
        With tShapeRect
            .Left = ObjRect(oShape).Left * 100 / ActiveWindow.Zoom
            .Top = ObjRect(oShape).Top * 100 / ActiveWindow.Zoom
            .Right = ObjRect(oShape).Right * 100 / ActiveWindow.Zoom
            .Bottom = ObjRect(oShape).Bottom * 100 / ActiveWindow.Zoom
            Call SetWindowPos(hWnd, 0, tPt.X, tPt.Y, .Right - .Left, .Bottom - .Top, SWP_SHOWWINDOW)
        End With
        Call SetActiveWindow(Application.hWnd)
    End If
    
errHandler:
    hParent = FindWindowEx(Application.hWnd, 0, "XLDESK", vbNullString)
    hParent = FindWindowEx(hParent, 0, "EXCEL7", vbNullString)
    Application.ScreenUpdating = True
'    Call SendMessage(hParent, ByVal WM_SETREDRAW, ByVal 1, 0)
    
End Sub

Private Sub SetFormClipArea()

    Dim tShapeRect As RECT, tClipAreaRect As RECT, tCursorPos As POINTAPI

    If bFormMoving Then
        Call GetWindowRect(hWnd, tShapeRect)
        Call GetCursorPos(tCursorPos)
        tClipAreaRect = GetRealVisibleRangeRectPix
        With tClipAreaRect
            .Left = .Left + (tCursorPos.X - tShapeRect.Left)
            .Top = .Top + (tCursorPos.Y - tShapeRect.Top)
            .Right = .Right - (tShapeRect.Right - tCursorPos.X)
            .Bottom = .Bottom - (tShapeRect.Bottom - tCursorPos.Y) - 10
        End With
        Call ClipCursor(tClipAreaRect)
    End If

End Sub

Private Sub CleanUp()

    Call DestroyIcon(hClickCursor)
    Call DestroyIcon(hDragCursor)
    Call DestroyWindow(FindWindow(vbNullString, CStr(hWnd)))
    On Error Resume Next
        Application.DisplayAlerts = False
        Sheets("TempSheet").Delete
    On Error GoTo 0
    
End Sub

Private Sub SetMouseCapture()

    Const WM_NCLBUTTONDOWN = &HA1
    Const HTCAPTION = 2

    Call RemoveToolTip
    Call SetCursor(hDragCursor)
    Call ReleaseCapture
    Call PostMessage(hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0)
    
End Sub

Private Sub CreateAndShowRightClickMenu(ByVal Button As Integer)

    Const TPM_RETURNCMD = &H100&
    Const MF_BYPOSITION = &H400
    Const MF_STRING = &H0&
    Const MF_SEPARATOR = &H800&
    Const MF_GRAYED = &H1&

    #If Win64 Then
        Dim hMenu As LongLong
    #Else
        Dim hMenu As Long
    #End If
  
    Dim lShowPopupMenu As Long, lFlags As Long, i As Long
    Dim oFaceIdPic1 As StdPicture, oFaceIdPic2 As StdPicture, oFaceIdPic3 As StdPicture
    Dim tCursorPos As POINTAPI
    
    bFormMoving = True
    For i = 0 To 1
        Call RemoveMenu(GetSystemMenu(hWnd, True), 0, MF_BYPOSITION)
    Next i
    If Button = 2 Then
        Call RemoveToolTip
        hMenu = CreatePopupMenu()
        Call AppendMenu(hMenu, MF_STRING, 1, "Floating Shape &Info")
        Call AppendMenu(hMenu, MF_SEPARATOR, 0, "")
        Call AppendMenu(hMenu, MF_STRING, 2, "Delete &This Floating Shape.")
        Call AppendMenu(hMenu, MF_SEPARATOR, 0, "")
        If FloatingShapesCount = 1 Then
            lFlags = MF_STRING Or MF_GRAYED
        Else
            lFlags = MF_STRING
        End If
        Call AppendMenu(hMenu, lFlags, 3, "Delete &All Floating Shapes.")
        Set oFaceIdPic1 = PicFromObject(984, °FaceID)
        Set oFaceIdPic2 = PicFromObject(1953, °FaceID)
        Set oFaceIdPic3 = PicFromObject(7674, °FaceID)
        Call SetMenuItemBitmaps(hMenu, 0, MF_BYPOSITION, oFaceIdPic1, oFaceIdPic1)
        Call SetMenuItemBitmaps(hMenu, 2, MF_BYPOSITION, oFaceIdPic2, oFaceIdPic2)
        Call SetMenuItemBitmaps(hMenu, 4, MF_BYPOSITION, oFaceIdPic3, oFaceIdPic3)
        
        Call GetCursorPos(tCursorPos)
        lShowPopupMenu = TrackPopupMenuEx(hMenu, TPM_RETURNCMD, tCursorPos.X, tCursorPos.Y, hWnd, ByVal 0&)
        
        If lShowPopupMenu = 1 Then
            Call DisplayShapeInfo(tCursorPos)
        ElseIf lShowPopupMenu = 2 Then
            Unload Me
        ElseIf lShowPopupMenu = 3 Then
            Call DeleteAllFloatingShapes
        End If
        Call DestroyMenu(hMenu)
    End If

End Sub

Private Function PicFromObject(ByVal Objt As Variant, ByVal ObjType As ARG_TYPE) As StdPicture

    Const IMAGE_BITMAP = 0
    Const IMAGE_ICON = 1
    Const PICTYPE_BITMAP = 1
    Const PICTYPE_ICON = 3
    Const LR_COPYRETURNORG = &H4
    Const CF_BITMAP = 2
    Const S_OK = 0

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

    Dim IID_IDispatch As GUID, uPicInfo As uPicDesc
    Dim IPic As StdPicture, lRet As Long, lPicType As Long
    
    On Error GoTo errHandler
    
    Select Case ObjType
        Case °Shape
            OpenClipboard 0
            hImagePtr = GetClipboardData(CF_BITMAP)
            hImagePtr = CopyImage(hImagePtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
            Call EmptyClipboard
            Call CloseClipboard
            lPicType = PICTYPE_BITMAP
        Case °FaceID
            CommandBars.FindControl(ID:=Objt).CopyFace
            Call OpenClipboard(0)
            hImagePtr = GetClipboardData(CF_BITMAP)
            hImagePtr = CopyImage(hImagePtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
            Call EmptyClipboard
            Call CloseClipboard
            lPicType = PICTYPE_BITMAP
        Case °ICON
            hImagePtr = CopyImage(Objt, IMAGE_ICON, 0, 0, 0)
            lPicType = PICTYPE_ICON
    End Select
    
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    
    With uPicInfo
        .Size = Len(uPicInfo)
        .Type = lPicType
        .hPic = hImagePtr
        .hPal = 0
    End With
        
    lRet = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)

    If lRet = S_OK Then
        Set PicFromObject = IPic
    End If
    
    Exit Function
    
errHandler:

    Call EmptyClipboard
    Call CloseClipboard
    
End Function

Private Sub DisplayShapeInfo(CurPos As POINTAPI)

    Dim tShapeRect As RECT
    Dim oSeedShape As Shape
    Dim sFloatingShapeName As String, sParentSheetName As String, sMsg As String
    Dim iTotalFolatingShapes As Integer
    Dim sngLeft As Single, sngTop As Single
    Dim bHasToolTip As Boolean
    
    Call GetWindowRect(hWnd, tShapeRect)
    
    iTotalFolatingShapes = FloatingShapesCount
    Set oSeedShape = oShape
    sFloatingShapeName = sShapeName
    bHasToolTip = IIf(Len(sToolTipText), True, False)
    
    sngLeft = ((tShapeRect.Left - ActiveWindow.PointsToScreenPixelsX(0)) * 72 / 96) / (ActiveWindow.Zoom / 100)
    sngTop = ((tShapeRect.Top - ActiveWindow.ActivePane.PointsToScreenPixelsY(0)) * 72 / 96) / (ActiveWindow.Zoom / 100)

    sMsg = vbNewLine & vbNewLine & vbNewLine
    sMsg = sMsg & "* Floating Shape Name:" & String(16, Chr(32)) & "[ " & sFloatingShapeName & " ]" & vbNewLine
    sMsg = sMsg & String(3, Chr(32)) & String(30, Chr(32)) & vbNewLine
    sMsg = sMsg & "* SeedShape Name:                       " & "[ " & oSeedShape.Name & " ]" & vbNewLine
    sMsg = sMsg & String(3, Chr(32)) & String(30, Chr(32)) & vbNewLine
    sMsg = sMsg & "* Index:" & String(44, Chr(32)) & "[ " & FloatingShapeIndex & " ]" & vbNewLine
    sMsg = sMsg & String(3, Chr(32)) & String(30, Chr(32)) & vbNewLine
    sMsg = sMsg & "* Left (In Points):" & String(29, Chr(32)) & "[ " & sngLeft & " ]" & vbNewLine
    sMsg = sMsg & String(3, Chr(32)) & String(30, Chr(32)) & vbNewLine
    sMsg = sMsg & "* Top (In Points):" & String(29, Chr(32)) & "[ " & sngTop & " ]" & vbNewLine
    sMsg = sMsg & String(3, Chr(32)) & String(30, Chr(32)) & vbNewLine
    sMsg = sMsg & "* HasToolTip: " & String(34, Chr(32)) & "[ " & bHasToolTip & " ]" & vbNewLine
    sMsg = sMsg & String(3, Chr(32)) & String(30, Chr(32)) & vbNewLine
    
    sParentSheetName = IIf(bStickToParentWorksheet, oShape.ControlFormat.Parent.Name, "N/A")
    
    sMsg = sMsg & "* Parent Worksheet: " & String(22, Chr(32)) & "[ " & sParentSheetName & " ]" & vbNewLine
    sMsg = sMsg & String(3, Chr(32)) & String(30, Chr(32)) & vbNewLine
    sMsg = sMsg & "* StuckToParentWorksheet:" & String(11, Chr(32)) & "[ " & CBool(bStickToParentWorksheet) & " ]" & vbNewLine
    sMsg = sMsg & String(3, Chr(32)) & String(30, Chr(32)) & vbNewLine
    sMsg = sMsg & "* HasClickMacro:" & String(29, Chr(32)) & "[ " & CBool(Len(sOnActionMacro)) & " ]" & vbNewLine
    sMsg = sMsg & String(3, Chr(32)) & String(30, Chr(32)) & vbNewLine
    sMsg = sMsg & "* Total Floating Shapes:" & String(17, Chr(32)) & "[ " & FloatingShapesCount & " ]"
    
    MsgBox sMsg, vbInformation, "Info For Floating Shape :  '" & sFloatingShapeName & "'"

End Sub

Private Function ObjRect(ByVal Obj As Object) As RECT

    Dim oPane  As Pane, lOutlineWeight As Long
    
    Set oPane = ThisWorkbook.Windows(1).ActivePane
    
    If Obj.Line.Visible Then
        lOutlineWeight = Obj.Line.Weight
    End If
    
    With Obj
        ObjRect.Left = oPane.PointsToScreenPixelsX(.Left - lOutlineWeight + 1)
        ObjRect.Top = oPane.PointsToScreenPixelsY(.Top - lOutlineWeight + 1)
        ObjRect.Right = oPane.PointsToScreenPixelsX(.Left + .Width + 2 * lOutlineWeight)
        ObjRect.Bottom = oPane.PointsToScreenPixelsY(.Top + .Height + 2 * lOutlineWeight)
    End With

End Function

Private Function GetRealVisibleRangeRectPix() As RECT

    #If Win64 Then
        Static hWbk As LongLong, hDesk As LongLong, hVert As LongLong, hHoriz As LongLong
    #Else
        Static hWbk As Long, hDesk As Long, hVert As Long, hHoriz As Long
    #End If
    
    Dim tDeskRect As RECT, WrkbookRect As RECT, VerRect As RECT, HorizRect As RECT, tPt1 As POINTAPI, tpt2 As POINTAPI

    hDesk = FindWindowEx(Application.hWnd, 0, "XLDESK", vbNullString)
    Call GetWindowRect(hDesk, tDeskRect)
    If hWbk = 0 Then hWbk = GetThisWorkbookHwnd
    
    Call GetClientRect(hWbk, WrkbookRect)
    tPt1.X = WrkbookRect.Left: tPt1.Y = WrkbookRect.Top
    tpt2.X = WrkbookRect.Right: tpt2.Y = WrkbookRect.Bottom
    Call ClientToScreen(hWbk, tPt1)
    Call ClientToScreen(hWbk, tpt2)
    WrkbookRect.Left = tPt1.X: WrkbookRect.Top = tPt1.Y
    WrkbookRect.Right = tpt2.X: WrkbookRect.Bottom = tpt2.Y
    hVert = FindWindowEx(hWbk, 0, "NUIScrollbar", "Vertical")
    hHoriz = FindWindowEx(hWbk, 0, "NUIScrollbar", "Horizontal")
    
    If IsWindowVisible(hHoriz) Or ThisWorkbook.Windows(1).DisplayWorkbookTabs Then
        Call GetWindowRect(hHoriz, HorizRect)
    End If
    
    If IsWindowVisible(hVert) Then
        Call GetWindowRect(hVert, VerRect)
    End If
    
    With Application.ActiveWindow
        GetRealVisibleRangeRectPix.Left = Application.Max(.ActivePane.PointsToScreenPixelsX(.VisibleRange.Cells(1, 1).Left) + (.Zoom / 100), tDeskRect.Left)
        GetRealVisibleRangeRectPix.Top = Application.Max(.ActivePane.PointsToScreenPixelsY(.VisibleRange.Cells(1, 1).Top) + (.Zoom / 100), tDeskRect.Top)
        GetRealVisibleRangeRectPix.Right = Application.Min(WrkbookRect.Right - (VerRect.Right - VerRect.Left), tDeskRect.Right)
        GetRealVisibleRangeRectPix.Bottom = Application.Min(WrkbookRect.Bottom - (HorizRect.Bottom - HorizRect.Top), tDeskRect.Bottom)
    End With

End Function

#If Win64 Then
    Private Function GetThisWorkbookHwnd() As LongLong
#Else
    Private Function GetThisWorkbookHwnd() As Long
#End If

    Dim sCaption As String
    
    On Error GoTo errHandler
    sCaption = ThisWorkbook.Windows(1).Caption
    ThisWorkbook.Windows(1).Caption = "@@{}@@"
    GetThisWorkbookHwnd = FindWindowEx(FindWindowEx(Application.hWnd, 0, "XLDESK", vbNullString), 0, "EXCEL7", "@@{}@@")
    
errHandler:
    ThisWorkbook.Windows(1).Caption = sCaption

End Function

Private Function FloatingShapesCount() As Integer

    Dim i As Long
    
    For i = 0 To UserForms.Count - 1
        If UserForms(i).Tag = "Floating" Then
            FloatingShapesCount = FloatingShapesCount + 1
        End If
    Next i

End Function

Private Function FloatingShapeIndex() As Integer

    Dim i As Long
    
    For i = 0 To UserForms.Count - 1
        If UserForms(i) Is Me Then
            FloatingShapeIndex = i + 1
            Exit Function
        End If
    Next i

End Function

Private Sub DeleteAllFloatingShapes()

    Dim oCol As New Collection, oElement As Object, i As Long
    
    For i = 0 To UserForms.Count - 1
        If UserForms(i).Tag = "Floating" Then
            oCol.Add UserForms(i)
        End If
    Next i
    
    For Each oElement In oCol
        Unload oElement
    Next

End Sub


Private Sub AddToolTip()
    
    Const CW_USEDEFAULT = &H80000000
    Const WS_POPUP = &H80000000
    Const WM_USER = &H400
    Const TTS_BALLOON = &H40
    Const TTS_CLOSE = &H80
    Const TTM_ADDTOOL = (WM_USER + 4)
    Const TTM_SETDELAYTIME = (WM_USER + 3)
    Const TTM_TRACKACTIVATE = (WM_USER + 17)
    Const TTM_TRACKPOSITION = (WM_USER + 18)
    Const TTM_SETTITLEA = (WM_USER + 32)
    Const TTF_TRACK = &H20
    Const TTF_ABSOLUTE = &H80
    
    Dim tTooltipPos As POINTAPI, tIccex As InitCommonControlsEx, tToolInfo As TOOLINFO

    Call RemoveToolTip
    
    With tIccex
        .Size = LenB(tIccex)
        .ICC = &H4 + &H8 + &HFF
    End With
    Call InitCommonControlsEx(tIccex)

    hToolTip = CreateWindowEx(0, "tooltips_class32", CStr(hWnd), WS_POPUP Or TTS_BALLOON Or TTS_CLOSE, _
    CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, 0, 0, GetModuleHandle(vbNullString), 0)
    
    If hToolTip Then
    
        With tToolInfo
            .cbSize = LenB(tToolInfo)
            Call GetWindowRect(hWnd, .cRect)
            .hWnd = hWnd
            .uFlags = TTF_TRACK Or IIf(InStr(1, sToolTipText, vbNewLine) Or InStr(1, sToolTipText, vbCr), TTF_ABSOLUTE, 0)
            .uId = hWnd
            .lpszText = sToolTipText
        End With
        
        Call SendMessage(hToolTip, TTM_SETTITLEA, °TTIconInfo, ByVal sShapeName)
        Call SendMessage(hToolTip, TTM_ADDTOOL, 0, tToolInfo)
        
        With tTooltipPos
            GetCursorPos tTooltipPos
            .X = tTooltipPos.X
            .Y = tToolInfo.cRect.Bottom + 2
            Call SendMessage(hToolTip, TTM_TRACKACTIVATE, True, tToolInfo)
            Call SendMessage(hToolTip, TTM_TRACKPOSITION, ByVal 0&, ByVal MakeDWord(CInt(.X), CInt(.Y)))
            sngTooltipStartTime = Timer
            Set cmb1 = Application.CommandBars
            Call cmb1_OnUpdate
        End With
        
    End If

End Sub


Private Sub RemoveToolTip()
    Call DestroyWindow(hToolTip)
End Sub


Private Function CreateStdPicture(ByVal Shp As Shape, ByRef TransparentColor As Long) As StdPicture

    Dim oWs As Worksheet, lLineWeight As Long
    Dim oTempShape As Shape, oParentShape As Shape, objGroup As ShapeRange
    
    On Error Resume Next
        Set oWs = ThisWorkbook.Sheets("TempSheet")
        If oWs Is Nothing Then
            Set oWs = ThisWorkbook.Sheets.Add
            oWs.Name = "TempSheet"
            oWs.Visible = xlSheetHidden
        End If
    On Error GoTo 0
    
    On Error GoTo errHandler
    
    Shp.Copy
    Sheets("TempSheet").Paste
    
    Set oTempShape = Sheets("TempSheet").Shapes(1)
    
    With oTempShape
    
        If oTempShape.Line.Visible Then
            lLineWeight = .Line.Weight
        End If
        
        Set oParentShape = _
        Sheets("TempSheet").Shapes.AddShape(msoShapeRectangle, _
        .Left - lLineWeight, .Top - lLineWeight, _
        .Width + 2 * lLineWeight, .Height + 2 * lLineWeight)
        
        oTempShape.ZOrder msoBringToFront
        oParentShape.ZOrder msoSendToBack
        
        If .Fill.ForeColor.RGB = &HFFFFFF Or .Fill.Transparency = 1 Then
            TransparentColor = .Fill.ForeColor.RGB Xor &HFFFFFF
        Else
            TransparentColor = vbWhite
        End If
        
        oParentShape.Fill.ForeColor.RGB = TransparentColor
        oParentShape.Line.Visible = msoFalse
        Set objGroup = Sheets("TempSheet").Shapes.Range(Array(.Name, oParentShape.Name))
        
        objGroup.Group
        If Not objGroup Is Nothing Then
            Sheets("TempSheet").Shapes(objGroup.Name).CopyPicture xlScreen, xlBitmap
            Set CreateStdPicture = PicFromObject(Nothing, °Shape)
        End If
        
    End With
    
errHandler:
    If Not objGroup Is Nothing Then
        objGroup.Delete
    End If

End Function

#If Win64 Then
    Private Function SetRegion( _
        ByVal Picture As StdPicture, _
        Optional TransparentColor As Long = vbNull _
        ) As LongLong

        Dim hMemDC As LongLong, hTempRegion As LongLong, hRegion As LongLong
        Dim hBitmapOrig As LongLong, hBitmap As LongLong

#Else
    Private Function SetRegion( _
        ByVal Picture As StdPicture, _
        Optional TransparentColor As Long = vbNull _
        ) As Long

        Dim hMemDC As Long, hTempRegion As Long, hRegion As Long
        Dim hBitmapOrig As Long, hBitmap As Long

#End If


    Const IMAGE_BITMAP = 0
    Const LR_COPYRETURNORG = &H4
    Const RGN_OR = 2
    
    Dim X As Long, Y As Long, lStart As Long, bm As BITMAP
    
    hRegion = CreateRectRgn(0, 0, 0, 0)
    Call GetObjectAPI(Picture.Handle, LenB(bm), bm)
    hBitmap = CopyImage(Picture.Handle, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
    hMemDC = CreateCompatibleDC(0)
    hBitmapOrig = SelectObject(hMemDC, hBitmap)
    
    For Y = 0 To bm.bmHeight
        X = 0
        Do While X < bm.bmWidth
            Do While X < bm.bmWidth And GetPixel(hMemDC, X, Y) = TransparentColor
                X = X + 1
            Loop
            If X < bm.bmWidth Then
                lStart = X
                Do While X < bm.bmWidth And GetPixel(hMemDC, X, Y) <> TransparentColor
                    X = X + 1
                Loop
                If X > bm.bmWidth Then X = bm.bmWidth
                hTempRegion = CreateRectRgn(lStart, Y, X, Y + 1)
                Call CombineRgn(hRegion, hRegion, hTempRegion, RGN_OR)
                Call DeleteObject(hTempRegion)
            End If
        Loop
    Next Y
    
    Call SelectObject(hMemDC, hBitmapOrig)
    Call DeleteObject(hBitmapOrig)
    Call DeleteDC(hMemDC)
    Call DeleteObject(hBitmap)
    
    SetRegion = hRegion
    
End Function


#If Win64 Then
    Private Function BuildDragCursor() As LongLong
#Else
    Private Function BuildDragCursor() As Long
#End If

    ReDim longs(0 To 186) As Long
    
    longs(0) = 0: longs(1) = 40: longs(2) = 32: longs(3) = 64: longs(4) = 262145: longs(5) = 0: longs(6) = 640: longs(7) = 0: longs(8) = 0: longs(9) = 16: longs(10) = 0: longs(11) = 0: longs(12) = 8388608: longs(13) = 32768: longs(14) = 8421376: longs(15) = 128: longs(16) = 8388736: longs(17) = 32896: longs(18) = 12632256: longs(19) = 8421504: longs(20) = 16711680: longs(21) = 65280: longs(22) = 16776960: longs(23) = 255: longs(24) = 16711935: longs(25) = 65535: longs(26) = 16777215: longs(27) = 0: longs(28) = 0: longs(29) = 0
    longs(30) = 0: longs(31) = 0: longs(32) = 0: longs(33) = 0: longs(34) = 0: longs(35) = 0: longs(36) = 151587072: longs(37) = 151587081: longs(38) = 9: longs(39) = 0: longs(40) = -1869611008: longs(41) = -1869574000: longs(42) = 144: longs(43) = 0: longs(44) = 2304: longs(45) = 0: longs(46) = 9: longs(47) = 0: longs(48) = 9437184: longs(49) = 0: longs(50) = 144: longs(51) = 0: longs(52) = 2304: longs(53) = 0: longs(54) = 9: longs(55) = 0: longs(56) = 9437184: longs(57) = 0: longs(58) = 144: longs(59) = 0
    longs(60) = 2304: longs(61) = 0: longs(62) = 9: longs(63) = 0: longs(64) = 9437184: longs(65) = 0: longs(66) = 144: longs(67) = 0: longs(68) = 2304: longs(69) = 0: longs(70) = 9: longs(71) = 0: longs(72) = -1869611008: longs(73) = -1869574000: longs(74) = 144: longs(75) = 0: longs(76) = 151587072: longs(77) = 151587081: longs(78) = 9: longs(79) = 150994944: longs(80) = 144: longs(81) = 0: longs(82) = 0: longs(83) = -1728053248: longs(84) = 153: longs(85) = 0: longs(86) = 0: longs(87) = -1728053248: longs(88) = 153: longs(89) = 0
    longs(90) = 0: longs(91) = -1727463424: longs(92) = 144: longs(93) = 0: longs(94) = 0: longs(95) = -1727463280: longs(96) = 144: longs(97) = 0: longs(98) = 0: longs(99) = -1718026087: longs(100) = 0: longs(101) = 0: longs(102) = 0: longs(103) = -1717989223: longs(104) = 0: longs(105) = 0: longs(106) = 0: longs(107) = -1868981863: longs(108) = 0: longs(109) = 0: longs(110) = 0: longs(111) = -1717986919: longs(112) = 37017: longs(113) = 0: longs(114) = 0: longs(115) = -1717986919: longs(116) = 153: longs(117) = 0: longs(118) = 0: longs(119) = -1717986919
    longs(120) = 144: longs(121) = 0: longs(122) = 0: longs(123) = -1717986919: longs(124) = 0: longs(125) = 0: longs(126) = 0: longs(127) = -1868981863: longs(128) = 0: longs(129) = 0: longs(130) = 0: longs(131) = 10066329: longs(132) = 0: longs(133) = 0: longs(134) = 0: longs(135) = 9476505: longs(136) = 0: longs(137) = 0: longs(138) = 0: longs(139) = 39321: longs(140) = 0: longs(141) = 0: longs(142) = 0: longs(143) = 37017: longs(144) = 0: longs(145) = 0: longs(146) = 0: longs(147) = 153: longs(148) = 0: longs(149) = 0
    longs(150) = 0: longs(151) = 144: longs(152) = 0: longs(153) = 0: longs(154) = 0: longs(155) = -1: longs(156) = -1: longs(157) = -1079317761: longs(158) = 2136339967: longs(159) = -1073745921: longs(160) = 2147481599: longs(161) = -1073745921: longs(162) = 2147481599: longs(163) = -1073745921: longs(164) = 2147481599: longs(165) = -1073745921: longs(166) = 2136339967: longs(167) = -1079317761: longs(168) = -32770: longs(169) = -49156: longs(170) = -49156: longs(171) = -32776: longs(172) = -32904: longs(173) = -208: longs(174) = -240: longs(175) = -255: longs(176) = -57600: longs(177) = -49408: longs(178) = -33024: longs(179) = -256
    longs(180) = -255: longs(181) = -253: longs(182) = -249: longs(183) = -241: longs(184) = -225: longs(185) = -193: longs(186) = -129:
    
    BuildDragCursor = CreateIconFromResourceEx(longs(0), UBound(longs) * 4 + 4, 0&, &H30000, 0, 0, 0&)

End Function


#If Win64 Then
    Private Function BuildClickCursor() As LongLong
#Else
    Private Function BuildClickCursor() As Long
#End If

    ReDim longs(0 To 609) As Long
    
    longs(0) = 40: longs(1) = 24: longs(2) = 48: longs(3) = 2097153: longs(4) = 0: longs(5) = 2400: longs(6) = 0: longs(7) = 0: longs(8) = 0: longs(9) = 0: longs(10) = 0: longs(11) = 0: longs(12) = 0: longs(13) = 0: longs(14) = 16711680: longs(15) = 16711680: longs(16) = 0: longs(17) = 16711680: longs(18) = 197263360: longs(19) = -1644167168: longs(20) = -65536: longs(21) = -65536: longs(22) = -65536: longs(23) = -65536: longs(24) = -65536: longs(25) = -65536: longs(26) = -65536: longs(27) = -1711268579: longs(28) = 7453: longs(29) = 8527133
    longs(30) = 0: longs(31) = 15539742: longs(32) = 16719390: longs(33) = 0: longs(34) = 0: longs(35) = 0: longs(36) = 0: longs(37) = 0: longs(38) = 83820544: longs(39) = 83821572: longs(40) = 0: longs(41) = 1476329472: longs(42) = -65536: longs(43) = -1179648: longs(44) = -3473408: longs(45) = -1271659516: longs(46) = -65536: longs(47) = -65536: longs(48) = -65536: longs(49) = -65536: longs(50) = -4193790: longs(51) = -1899773: longs(52) = -604045312: longs(53) = 16711680: longs(54) = 0: longs(55) = 16718362: longs(56) = 16712194: longs(57) = 0: longs(58) = 0: longs(59) = 0
    longs(60) = 0: longs(61) = 0: longs(62) = 83820544: longs(63) = 16712708: longs(64) = 0: longs(65) = -1426128896: longs(66) = -65536: longs(67) = -65536: longs(68) = 1694433280: longs(69) = 16711680: longs(70) = 16711680: longs(71) = 16711680: longs(72) = 16711680: longs(73) = 16711680: longs(74) = -1711341568: longs(75) = -65536: longs(76) = -65536: longs(77) = 1241448448: longs(78) = 16712965: longs(79) = 0: longs(80) = 16711680: longs(81) = 0: longs(82) = 0: longs(83) = 0: longs(84) = 0: longs(85) = 0: longs(86) = 0: longs(87) = 16712708: longs(88) = 16711680: longs(89) = -2015232000
    longs(90) = -2686976: longs(91) = 648609792: longs(92) = 16711680: longs(93) = 16711680: longs(94) = 16711680: longs(95) = 16711680: longs(96) = 16711680: longs(97) = 16711680: longs(98) = 16713222: longs(99) = 1425999623: longs(100) = -3930104: longs(101) = 1744764928: longs(102) = 16711680: longs(103) = 0: longs(104) = 0: longs(105) = 0: longs(106) = 0: longs(107) = 0: longs(108) = 0: longs(109) = 0: longs(110) = 16711680: longs(111) = 16711680: longs(112) = 16711680: longs(113) = -425394176: longs(114) = -6814716: longs(115) = 8520708: longs(116) = 9110532: longs(117) = 0: longs(118) = 16711680: longs(119) = 16711680
    longs(120) = 16711680: longs(121) = 0: longs(122) = 13510439: longs(123) = 10491157: longs(124) = -7400942: longs(125) = -1566701046: longs(126) = 13573662: longs(127) = 6173491: longs(128) = 15411754: longs(129) = 0: longs(130) = 0: longs(131) = 0: longs(132) = 0: longs(133) = 0: longs(134) = 16711680: longs(135) = 16711680: longs(136) = -268500992: longs(137) = -65536: longs(138) = -587268096: longs(139) = 16711680: longs(140) = 16711680: longs(141) = 16711680: longs(142) = 0: longs(143) = 0: longs(144) = 0: longs(145) = 16711680: longs(146) = 16720418: longs(147) = 16717077: longs(148) = -3863026: longs(149) = -642839540
    longs(150) = 6434607: longs(151) = 11611180: longs(152) = 15672356: longs(153) = 0: longs(154) = 0: longs(155) = 0: longs(156) = 0: longs(157) = 0: longs(158) = 16711680: longs(159) = 805240832: longs(160) = -65536: longs(161) = -65536: longs(162) = 16711680: longs(163) = 16711680: longs(164) = 16711680: longs(165) = 0: longs(166) = 0: longs(167) = 0: longs(168) = 0: longs(169) = 0: longs(170) = 16715792: longs(171) = 16713479: longs(172) = -620822528: longs(173) = -269676014: longs(174) = 1884694825: longs(175) = 9051678: longs(176) = 10753558: longs(177) = 0: longs(178) = 0: longs(179) = 83820544
    longs(180) = 83820544: longs(181) = 0: longs(182) = 251592704: longs(183) = -1241579520: longs(184) = -4520699: longs(185) = -1095760378: longs(186) = 5397: longs(187) = 5654: longs(188) = 16711680: longs(189) = 0: longs(190) = 0: longs(191) = 0: longs(192) = 0: longs(193) = 0: longs(194) = 16714250: longs(195) = 16713222: longs(196) = 822018048: longs(197) = -206363355: longs(198) = -10016471: longs(199) = 10622486: longs(200) = 12129043: longs(201) = 0: longs(202) = 0: longs(203) = 33488896: longs(204) = 16711680: longs(205) = 65535: longs(206) = -2030108672: longs(207) = -64251: longs(208) = -65536: longs(209) = 16783898
    longs(210) = 4883: longs(211) = 3855: longs(212) = 0: longs(213) = 0: longs(214) = 0: longs(215) = 0: longs(216) = 0: longs(217) = 0: longs(218) = 16711680: longs(219) = 0: longs(220) = 16711680: longs(221) = -208333033: longs(222) = -10147286: longs(223) = 10753815: longs(224) = 11998228: longs(225) = 0: longs(226) = 0: longs(227) = 16711680: longs(228) = 0: longs(229) = 16711680: longs(230) = -1073807360: longs(231) = -65536: longs(232) = 1224739852: longs(233) = 4883: longs(234) = 2827: longs(235) = 2827: longs(236) = 12593: longs(237) = 0: longs(238) = 0: longs(239) = 0
    longs(240) = 0: longs(241) = 0: longs(242) = 16711680: longs(243) = 16711680: longs(244) = 16711680: longs(245) = -320464872: longs(246) = -10081493: longs(247) = 10819608: longs(248) = 11605269: longs(249) = 0: longs(250) = 0: longs(251) = 16062488: longs(252) = 14811136: longs(253) = 1597505536: longs(254) = -1594425344: longs(255) = 1459552256: longs(256) = 13041664: longs(257) = 9049108: longs(258) = 13901342: longs(259) = 16719390: longs(260) = 16718105: longs(261) = 16719133: longs(262) = 16719390: longs(263) = 16726329: longs(264) = 16725044: longs(265) = 16711680: longs(266) = 16711680: longs(267) = 65535: longs(268) = 16711680: longs(269) = -842588385
    longs(270) = -9228240: longs(271) = 10887714: longs(272) = 11410974: longs(273) = 0: longs(274) = 0: longs(275) = 16715792: longs(276) = 586813456: longs(277) = -12448756: longs(278) = -692976122: longs(279) = 16711680: longs(280) = 14421261: longs(281) = 747770900: longs(282) = -758247408: longs(283) = 15469580: longs(284) = 12521745: longs(285) = 16715021: longs(286) = 16716563: longs(287) = 16721446: longs(288) = 16719904: longs(289) = 16711680: longs(290) = 16719390: longs(291) = 12395042: longs(292) = 16711680: longs(293) = -1546775789: longs(294) = -8377043: longs(295) = 11017758: longs(296) = 11541018: longs(297) = 0: longs(298) = 0: longs(299) = 16715792
    longs(300) = 1157565452: longs(301) = -11072500: longs(302) = -2816506: longs(303) = -64765: longs(304) = -65536: longs(305) = -10022125: longs(306) = -65536: longs(307) = 16711680: longs(308) = 11995658: longs(309) = 536741382: longs(310) = 16320520: longs(311) = 11409175: longs(312) = 733614353: longs(313) = 16711680: longs(314) = -1663823856: longs(315) = -8249055: longs(316) = 15990784: longs(317) = -1814425584: longs(318) = -6216411: longs(319) = 12261914: longs(320) = 12523287: longs(321) = 0: longs(322) = 0: longs(323) = 16714507: longs(324) = 436144907: longs(325) = -8254709: longs(326) = -65536: longs(327) = -65536: longs(328) = -65536: longs(329) = -9826802
    longs(330) = -65536: longs(331) = 16711680: longs(332) = 427368480: longs(333) = -7071720: longs(334) = 9310224: longs(335) = 1048454180: longs(336) = -763289568: longs(337) = 14352384: longs(338) = 1995309313: longs(339) = -4191220: longs(340) = 769065474: longs(341) = -1949821418: longs(342) = -3926249: longs(343) = 13046547: longs(344) = 12326679: longs(345) = 0: longs(346) = 0: longs(347) = 16712194: longs(348) = 16711680: longs(349) = 1509883904: longs(350) = -419495936: longs(351) = -553713664: longs(352) = 12190981: longs(353) = 1503597331: longs(354) = -892269813: longs(355) = 7542294: longs(356) = 2085889060: longs(357) = -9561317: longs(358) = 8458256: longs(359) = -2088426460
    longs(360) = -8052704: longs(361) = 10753044: longs(362) = 1223820035: longs(363) = -1702394: longs(364) = -1178921964: longs(365) = 1806899995: longs(366) = 1911688204: longs(367) = 14880784: longs(368) = 13178904: longs(369) = 0: longs(370) = 0: longs(371) = 16711937: longs(372) = 16711680: longs(373) = 16711680: longs(374) = 16711680: longs(375) = 16711680: longs(376) = 15007744: longs(377) = 1958088463: longs(378) = -3601653: longs(379) = 9442838: longs(380) = 765728535: longs(381) = -172028402: longs(382) = 14549506: longs(383) = 851253015: longs(384) = -4844524: longs(385) = 1635394339: longs(386) = -108515280: longs(387) = -5555911: longs(388) = -447850665: longs(389) = 684144
    longs(390) = 16721446: longs(391) = 16721446: longs(392) = 16723502: longs(393) = 0: longs(394) = 0: longs(395) = 16713993: longs(396) = 16713993: longs(397) = 65535: longs(398) = 16716563: longs(399) = 11997457: longs(400) = 14484484: longs(401) = -1263399153: longs(402) = -3666932: longs(403) = 11603213: longs(404) = 1241448448: longs(405) = -65536: longs(406) = 402587648: longs(407) = -1883301864: longs(408) = -7526617: longs(409) = -4712938: longs(410) = -1110632167: longs(411) = -1414442928: longs(412) = 460421754: longs(413) = 4167318: longs(414) = 16740464: longs(415) = 16728128: longs(416) = 16729156: longs(417) = 0: longs(418) = 0: longs(419) = 0
    longs(420) = 0: longs(421) = 100597760: longs(422) = 16711680: longs(423) = 33488896: longs(424) = 265029126: longs(425) = -625078256: longs(426) = -3272431: longs(427) = 12388874: longs(428) = -2063663104: longs(429) = -65536: longs(430) = -65536: longs(431) = -1111745251: longs(432) = -465745848: longs(433) = -553776116: longs(434) = 33488896: longs(435) = 104857: longs(436) = 0: longs(437) = 16711680: longs(438) = 16711680: longs(439) = 0: longs(440) = 0: longs(441) = 0: longs(442) = 0: longs(443) = 0: longs(444) = 0: longs(445) = 0: longs(446) = 16711680: longs(447) = 16711680: longs(448) = 299631106: longs(449) = -574551028
    longs(450) = -3470067: longs(451) = 11995658: longs(452) = 1724846867: longs(453) = -3271917: longs(454) = 1860175623: longs(455) = 13700622: longs(456) = 4599342: longs(457) = 16711680: longs(458) = 16711680: longs(459) = 16721446: longs(460) = 0: longs(461) = 0: longs(462) = 0: longs(463) = 0: longs(464) = 0: longs(465) = 0: longs(466) = 0: longs(467) = 0: longs(468) = 0: longs(469) = 0: longs(470) = 16718362: longs(471) = 16716306: longs(472) = 298584843: longs(473) = -710076906: longs(474) = -4843753: longs(475) = 10229784: longs(476) = 750000409: longs(477) = -4515559: longs(478) = 13438221: longs(479) = 14882326
    longs(480) = 2056288: longs(481) = 16711680: longs(482) = 16711680: longs(483) = 0: longs(484) = 0: longs(485) = 0: longs(486) = 0: longs(487) = 0: longs(488) = 0: longs(489) = 0: longs(490) = 0: longs(491) = 0: longs(492) = 0: longs(493) = 0: longs(494) = 16718362: longs(495) = 16716563: longs(496) = 500304651: longs(497) = -390721006: longs(498) = -4779245: longs(499) = 10687765: longs(500) = 701567249: longs(501) = -2093554: longs(502) = 14944778: longs(503) = 16717848: longs(504) = 16711680: longs(505) = 65535: longs(506) = 65535: longs(507) = 0: longs(508) = 0: longs(509) = 0
    longs(510) = 0: longs(511) = 0: longs(512) = 0: longs(513) = 0: longs(514) = 0: longs(515) = 0: longs(516) = 0: longs(517) = 0: longs(518) = 16712965: longs(519) = 16715535: longs(520) = 637468672: longs(521) = -65279: longs(522) = -65022: longs(523) = 132644864: longs(524) = -1812001009: longs(525) = -59625: longs(526) = 16717334: longs(527) = 16725301: longs(528) = 0: longs(529) = 0: longs(530) = 0: longs(531) = 0: longs(532) = 0: longs(533) = 0: longs(534) = 0: longs(535) = 0: longs(536) = 0: longs(537) = 0: longs(538) = 0: longs(539) = 0
    longs(540) = 0: longs(541) = 0: longs(542) = 16712965: longs(543) = 16725301: longs(544) = 16711680: longs(545) = -2097212653: longs(546) = -60139: longs(547) = -608823272: longs(548) = -1965413846: longs(549) = 1224679199: longs(550) = 16719390: longs(551) = 16729413: longs(552) = 0: longs(553) = 0: longs(554) = 0: longs(555) = 0: longs(556) = 0: longs(557) = 0: longs(558) = 0: longs(559) = 0: longs(560) = 0: longs(561) = 0: longs(562) = 0: longs(563) = 0: longs(564) = 0: longs(565) = 0: longs(566) = 16727100: longs(567) = 16726072: longs(568) = 0: longs(569) = 5913660
    longs(570) = 1247624509: longs(571) = -729925833: longs(572) = 6635070: longs(573) = 0: longs(574) = 0: longs(575) = 0: longs(576) = 0: longs(577) = 0: longs(578) = 0: longs(579) = 0: longs(580) = 0: longs(581) = 0: longs(582) = 0: longs(583) = 0: longs(584) = 0: longs(585) = 0: longs(586) = 4161791: longs(587) = 2031871: longs(588) = 2039807: longs(589) = 9388031: longs(590) = 13598718: longs(591) = 13598716: longs(592) = 13631484: longs(593) = 15204344: longs(594) = 15204345: longs(595) = 15204337: longs(596) = 15204339: longs(597) = 15171558: longs(598) = 10977248: longs(599) = 487392
    longs(600) = 1001970: longs(601) = 2050302: longs(602) = 4145406: longs(603) = 16728318: longs(604) = 16730110: longs(605) = 16732158: longs(606) = 16732158: longs(607) = 16732158: longs(608) = 16719871: longs(609) = 16728063:
        
    BuildClickCursor = CreateIconFromResourceEx(longs(0), UBound(longs) * 4 + 4, 1&, &H30000, 0, 0, 0&)
    

End Function

Private Sub cmb1_OnUpdate()

    Const TOOLTIP_SHOW_DELAY = 4 'Secs

    On Error Resume Next
    With Application.CommandBars
        .FindControl(ID:=2040).Enabled = Not .FindControl(ID:=2040).Enabled
    End With
    
    Call Delay(TOOLTIP_SHOW_DELAY)
    
End Sub

Private Sub cmb2_OnUpdate()

    Const GW_CHILD = 5
    Dim tMousePos As POINTAPI
    
    Call GetCursorPos(tMousePos)
    
    #If Win64 Then
        Dim lngPtr As LongLong, hwndFromPoint As LongLong
        CopyMemory lngPtr, tMousePos, LenB(tMousePos)
        hwndFromPoint = WindowFromPoint(lngPtr)
    #Else
        Dim hwndFromPoint As Long
        hwndFromPoint = WindowFromPoint(tMousePos.X, tMousePos.Y)
    #End If

    If hwndFromPoint <> GetNextWindow(hWnd, GW_CHILD) Then
        Call SetActiveWindow(Application.hWnd)
        Set cmb2 = Nothing
    End If

End Sub

Private Sub Delay(ByVal HowLong As Single)

    Const GW_CHILD = 5
    Dim tMousePos As POINTAPI, sngInitTimer As Single
    
    On Error Resume Next
    
    Call GetCursorPos(tMousePos)
    
    #If Win64 Then
        Dim lngPtr As LongLong, hwndFromPoint As LongLong
        CopyMemory lngPtr, tMousePos, LenB(tMousePos)
        hwndFromPoint = WindowFromPoint(lngPtr)
    #Else
        Dim hwndFromPoint As Long
        hwndFromPoint = WindowFromPoint(tMousePos.X, tMousePos.Y)
    #End If
    
    If GetNextWindow(hWnd, GW_CHILD) <> hwndFromPoint Then
        Set cmb1 = Nothing: bStartMouseMoving = False
        Call RemoveToolTip
    End If
    
    If Timer - sngTooltipStartTime >= HowLong Then
        Call RemoveToolTip
    End If
End Sub

Private Function MakeDWord(loword As Integer, hiword As Integer) As Long
    MakeDWord = (hiword * &H10000) Or (loword And &HFFFF&)
End Function


Private Sub wb_Activate()

    If bStickToParentWorksheet = False Then
        Call ShowWindow(hWnd, 1)
    Else
        If ActiveSheet Is oShape.ControlFormat.Parent Then
            Call ShowWindow(hWnd, 1)
        End If
    End If
    
End Sub

Private Sub wb_Deactivate()
    Call ShowWindow(hWnd, 0)
End Sub

Private Sub ws_Activate()
    Call ShowWindow(hWnd, 1)
End Sub

Private Sub ws_Deactivate()
    If bStickToParentWorksheet Then
        Call ShowWindow(hWnd, 0)
    End If
End Sub

Private Sub wb_BeforeClose(Cancel As Boolean)
    Unload Me
End Sub

3- Code Usage test (Standard Module)

VBA Code:

Option Explicit

Private oFloatingShape As IFloatingShape


Public Sub CreateFloatingShapesTest()

    With Sheet1
        
        Select Case Application.Caller
        
            Case "btn1"
            
                Call MakeFloatingCopyOfShape( _
                    Shape:=.Shapes("Circle"), _
                    FolatingShapeName:="Floating " & .Shapes("Circle").Name, _
                    OnActionMacro:="OnActionMacro", _
                    TooltipText:="Click for OnAction Macro, Right-Click for Info or Drag around. ", _
                    StickToParentWorksheet:=True)
            
            Case "btn2"
                    Call MakeFloatingCopyOfShape( _
                    Shape:=.Shapes("Smily"), _
                    FolatingShapeName:="Floating " & .Shapes("Smily").Name, _
                    OnActionMacro:="OnActionMacro", _
                    TooltipText:="Click for OnAction Macro, Right-Click for Info or Drag around. ", _
                    StickToParentWorksheet:=True)
        
        
            Case "btn3"
                    Call MakeFloatingCopyOfShape( _
                    Shape:=.Shapes("Triangle"), _
                    FolatingShapeName:="Floating " & .Shapes("Triangle").Name, _
                    OnActionMacro:="OnActionMacro", _
                    TooltipText:="Click for OnAction Macro, Right-Click for Info or Drag around. ", _
                    StickToParentWorksheet:=True)
        
        
            Case "btn4"
                    Call MakeFloatingCopyOfShape( _
                    Shape:=.Shapes("Star"), _
                    FolatingShapeName:="Floating " & .Shapes("Star").Name, _
                    OnActionMacro:="OnActionMacro", _
                    TooltipText:="Click for OnAction Macro, Right-Click for Info or Drag around. ", _
                    StickToParentWorksheet:=True)
        
        
            Case "btn5"
                    Call MakeFloatingCopyOfShape( _
                    Shape:=.Shapes("Picture 1"), _
                    FolatingShapeName:="Floating " & .Shapes("Picture 1").Name, _
                    OnActionMacro:="OnActionMacro", _
                    TooltipText:="Click for OnAction Macro, Right-Click for Info or Drag around. ", _
                    StickToParentWorksheet:=True)
        
            
            Case "btn6"
                    Call MakeFloatingCopyOfShape( _
                    Shape:=.Shapes("Word_Art"), _
                    FolatingShapeName:="Floating " & .Shapes("Word_Art").Name, _
                    OnActionMacro:="OnActionMacro", _
                    TooltipText:="Click for OnAction Macro, Right-Click for Info or Drag around. ", _
                    StickToParentWorksheet:=True)
        
        
        End Select
    
    End With


End Sub


Public Sub DeleteAllFloatingShapes()
    If Not oFloatingShape Is Nothing Then
        oFloatingShape.DeleteAllFloatingShapes
        Set oFloatingShape = Nothing
    End If
End Sub



Public Sub MakeFloatingCopyOfShape( _
    ByVal Shape As Shape, _
    Optional ByVal FolatingShapeName As String, _
    Optional ByVal OnActionMacro As String, _
    Optional ByVal TooltipText As String, _
    Optional ByVal StickToParentWorksheet As Boolean = True _
)

    Set oFloatingShape = New frm_FloatingShape
    
    With oFloatingShape
        Set .SeedShape = Shape
        .FloatingShapeName = FolatingShapeName
        .FloatingShapeClickMacro = OnActionMacro
        .Create
        .StickToParentWorksheet = StickToParentWorksheet
        .TooltipText = TooltipText
    End With

End Sub



'GENERIC ONACTION MACRO.
Public Sub OnActionMacro(ByVal Shape As IFloatingShape)
    MsgBox "You Clicked On Floating Shape: '" & Shape.FloatingShapeName & "'"
End Sub

Cool Class for making Floating Shapes !

Jaafar Tribak

Well-known Member

Norie

Well-known Member

Excel Facts

Yongle

Well-known Member

Jaafar Tribak

Well-known Member

Norie

Well-known Member

Yongle

Well-known Member

Jaafar Tribak

Well-known Member

Similar threads

Forum statistics

Share this page

Cool Class for making Floating Shapes !

Jaafar Tribak

Well-known Member

Norie

Well-known Member

Excel Facts

Yongle

Well-known Member

Jaafar Tribak

Well-known Member

Norie

Well-known Member

Yongle

Well-known Member

Jaafar Tribak

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock