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

BenMcBen

New Member
Joined
Aug 19, 2014
Messages
34
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
 

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"

RoryA

MrExcel MVP, Moderator
Joined
May 2, 2008
Messages
39,339
Office Version
  1. 365
  2. 2019
  3. 2016
  4. 2010
Platform
  1. Windows
  2. MacOS
Is there a reason you want the buttons/shapes on the sheet rather than using the Ribbon?
 

BenMcBen

New Member
Joined
Aug 19, 2014
Messages
34
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

Well-known Member
Joined
Dec 5, 2002
Messages
8,852
Office Version
  1. 2016
Platform
  1. Windows
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

Well-known Member
Joined
Dec 5, 2002
Messages
8,852
Office Version
  1. 2016
Platform
  1. Windows
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
VBA Code:
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:
VBA Code:
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.
 

Forum statistics

Threads
1,176,089
Messages
5,901,333
Members
434,886
Latest member
qazibelal

We've detected that you are using an adblocker.

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

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

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

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

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

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

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

Disable uBlock

Follow these easy steps to disable uBlock

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