A few ideas to prevent user editing of shape size (code help needed for Psychology study)

[Excel_Fool]

Friends

I want to prevent users from editing the size of shapes but allow them to move the shapes around the spreadsheet. I have several ideas on how to do this but I need help with the code (I'm a code fool!).

1. There may be a way to remove the "handles" so that users can move the shapes around the screen but not change the size of the shapes. Maybe make the mouse cursor turn to a hand when hovering over shapes?
2. I've heard that using a text box or "Smart Art" instead of shapes can provide different options
3. I've read that it is possible to code clicking off of a shape as an event (something like "<code>Workbook_SheetSelectionChange</code>"). According to this POST, it is possible to code clicking off a shape as a cue to set constant dimensions for a shape. Obviously, this is a workaround because users would still be able to edit the shape size but after clicking a cell or another shape, the dimensions would automatically resize to the original dimensions. The problem with the linked post is that I can't get the code to work. Maybe I'm not pasting it into the right place???

And to be clear, I know Excel has built in ways to disable all editing of shapes but this is not an option for me because users must be able to move the shapes around the screen. There is also an excel option to "disable resize with cells" but this is doesn't prevent users from editing shape size.

Any ideas?

-Fool

 

[BiocideJ]

Well, this was no trivial request. That being said, I 'believe' I have found a semi-workable solution.

For this to work, you will need to set each Shapes 'Locked' option to YES and protect the worksheet.
This will make it so you cannot select, move or resize the shape, but that is OK.

The 'trick' is that you will need to assign each shape to a common macro (ShapeMover) which is in the code below. What this macro does is to make the shape 'stick' to the cursor until you click on it again which 'drops' it in the new location of the screen.

Paste the following into a Standard Module:

#If Win64 Or VBA7 Then
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
#Else
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
#End If
Type POINTAPI
    x As Long
    y As Long
End Type
Public ShapeActive As Boolean
Function GetCursorXY() As POINTAPI
     
    Dim lngStatus As Long
    lngStatus = GetCursorPos(GetCursorXY)
    
End Function
 
Sub ShapeMover()
Dim mousePOS As POINTAPI
Dim InitMouse As POINTAPI
Dim ThisShape As Shape
Dim InitLEFT As Single
Dim InitTOP As Single
    Set ThisShape = ActiveSheet.Shapes(Application.Caller)
    InitLEFT = ThisShape.Left
    InitTOP = ThisShape.Top
    mousePOS = GetCursorXY()
    InitMouse = mousePOS
    hdc = GetDC(0)
    PointsPerPixelY = 72 / GetDeviceCaps(hdc, 90)
    PointsPerPixelX = 72 / GetDeviceCaps(hdc, 88)
    ReleaseDC 0, hdc
    ShapeActive = Not ShapeActive
    Do While ShapeActive
        mousePOS = GetCursorXY()
        ThisShape.Left = InitLEFT + (mousePOS.x - InitMouse.x) * PointsPerPixelX
        ThisShape.Top = InitTOP + (mousePOS.y - InitMouse.y) * PointsPerPixelY
        DoEvents
    Loop
End Sub

Let me know if you have any questions.
A portion of my code derived from http://www.mrexcel.com/forum/excel-questions/401643-detect-mouse-movement.html

 

[Jaafar Tribak]

Nice code BiocidJ,


I would alter the code as follows to avoid the sticky feel of the shape ie: to avoid having to click the shape a second time before dropping it in the new location :

#If Win64 Or VBA7 Then
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
#Else
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
   [B] Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer[/B]
#End If
Type POINTAPI
    x As Long
    y As Long
End Type
Public ShapeActive As Boolean
Function GetCursorXY() As POINTAPI
     
    Dim lngStatus As Long
    lngStatus = GetCursorPos(GetCursorXY)
    
End Function
 
Sub ShapeMover()


Dim mousePOS As POINTAPI
Dim InitMouse As POINTAPI
Dim ThisShape As Shape
Dim InitLEFT As Single
Dim InitTOP As Single
    Set ThisShape = ActiveSheet.Shapes(Application.Caller)
    InitLEFT = ThisShape.Left
    InitTOP = ThisShape.Top
    mousePOS = GetCursorXY()
    InitMouse = mousePOS
    hdc = GetDC(0)
    PointsPerPixelY = 72 / GetDeviceCaps(hdc, 90)
    PointsPerPixelX = 72 / GetDeviceCaps(hdc, 88)
    ReleaseDC 0, hdc
[B][COLOR=#008000]'    ShapeActive = Not ShapeActive[/COLOR][/B]
    Do  [B][COLOR=#008000]'While Not ShapeActive[/COLOR][/B]
        mousePOS = GetCursorXY()
        ThisShape.Left = InitLEFT + (mousePOS.x - InitMouse.x) * PointsPerPixelX
        ThisShape.Top = InitTOP + (mousePOS.y - InitMouse.y) * PointsPerPixelY
        [B]If GetAsyncKeyState(vbKeyLButton) = 0 Then Exit Do[/B]
        DoEvents
    Loop
End Sub

 

[BiocideJ]

I agree. That makes it so much more natural feeling.
The only thing I noticed is that the GetAsyncKeyState declaration needed to be added in the 64-bit section as well.
Great modification!

#If Win64 Or VBA7 Then
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#Else
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#End If
Type POINTAPI
    x As Long
    y As Long
End Type
Public ShapeActive As Boolean
Function GetCursorXY() As POINTAPI
     
    Dim lngStatus As Long
    lngStatus = GetCursorPos(GetCursorXY)
    
End Function
 
Sub ShapeMover()

Dim mousePOS As POINTAPI
Dim InitMouse As POINTAPI
Dim ThisShape As Shape
Dim InitLEFT As Single
Dim InitTOP As Single
    Set ThisShape = ActiveSheet.Shapes(Application.Caller)
    InitLEFT = ThisShape.Left
    InitTOP = ThisShape.Top
    mousePOS = GetCursorXY()
    InitMouse = mousePOS
    hdc = GetDC(0)
    PointsPerPixelY = 72 / GetDeviceCaps(hdc, 90)
    PointsPerPixelX = 72 / GetDeviceCaps(hdc, 88)
    ReleaseDC 0, hdc
'    ShapeActive = Not ShapeActive
    Do  'While Not ShapeActive
        mousePOS = GetCursorXY()
        ThisShape.Left = InitLEFT + (mousePOS.x - InitMouse.x) * PointsPerPixelX
        ThisShape.Top = InitTOP + (mousePOS.y - InitMouse.y) * PointsPerPixelY
        If GetAsyncKeyState(vbKeyLButton) = 0 Then Exit Do
        DoEvents
    Loop
End Sub

 

[Excel_Fool]

Friends,

This is a very clever fix and, as you indicated BiocideJ, this task requires some creativity. I've been working with Jaafar Tribak on some code to count shape moves (Link). I don't think I can run that code and the code in this thread simultaneously. The "Protect Sheet" function prevents the counter from inserting numbers into the worksheet.

This was such a clever fix, it's too bad I can't use it. Any other ideas?

-Fool

 

[Jaafar Tribak]

The following solution should allow for counting all shape movements and for displaying the total movement count in Cell (D2) while still having the worksheet protected so that none of the shapes can be resized by the user .. just as requested

Follow these steps :

1 - First, add two buttons to your worksheet .. One will be assigned the StartMonitoringShapeMoves Macro and the other one will be assigned the Reset Macro which will clear Cell (D2) and will reinitialise the moves count
2 - Add to the worksheet all the shapes you require
3 - Place this code in the worksheet Module :

Option Explicit

#If Win64 Or VBA7 Then
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#Else
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#End If
Private Type POINTAPI
    x As Long
    y As Long
End Type

Private iCounter As Long

Sub StartMonitoringShapeMoves()
    Dim oShp As Shape
    On Error Resume Next
    With Me
        For Each oShp In .Shapes
            If oShp.Type = msoAutoShape Then
                oShp.Locked = True
                oShp.OnAction = .CodeName & ".ShapeMover"
            End If
        Next
        .Cells.Locked = False
        .Protect
    End With
End Sub

Sub Reset()
    Dim oShp As Shape
    For Each oShp In Me.Shapes
    If oShp.Type = msoAutoShape Then
        oShp.OnAction = ""
    End If
    Next
    Me.Range("D2").ClearContents
    iCounter = 0
End Sub

Private Function GetCursorXY() As POINTAPI
    Dim lngStatus As Long
    lngStatus = GetCursorPos(GetCursorXY)
End Function
 
Private Sub ShapeMover()
    Dim mousePOS As POINTAPI
    Dim InitMouse As POINTAPI
    Dim ThisShape As Shape
    Dim InitLEFT As Single
    Dim InitTOP As Single
    Dim PointsPerPixelY As Single
    Dim PointsPerPixelX As Single
    Dim hdc As Long
    Set ThisShape = Me.Shapes(Application.Caller)
    InitLEFT = ThisShape.Left
    InitTOP = ThisShape.Top
    mousePOS = GetCursorXY()
    InitMouse = mousePOS
    hdc = GetDC(0)
    PointsPerPixelY = 72 / GetDeviceCaps(hdc, 90)
    PointsPerPixelX = 72 / GetDeviceCaps(hdc, 88)
    ReleaseDC 0, hdc
    Do While GetAsyncKeyState(vbKeyLButton) <> 0
        mousePOS = GetCursorXY()
        ThisShape.Left = InitLEFT + (mousePOS.x - InitMouse.x) * PointsPerPixelX
        ThisShape.Top = InitTOP + (mousePOS.y - InitMouse.y) * PointsPerPixelY
        DoEvents
    Loop
    If InitLEFT <> ThisShape.Left Or InitTOP <> ThisShape.Top Then
        iCounter = iCounter + 1
        Range("D2") = iCounter
    End If
End Sub

4 - Now you can click on the button to which you assigned the StartMonitoringShapeMoves Macro to get started .. Click on the reset button when you are done.

I hope this answers the question asked here and in the other thread