Disable selection of shapes

[Mike]

Hi. I have a macro that will place a shape (either a
circle or rectange) in several cells based on the value
in the cell.

I want the user to be able to change the value of the
cell, but I do not want them to be able to select the
shape that is in the cell.

Could someone tell me how to accomplish this? My code is
included below.

Thanks,
Mike.


Private Sub Worksheet_Change(ByVal Target As Range)
Dim myrange As Range
Dim myCell As Range
Dim myOval As Shape
Dim mySquare As Shape
Dim pbar, lcl, ucl
Dim n As Integer
Dim pbarn As Variant
Dim lastRow As Integer
'This statement find the last row of the spreadsheet
lastRow = Rows.Find(What:="Percentage").Row
Set myrange = Worksheets("Practice").Range("c26:y" &
lastRow - 2)
For Each myCell In myrange.Cells
'The following with statement calculates the control
limits for each individual
'entry on the chart and places red squares or green
circles around the entry.
With myCell
pbar = Range("A" & .Row)
n = myrange(lastRow - 26, .Column - 2)
pbarn = pbar * n
lcl = pbarn - 2.58 * Sqr(pbarn * (1 -
pbar))
ucl = pbarn + 2.58 * Sqr(pbarn * (1 -
pbar))
If .Value < lcl Then
Set myOval = .Parent.Shapes.AddShape
(Type:=msoShapeOval, _
Top:=.Top + 1, Left:=.Left + 2,
Width:=.Width - 4, Height:=.Height - 2)
myOval.Fill.Visible = msoTrue
myOval.Line.Weight = 1.5
myOval.Line.ForeColor.SchemeColor = 17
myOval.Fill.ForeColor.SchemeColor = 11
myOval.Fill.Transparency = 0.85
End If
If .Value > ucl Then
Set mySquare = .Parent.Shapes.AddShape
(Type:=msoShapeRectangle, _
Top:=.Top + 1.5, Left:=.Left + 1.5,
Width:=.Width - 3, Height:=.Height - 3)
mySquare.Fill.Visible = msoTrue
mySquare.Line.Weight = 1.5
mySquare.Line.ForeColor.SchemeColor = 10
mySquare.Fill.ForeColor.SchemeColor = 10
mySquare.Fill.Transparency = 0.85
End If
End With
Next myCell

Set myrange = Worksheets("Practice").Range("c39:y" &
lastRow)
For Each myCell In myrange.Cells
'The following with statement calculates the control
limits for the totals row
' and places red squares or green circles around the
entry.
With myCell
pbar = Range("A" & lastRow - 2)
n = myrange(0, .Column - 2)
pbarn = pbar * n
If n > 0 Then
lcl = pbar - 2.58 * Sqr(pbar * (1 -
pbar) / n)
ucl = pbar + 2.58 * Sqr(pbar * (1 -
pbar) / n)

If .Value < lcl Then
Set myOval = .Parent.Shapes.AddShape
(Type:=msoShapeOval, _
Top:=.Top + 1, Left:=.Left + 2,
Width:=.Width - 4, Height:=.Height - 2)
myOval.Fill.Visible = msoTrue
myOval.Line.Weight = 1.5
myOval.Line.ForeColor.SchemeColor = 17
myOval.Fill.ForeColor.SchemeColor = 11
myOval.Fill.Transparency = 0.85
End If
If .Value > ucl Then
Set mySquare = .Parent.Shapes.AddShape
(Type:=msoShapeRectangle, _
Top:=.Top + 1.5, Left:=.Left +
1.5, Width:=.Width - 3, Height:=.Height - 3)
mySquare.Fill.Visible = msoTrue
mySquare.Line.Weight = 1.5
mySquare.Line.ForeColor.SchemeColor = 10
mySquare.Fill.ForeColor.SchemeColor = 10
mySquare.Fill.Transparency = 0.85
End If
End If
End With
Next myCell
End Sub

 

[Jim Rech]

The only way I know of to prevent shapes from being selected is to protect
the worksheet (Tools, Protection, Protect Sheet).

 

[Alex J]

A partial solution is a "Null" subroutine, like the following:

Sub ClickMe()
End Sub

This has the effect of nullifying the mouse left-click selection function
very nicely. Unfortunately, I know of no way to prevent the right-click
selection. If someone in the NG knows how to capture right-click event for a
shape, we might have a full solution here.

HT(partially)H,

Alex J

 

[Jim Rech]

Good thought about assigning a null macro. It might eliminate most
"accidental" selections. Besides the right-click another issue is
Ctrl-click. I do think sheet protection is a good approach though,
unlocking the cells users can change in advance.