How to allow moving shapes, but prevent editing their text on a worksheet

A

Antar

New Member
Joined
Feb 12, 2022
Messages
6
Office Version
  1. 365
Platform
  1. Windows
I have a challenge to overcome, but couldn't find any hint yet and hope you guys can help. I need to create shapes (e.g. msoShapeRectangle) with specific texts in them in a worksheet. Once created, I want to allow users to move the shapes on the worksheet, but I want to prevent them, editing the text which had been written in the shapes. How can I achieve this?
Many thanks in Advance!
Antar
 

Excel Facts

When they said...
When they said you are going to "Excel at life", they meant you "will be doing Excel your whole life".
Sort by date Sort by votes
Welcome to the forum.

Protecting the worksheet will prevent editing the shapes text. Unfortunately, this will also prevent moving or resizing the shapes.

The only workaround I can think of is to store the initial shapes text in their respective AlternativeText Property and then use the CommandBars OnUpdate event to detect when\if the user has changed the shape text. If the text has changed, restore it immediately from the shape AlternativeText Property.

Place this code in the ThisWorkbook Module:
VBA Code: 
Option Explicit

Private WithEvents Cmbrs As CommandBars

Private Sub Workbook_Open()
    Call AddAlternativeTextToShapes
    Set Cmbrs = Application.CommandBars
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Set Cmbrs = Application.CommandBars
End Sub

Private Sub AddAlternativeTextToShapes()
    
    Dim ws As Worksheet
    Dim shp As Shape
    
    On Error Resume Next
    For Each ws In Me.Worksheets
        For Each shp In Sheet1.Shapes
            shp.AlternativeText = shp.TextFrame2.TextRange.Text
        Next shp
    Next ws

End Sub

Private Sub Cmbrs_OnUpdate()

    On Error Resume Next
    
    If TypeName(Selection) <> "Range" Then
        With Selection.ShapeRange
            If .TextFrame2.TextRange.Text <> .AlternativeText Then
                If Err.Number = 0 Then
                    .TextFrame2.TextRange.Text = .AlternativeText
                    MsgBox "The Text Of This Shape : [" & Selection.Name & "] " & _
                           vbNewLine & "Is Locked For Editing.", vbCritical
                End If
            End If
        End With
    End If

End Sub
 
Last edited:
Upvote 0
Stupid error in the AddAlternativeTextToShapes SUB but editing time is up!!

So, please, Ignore the previous code and use the following one:

Place this code in the ThisWorkbook Module:
VBA Code: 
Option Explicit

Private WithEvents Cmbrs As CommandBars

Private Sub Workbook_Open()
    Call AddAlternativeTextToShapes
    Set Cmbrs = Application.CommandBars
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Set Cmbrs = Application.CommandBars
End Sub

Private Sub AddAlternativeTextToShapes()
   
    Dim ws As Worksheet
    Dim shp As Shape
   
    On Error Resume Next
    For Each ws In Me.Worksheets
        For Each shp In ws.Shapes
            shp.AlternativeText = shp.TextFrame2.TextRange.Text            
        Next shp
    Next ws

End Sub

Private Sub Cmbrs_OnUpdate()

    On Error Resume Next
   
    If TypeName(Selection) <> "Range" Then
        With Selection.ShapeRange
            If .TextFrame2.TextRange.Text <> .AlternativeText Then
                If Err.Number = 0 Then
                    .TextFrame2.TextRange.Text = .AlternativeText
                    MsgBox "The Text Of This Shape : [" & Selection.Name & "] " & _
                           vbNewLine & "Is Locked For Editing.", vbCritical
                End If
            End If
        End With
    End If

End Sub
 
Upvote 0
Solution
Here is a different approach (API based).

Workbook Example

Follow these steps:

1- Protect the worksheet(s) so that the user cannot edit the text of the shapes. (Keep 'Edit Objects' box UnChecked)

2- Place the following code in the ThisWorkbook Module:

VBA Code: 
Option Explicit

Private Type POINTAPI
    X As Long
    Y As Long
End Type

#If VBA7 Then
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare PtrSafe Function SetCursorAPI Lib "user32" Alias "SetCursor" (ByVal hCursor As LongPtr) As LongPtr
    Private Declare PtrSafe Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As LongPtr, ByVal lpCursorName As Long) As Long
    Private Declare PtrSafe Function DestroyCursor Lib "user32" (ByVal hCursor As LongPtr) As Long
#Else
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare Function SetCursorAPI Lib "user32" Alias "SetCursor" (ByVal hCursor As Long) As Long
    Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
    Private Declare Function DestroyCursor Lib "user32" (ByVal hCursor As Long) As Long
#End If


Private Sub Workbook_Open()
    Call AssignGenericMacro
End Sub

Private Sub AssignGenericMacro()

    Dim ws As Worksheet
    Dim shp As Shape

    For Each ws In ThisWorkbook.Worksheets
        For Each shp In ws.Shapes
            shp.OnAction = Me.CodeName & ".GenericMacro"
        Next shp
    Next ws

End Sub

Private Sub GenericMacro()

    Const IDC_NO = 32646&
    Static tInitPt As POINTAPI
    #If Win64 Then
        Dim hCursor As LongLong
    #Else
        Dim hCursor As Long
    #End If
    Dim tCurPt As POINTAPI
    Dim t As Single, l As Single
  
    l = ActiveSheet.Shapes(Application.Caller).Left
    t = ActiveSheet.Shapes(Application.Caller).Top
    hCursor = LoadCursor(0, IDC_NO)
    Call GetCursorPos(tInitPt)
  
    Do
        Call GetCursorPos(tCurPt)
        If tCurPt.X <> 0 And tCurPt.X <> tInitPt.X Then
            If tCurPt.Y <> 0 And tCurPt.Y <> tInitPt.Y Then
                Call SetCursorAPI(hCursor)
            End If
        End If
    Loop Until GetAsyncKeyState(VBA.vbKeyLButton) = 0
  
    Call DestroyCursor(hCursor)
  
    With ActiveSheet.Shapes(Application.Caller)
        .Left = ActiveWindow.RangeFromPoint(tCurPt.X, tCurPt.Y).Left
        .Top = ActiveWindow.RangeFromPoint(tCurPt.X, tCurPt.Y).Top
          'OPTIONAL FEEDBACK ... COMMENT OUT THE FOLLOWING LINES IF FEEDBACK NOT NEEDED.
        If .Left = l And .Top = t Then
            Application.OnTime Now, "'" & Me.CodeName & ".UserFeedBack """ & .Name & """ , TRUE '"
        Else
            Application.OnTime Now, "'" & Me.CodeName & ".UserFeedBack """ & .Name & """ , False '"
        End If
    End With  
  
End Sub

Private Sub UserFeedBack(ByVal ShapeName As String, ByVal Click As Boolean)
    MsgBox "You " & IIf(Click, "CLIKED", "MOVED") & " the Shape :" & vbNewLine & "[" & ShapeName & "]", vbInformation
End Sub


Note:
In order for the code to take effect, you will first need to close and re-open the workbook (This will give a chance to the Workbook_Open event to fire and assign the generic macro to all the shapes)
 
Last edited:
Upvote 0
Jaafar Tribak said:
Here is a different approach (API based).

Workbook Example

Follow these steps:

1- Protect the worksheet(s) so that the user cannot edit the text of the shapes. (Keep 'Edit Objects' box UnChecked)

2- Place the following code in the ThisWorkbook Module:

VBA Code: 
Option Explicit

Private Type POINTAPI
    X As Long
    Y As Long
End Type

#If VBA7 Then
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare PtrSafe Function SetCursorAPI Lib "user32" Alias "SetCursor" (ByVal hCursor As LongPtr) As LongPtr
    Private Declare PtrSafe Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As LongPtr, ByVal lpCursorName As Long) As Long
    Private Declare PtrSafe Function DestroyCursor Lib "user32" (ByVal hCursor As LongPtr) As Long
#Else
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare Function SetCursorAPI Lib "user32" Alias "SetCursor" (ByVal hCursor As Long) As Long
    Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
    Private Declare Function DestroyCursor Lib "user32" (ByVal hCursor As Long) As Long
#End If


Private Sub Workbook_Open()
    Call AssignGenericMacro
End Sub

Private Sub AssignGenericMacro()

    Dim ws As Worksheet
    Dim shp As Shape

    For Each ws In ThisWorkbook.Worksheets
        For Each shp In ws.Shapes
            shp.OnAction = Me.CodeName & ".GenericMacro"
        Next shp
    Next ws

End Sub

Private Sub GenericMacro()

    Const IDC_NO = 32646&
    Static tInitPt As POINTAPI
    #If Win64 Then
        Dim hCursor As LongLong
    #Else
        Dim hCursor As Long
    #End If
    Dim tCurPt As POINTAPI
    Dim t As Single, l As Single
 
    l = ActiveSheet.Shapes(Application.Caller).Left
    t = ActiveSheet.Shapes(Application.Caller).Top
    hCursor = LoadCursor(0, IDC_NO)
    Call GetCursorPos(tInitPt)
 
    Do
        Call GetCursorPos(tCurPt)
        If tCurPt.X <> 0 And tCurPt.X <> tInitPt.X Then
            If tCurPt.Y <> 0 And tCurPt.Y <> tInitPt.Y Then
                Call SetCursorAPI(hCursor)
            End If
        End If
    Loop Until GetAsyncKeyState(VBA.vbKeyLButton) = 0
 
    Call DestroyCursor(hCursor)
 
    With ActiveSheet.Shapes(Application.Caller)
        .Left = ActiveWindow.RangeFromPoint(tCurPt.X, tCurPt.Y).Left
        .Top = ActiveWindow.RangeFromPoint(tCurPt.X, tCurPt.Y).Top
          'OPTIONAL FEEDBACK ... COMMENT OUT THE FOLLOWING LINES IF FEEDBACK NOT NEEDED.
        If .Left = l And .Top = t Then
            Application.OnTime Now, "'" & Me.CodeName & ".UserFeedBack """ & .Name & """ , TRUE '"
        Else
            Application.OnTime Now, "'" & Me.CodeName & ".UserFeedBack """ & .Name & """ , False '"
        End If
    End With 
 
End Sub

Private Sub UserFeedBack(ByVal ShapeName As String, ByVal Click As Boolean)
    MsgBox "You " & IIf(Click, "CLIKED", "MOVED") & " the Shape :" & vbNewLine & "[" & ShapeName & "]", vbInformation
End Sub


Note:
In order for the code to take effect, you will first need to close and re-open the workbook (This will give a chance to the Workbook_Open event to fire and assign the generic macro to all the shapes)
Click to expand...
Hey Jaafar, thank you very much for your solution options and the effort you have spent on this.
I have tried both approaches. The second one (API based) works. However the user experience is not good (too slow and users don’t see where they move the shape to, etc.).
The first option (second code) sounds to be great. But unfortunately it doesn't work for me.
If I click on a shape, it responds with the following error message saying “excel cannot run the macro "thisworkbook.GenericMacro". The macro may not be available in this workbook or all macros may be disabled.”
This is really strange, since the I have added your code to a fresh workbook and saved it as xlsm. … and I don’t understand the “GenericMAcro” part in particular.
I might be overseeing the obvious, but I don’t understand the error message.
Do you have any idea?
Cheers, Antar.
 
Upvote 0
Jaafar Tribak said:
Stupid error in the AddAlternativeTextToShapes SUB but editing time is up!!

So, please, Ignore the previous code and use the following one:

Place this code in the ThisWorkbook Module:
VBA Code: 
Option Explicit

Private WithEvents Cmbrs As CommandBars

Private Sub Workbook_Open()
    Call AddAlternativeTextToShapes
    Set Cmbrs = Application.CommandBars
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Set Cmbrs = Application.CommandBars
End Sub

Private Sub AddAlternativeTextToShapes()
  
    Dim ws As Worksheet
    Dim shp As Shape
  
    On Error Resume Next
    For Each ws In Me.Worksheets
        For Each shp In ws.Shapes
            shp.AlternativeText = shp.TextFrame2.TextRange.Text           
        Next shp
    Next ws

End Sub

Private Sub Cmbrs_OnUpdate()

    On Error Resume Next
  
    If TypeName(Selection) <> "Range" Then
        With Selection.ShapeRange
            If .TextFrame2.TextRange.Text <> .AlternativeText Then
                If Err.Number = 0 Then
                    .TextFrame2.TextRange.Text = .AlternativeText
                    MsgBox "The Text Of This Shape : [" & Selection.Name & "] " & _
                           vbNewLine & "Is Locked For Editing.", vbCritical
                End If
            End If
        End With
    End If

End Sub
Click to expand...
Hey Jaafar, thank you very much for your solution options and the effort you have spent on this.
I have tried both approaches. The second one (API based) works. However the user experience is not good (too slow and users don’t see where they move the shape to, etc.).
The first option (second code) sounds to be great. But unfortunately it doesn't work for me.
If I click on a shape, it responds with the following error message saying “excel cannot run the macro "thisworkbook.GenericMacro". The macro may not be available in this workbook or all macros may be disabled.”
This is really strange, since the I have added your code to a fresh workbook and saved it as xlsm. … and I don’t understand the “GenericMAcro” part in particular.
I might be overseeing the obvious, but I don’t understand the error message.
Do you have any idea?
Cheers, Antar.
 
Upvote 0
@Antar
The first option (second code) sounds to be great. But unfortunately it doesn't work for me.
Click to expand...
Are you sure you are placing the code in the correct ThisWorkbook Module ?

Below is a workbook example that shows how the first option (second code) works:
Workbook Download

Note:
In order for the code to take effect, the Workbook_Open event needs to fire.
 
Last edited:
Upvote 0
Jaafar Tribak said:
@Antar

Are you sure you are placing the code in the correct ThisWorkbook Module ?

Below is a workbook example that shows how the first option (second code) works:
Workbook Download

Note:
In order for the code to take effect, the Workbook_Open event needs to fire.
Click to expand...
Thank you, I don't know what was the reason. I deleted the shapes and created new ones. Then your code worked with the new shapes. Can it have an issue with shapes which have been added to the sheet, prior to adding the code? This would be really stangs. However, with new shapes it worls. Thanks a ton man!
 
Upvote 0
Jaafar Tribak said:
Don't know. Can you uplaod here a copy of the workbook that doesn't work so I can take a look.
You can use some file sharing website such as Secure File Sharing, Storage, and Collaboration | Box
Click to expand...
I know now how it can be reproduced:
1) start with an empty workbook and add some shapes with texts and alt texts
2) add your API based code to it and save it
3) open the file and replace the API based code with the first one and save it.
From this moment on it bugs when you click on the shapes. Really strange, since the other code had been removed. However, removing those shapes and adding new ones make it work fine again.

AGAIN, THANKS A LOT FOR YOUR HELP! It was a great idea.
Best
 
Upvote 0
You must log in or register to reply here.

Similar threads

W
  • Question
How to add "edit text import" to get data from an external text file?
Replies
3
Views
148
waljbt
W
C
  • Question
Partially lock shapes in the same sheet
Replies
6
Views
907
ceecee88
C
S
  • Question
How can you insert images on a protected worksheet in a protected workbook?
Replies
1
Views
613
spurs
S
L
  • Solved
Would like to make edits to VBA Calendar Code
Replies
8
Views
400
Legacy 352679
L
R
  • Question
Prevent shapes from being moved into certain cell
Replies
1
Views
821
tonyyy
tonyyy

Forum statistics

Threads
1,215,009
Messages
6,122,674
Members
449,091
Latest member
peppernaut

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