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

Yongle · Jun 23, 2019

@Jaafar Tribak
- that is an amazing piece of work

- I will be looking at it in more detail tomorrow

The demo is excellent too
- how did you put the demo on the thread?

thanks

Yongle · Jun 23, 2019

@Jaafar Tribak
What did I do wrong?

"Compile Error User defined type not defined!"

This is the problem line

Code:

Private oFloatingShape As [B]IFloatingShape[/B]

Code pasted as below :
Module1 = Interface code
Module2 = Code Usage code
UserForm1 module = Userform code

Norie · Jun 23, 2019

Jaafar

All I'm getting is small userforms with the shapes displayed.

Also the options in the right click menu are greyed out.

Yongle

The Interface code needs to be in a class module name IFloatingShape.

Yongle · Jun 23, 2019

@Norie thanks - that's moved me to a different issue

@Jaafar Tribak
My setup is Windows10 and Office365
The code is now in the correct modules
But it is not "plug and play" for me - I must be doing something wrong

For my benefit and anyone else who reads this, can you please list all steps required to make it work
thank you

Jaafar Tribak · Jun 23, 2019

Yongle said:
@Norie thanks - that's moved me to a different issue

@Jaafar Tribak
My setup is Windows10 and Office365
The code is now in the correct modules
But it is not "plug and play" for me - I must be doing something wrong

For my benefit and anyone else who reads this, can you please list all steps required to make it work
thank you

Hi Yongle,

Did you try the demo workbook in the link ? did it work for you as expected ?

Anyway here are the streps required:

1- Add a new class module to the vbaproject and give the class the name of : IFloatingShape then paste the first code in the class module.... This will be the Interface class.

2- Add a new blank userform to the vbaproject and give it the name of : frm_FloatingShape then paste the second code in the userform module.

3- Add a Standard module and paste the third code in it and run the CreateFloatingShapesTest routine ... Obviously, you will need to have beforehand some shapes on Sheet1 and the CreateFloatingShapesTest routine must be edited with the correct names of the shapes , parent sheet etc..

Regards.

Yongle · Jun 23, 2019

Did you try the demo workbook in the link ? did it work for you as expected ?

I was not able to download earlier. But I have downloaded it a few minutes ago

I get very similar problem to what @Norrie said in post#4

Fluff · Jun 23, 2019

It works quite happily for me using 32bit 2013 on Win 7

Jaafar Tribak · Jun 23, 2019

Yongle said:
I was not able to download earlier. But I have downloaded it a few minutes ago

I get very similar problem to what @Norrie said in post#4

I tested the code again in two different machines excel 2010\2013 32bit Win 7 and excel 2007 Win 7 SP1 and the code worked just fine in both machines.

It could be something about Office365 or the platform that it is running on that is causing the issue Norie and yourself are experiencing... I don't know.

Regards.

Jaafar Tribak · Jun 24, 2019

Norie said:
Jaafar

All I'm getting is small userforms with the shapes displayed.

Also the options in the right click menu are greyed out.

Hi Norie,

Which edition of Windows did you try the code in ? (bitness include)

Regards.

Cool Class for making Floating Shapes !

Jaafar Tribak

Well-known Member

Excel Facts

Yongle

Well-known Member

Yongle

Well-known Member

Norie

Well-known Member

Yongle

Well-known Member

Jaafar Tribak

Well-known Member

Yongle

Well-known Member

Fluff

MrExcel MVP, Moderator

Jaafar Tribak

Well-known Member

Jaafar Tribak

Well-known Member

Similar threads

Forum statistics

Share this page

Cool Class for making Floating Shapes !

Well-known Member

Excel Facts

Well-known Member

Well-known Member

Well-known Member

Well-known Member

Well-known Member

Well-known Member

MrExcel MVP, Moderator

Well-known Member

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