Issue with switching from buttons to shapes (mouse down area)

[BenMcBen]

Hi

I am updating the look & feel of a legacy sheet. I decided to make part of this process updating all the existing "forms buttons" to shapes with assigned macros. For the bigger buttons which are well spread out there is no issue, but this sheet makes use of a good number of relatively small buttons, sometimes in groups, sometimes next to cells with dropdown data validation.

The issue I face (first noticed by users testing) is that the area where the normal cross mouse pointer becomes a hand/can activate the shape macro, is now defined by the merest touch/overhang of the edge of the cursor, whereas with form buttons at least half of the crossbar must be on the button / over the border for this to happen. This makes selecting cells close to buttons as likely to end up firing the button as selecting the cell. This sheet is extremely compact and the users like/want the layout the way it is.

So I see I have two choices either
a) I rip out all the shapes and go back to form buttons
b) Create a "visual shape" which has the text and nice formatting but no macro, and then group a smaller transparent button on top bringing in the edges to a more "normal" active area. Unless I lock the sheet (which really isn't going to be easy at all) - I'll still have the danger of the user accidentally selecting the shape.

Neither of these fill me with joy - does anyone have any alternative / better suggestions? (I've discounted using ActiveX controls due to "shrinkies")

Thanks

Ben

 

[RoryA]

Is there a reason you want the buttons/shapes on the sheet rather than using the Ribbon?

 

[BenMcBen]

Is there a reason you want the buttons/shapes on the sheet rather than using the Ribbon?

The users like it the way it is, and there's a large investment of training/familiarity with current operation/paradigm - not an option to diverge from this....

 

[Jaafar Tribak]

If the small shapes have a solid fill color (ie:=No Gradient), we can use an easy workaround by detecting the pixel color under the mouse .
Also, do the shapes have text and if so what is the color of it ?

 

[Jaafar Tribak]

I took a seocond look at this last night and decided to follow a better and cleaner approach. One that doesn't depend on the color of the shapes.
Basically, the idea is to figure out the cursor position based on the cursor bitmap hotspot and see which object is underneath.

I have wrapped the code inside a single boolean Function (Is_Hand_Cursor_Off_Shape) for easy use.

Place this code in a new standard module

Option Explicit

Private Type POINTAPI
    x As Long
    y As Long
End Type

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

#If VBA7 Then
    Private Declare PtrSafe Function GetCursor Lib "user32" () As LongPtr
    Private Declare PtrSafe Function GetIconInfo Lib "user32" (ByVal hIcon As LongPtr, piconinfo As ICONINFO) As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
#Else
    Private Declare Function GetCursor Lib "user32" () As Long
    Private Declare Function GetIconInfo Lib "user32" (ByVal hIcon As Long, piconinfo As ICONINFO) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
#End If


Function Is_Hand_Cursor_Off_Shape() As Boolean

    Dim tCurPos As POINTAPI, tIconInfo As ICONINFO
    Dim objLeft As Object, objTop As Object, objRight As Object, objBottom As Object
    Dim bLeft As Boolean, bTop As Boolean, bRight As Boolean, bBottom As Boolean
    Dim sShapName As String
  

    sShapName = Application.Caller
    Call GetCursorPos(tCurPos)
    Call GetIconInfo(GetCursor, tIconInfo)
  
    On Error Resume Next
        With tCurPos
            Set objLeft = ActiveWindow.RangeFromPoint(.x - tIconInfo.xHotspot / 3 - 1, .y)
            bLeft = CBool(objLeft.Name = sShapName)
            Set objTop = ActiveWindow.RangeFromPoint(.x, .y - tIconInfo.xHotspot / 3 - 1)
            bTop = CBool(objTop.Name = sShapName)
            Set objRight = ActiveWindow.RangeFromPoint(.x + tIconInfo.xHotspot / 3 + 1, .y)
            bRight = CBool(objRight.Name = sShapName)
            Set objBottom = ActiveWindow.RangeFromPoint(.x, .y + tIconInfo.xHotspot / 3 + 1)
            bBottom = CBool(objBottom.Name = sShapName)
        End With
        If Not (bLeft And bTop And bRight And bBottom) Then
            If bLeft = False And TypeName(objLeft) = "Range" Then objLeft.Select
            If bTop = False And TypeName(objTop) = "Range" Then objTop.Select
            If bRight = False And TypeName(objRight) = "Range" Then objRight.Select
            If bBottom = False And TypeName(objBottom) = "Range" Then objBottom.Select
                Is_Hand_Cursor_Off_Shape = True
        End If
    On Error GoTo 0
  
    Call DeleteObject(tIconInfo.hbmColor)
    Call DeleteObject(tIconInfo.hbmMask)

End Function

And then, simply place this single line: If Is_Hand_Cursor_Off_Shape() Then Exit Sub at the top of the macros assigned to your shapes

Usage Example:

Sub Shape_Click()

    'SKIP CODE IF THE CURSOR IS NOT ENTIRELY OVER THE SHAPE.
     If Is_Hand_Cursor_Off_Shape() Then Exit Sub
  
    'OTHERWISE,CONTINUE WITH THE REST OF YOUR CODE ...

End Sub

The code worked for me nicely in various tests . I hope it works for you too.