Partially lock shapes in the same sheet

C

ceecee88

Board Regular
Joined
Jun 30, 2022
Messages
59
Office Version
  1. 365
  2. 2013
Platform
  1. Windows
Hello, the situation is that I have many shapes in 1 sheets
1. some shapes I want the user to be able to modify
2. some shapes I don't want the user to be able to do anything with it
3. I want the user to be able to insert new shapes as they wish

Here is what I have tried so far
Method 1:
- If I protected the whole sheet and don't allow "Edit Object"
- Unlock all the shapes I want the use to modify
- Lock shapes that I don't want user to modify.
I can accomplished 1&2 but user won't be able to insert new shapes (because I locked "Edit Object".

Method 2:
- If I protected the whole sheet BUT allow "Edit Object"
I can accomplished 1&3 but user can modify/delete any shapes including the ones I don't want them to be able to do it.

My next idea and I'm not sure if it is possible or not (I have been searching but didn't find anything on this), is to write a VBA code that can identify if the particular shape is being selected (specified by name e.g. if any of these name -> Oval 1/Oval 2/Rectangle 1 being selected/active) Then deselect the object -> lock sheet and Don't allow "Edit Object" but when user don't select any of those specified objects it can go to lock sheet and allow "Edit Object".

Is it possible to write VBA code for the idea above? I think I can't use Private Sub Worksheet_Change(ByVal Target as Range) to catch the object selection, right? Any recommendation will be much appreciated.
Thank you
 

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().
Sort by date Sort by votes
This is one funny situation :)

If you are interested only in a small number of shape types, one possibility may be to add one instance of each shape to the worksheet.
Those shapes will serve as cloners.. When clicking on them, the sheet will be temporarly unprotected, the clone shape(s) will be added and the worksheet wil be protected back... For adding the shapes, you could use some simple code as follows :

CommandBars.ExecuteMso "ShapeRectangle"
CommandBars.ExecuteMso "ShapeOval"
 
Upvote 0
Jaafar Tribak said:
This is one funny situation :)

If you are interested only in a small number of shape types, one possibility may be to add one instance of each shape to the worksheet.
Those shapes will serve as cloners.. When clicking on them, the sheet will be temporarly unprotected, the clone shape(s) will be added and the worksheet wil be protected back... For adding the shapes, you could use some simple code as follows :

CommandBars.ExecuteMso "ShapeRectangle"
CommandBars.ExecuteMso "ShapeOval"
Click to expand...
Hi, thank you for your reply. I want the users to be able to add anything they want, CommandBars.ExecuteMso "ShapeRectangle" not going to work in this case.
I found some code on beforerightclick but that only apply to cell not object, wondering if anyone found solution for rightclick on object at all, there are quite a few people asking about it but never found the answer.
 
Upvote 0
As you said, there is no Beforerightclick for shapes. One possibility may be using a vba loop or some other kind of monitoring such as a timer for continiously watching if the user presses the right mouse button while over a shape and unselect the shape.
 
Upvote 0
One idea that might work is to tag the shapes that you don't want the user to modify. You can tag them via the AlternativeText property.
Then the monitoring code will only deselect the shapes that are tagged. Would that be ok ?
 
Upvote 0
The following vba workaround is by no means perfect particularly because it uses a timer which will impact performance, otherwise, it should work ok.

Download demo:
PartialLockOfShapes.xlsm

The code assumes the following 3 requirements :

1 - Sheet1 is where you have the shapes. (You can change to a different sheet via the SHEET_NAME Const in the module)
2 - Each shape that you don't want to be modified by the user must be tagged manually (prior to running the code) with the word Locked. This is done via the shape AlternativeText Property as shown in the screenshot below.
Untifgdfgdftled.png


3- Leave Sheet1 UnProtected.

Here is the entire code in a Standard Module:
VBA Code: 
Option Explicit

#If Win64 Then
    Const NULL_PTR = 0^
#Else
    Const NULL_PTR = 0&
#End If

Private Type POINTAPI
    X As Long
    Y As Long
End Type

#If VBA7 Then
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function AnyPopup Lib "user32" () As Long
#Else
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function AnyPopup Lib "user32" () As Long
#End If

Private Const SHEET_NAME = "Sheet1"  '<---- Change target sheet name as needed.


Sub Start()
    Call KillTimer(Application.hwnd, NULL_PTR)
    Call SetTimer(Application.hwnd, NULL_PTR, 0&, AddressOf TimerProc)
End Sub

Sub Finish()
    Call KillTimer(Application.hwnd, NULL_PTR)
    ThisWorkbook.Sheets(SHEET_NAME).Protect Contents:=False, DrawingObjects:=False
End Sub

Private Sub TimerProc()

    Static oPrevObjFromPt As Object
    Static bFlag As Boolean

    Dim tCurPos As POINTAPI
    Dim oCurObjFromPt As Object
    Dim lErr As Long
    Dim sAltText As String

    On Error Resume Next

    Call GetCursorPos(tCurPos)
    Set oCurObjFromPt = ActiveWindow.RangeFromPoint(tCurPos.X, tCurPos.Y)
    sAltText = oCurObjFromPt.ShapeRange.AlternativeText
    lErr = Err.Number
            
    If lErr = 0& Then
        bFlag = True
        If oCurObjFromPt.ShapeRange.Name <> oPrevObjFromPt.ShapeRange.Name Then
            If sAltText = "Locked" Then
                If AnyPopup = 0& Then
                    ThisWorkbook.Sheets(SHEET_NAME).Protect Contents:=False, DrawingObjects:=True
                End If
            Else
                ThisWorkbook.Sheets(SHEET_NAME).Protect Contents:=False, DrawingObjects:=False
            End If
        End If
    End If
          
    If TypeName(oCurObjFromPt) = "Range" Or TypeName(oCurObjFromPt) = "Nothing" Then
        If bFlag Then
            bFlag = False
            ThisWorkbook.Sheets(SHEET_NAME).Protect Contents:=False, DrawingObjects:=False
        End If
    End If

    Set oPrevObjFromPt = oCurObjFromPt

End Sub

Private Sub Auto_Close()
    Call Finish
End Sub

You should still be able to add new shapes while the code is running.
 
Last edited:
Upvote 0
Jaafar Tribak said:
The following vba workaround is by no means perfect particularly because it uses a timer which will impact performance, otherwise, it should work ok.

Download demo:
PartialLockOfShapes.xlsm

The code assumes the following 3 requirements :

1 - Sheet1 is where you have the shapes. (You can change to a different sheet via the SHEET_NAME Const in the module)
2 - Each shape that you don't want to be modified by the user must be tagged manually (prior to running the code) with the word Locked. This is done via the shape AlternativeText Property as shown in the screenshot below.
View attachment 90474

3- Leave Sheet1 UnProtected.

Here is the entire code in a Standard Module:
VBA Code: 
Option Explicit

#If Win64 Then
    Const NULL_PTR = 0^
#Else
    Const NULL_PTR = 0&
#End If

Private Type POINTAPI
    X As Long
    Y As Long
End Type

#If VBA7 Then
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function AnyPopup Lib "user32" () As Long
#Else
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function AnyPopup Lib "user32" () As Long
#End If

Private Const SHEET_NAME = "Sheet1"  '<---- Change target sheet name as needed.


Sub Start()
    Call KillTimer(Application.hwnd, NULL_PTR)
    Call SetTimer(Application.hwnd, NULL_PTR, 0&, AddressOf TimerProc)
End Sub

Sub Finish()
    Call KillTimer(Application.hwnd, NULL_PTR)
    ThisWorkbook.Sheets(SHEET_NAME).Protect Contents:=False, DrawingObjects:=False
End Sub

Private Sub TimerProc()

    Static oPrevObjFromPt As Object
    Static bFlag As Boolean

    Dim tCurPos As POINTAPI
    Dim oCurObjFromPt As Object
    Dim lErr As Long
    Dim sAltText As String

    On Error Resume Next

    Call GetCursorPos(tCurPos)
    Set oCurObjFromPt = ActiveWindow.RangeFromPoint(tCurPos.X, tCurPos.Y)
    sAltText = oCurObjFromPt.ShapeRange.AlternativeText
    lErr = Err.Number
           
    If lErr = 0& Then
        bFlag = True
        If oCurObjFromPt.ShapeRange.Name <> oPrevObjFromPt.ShapeRange.Name Then
            If sAltText = "Locked" Then
                If AnyPopup = 0& Then
                    ThisWorkbook.Sheets(SHEET_NAME).Protect Contents:=False, DrawingObjects:=True
                End If
            Else
                ThisWorkbook.Sheets(SHEET_NAME).Protect Contents:=False, DrawingObjects:=False
            End If
        End If
    End If
         
    If TypeName(oCurObjFromPt) = "Range" Or TypeName(oCurObjFromPt) = "Nothing" Then
        If bFlag Then
            bFlag = False
            ThisWorkbook.Sheets(SHEET_NAME).Protect Contents:=False, DrawingObjects:=False
        End If
    End If

    Set oPrevObjFromPt = oCurObjFromPt

End Sub

Private Sub Auto_Close()
    Call Finish
End Sub

You should still be able to add new shapes while the code is running.
Click to expand...
I'll try that and let you know how it goes. Thank you so much!
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Solved
Disable shapes when Workbook is protected VBA
2
Replies
12
Views
426
mumps
mumps
L
  • Solved
VBA to resize shape incrementally
Replies
3
Views
197
Lil Stinker
L
B
  • Question
Event code to give message box and change color of auto-shape
Replies
4
Views
157
bh24524
B
JoeMajestee
  • Solved
How to refer to a shape added to a chart
Replies
2
Views
327
JoeMajestee
JoeMajestee
J
  • Question
Locking Worksheet
Replies
3
Views
134
dmt32
D

Forum statistics

Threads
1,214,943
Messages
6,122,376
Members
449,080
Latest member
Armadillos

Share this page

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
Back
Top