OnAction and Sheet Protection

[kiat]

I'm working on shapes a lot in a project and I encountered this strange
problem, when the sheet is protected, some of the shapes' OnAction don't
response to mouse click event. When the sheet is unprotected, then those
shapes that don't work before work this time. Do you know why?

I have Excel XP. To duplicate the problem, on a new workbook, draw 2
rectangles and assign its OnAction to Rectangle1_Click and Rectangle2_Click
respectively. Then copy and paste the following in Module1. Now, click on
Rectangle1, 2 arrows are drawn. Click on the top arrow, there is no
response, click on the bottom arrow, existing arrows are deleted and a small
arrow points to Rectangle1, which is expected. Now, click on Rectangle1
again. Unprotect the sheet manually with the password "abc". Click on the
top arrow and it'll response as expected. Can you duplicate this on your
version of Excel?

'****begin code ***
Option Explicit

Sub Rectangle1_Click()
DoClickEvent "Rectangle 1"
End Sub

Sub Rectangle2_Click()
DoClickEvent "Rectangle 2"
End Sub

Private Sub DoClickEvent(uid As String)
ActiveSheet.Unprotect "abc"
DelPointers
DrawLine "lineF", uid
DrawLine "lineB", uid
ActiveSheet.Protect "abc", DrawingObjects:=True
End Sub

Private Sub DelPointers()
On Error Resume Next
With ActiveSheet
.Shapes("LineP").Delete
.Shapes("LineF").Delete
.Shapes("LineB").Delete
.Shapes("LblB").Delete
.Shapes("LblF").Delete
End With
Err.Clear
End Sub

Private Sub DrawLine(nmLine As String, uid As String)
Dim obj1 As Excel.Shape
Dim x1 As Single, y1 As Single, x2 As Single, y2 As Single

Set obj1 = ActiveSheet.Shapes(uid)
x1 = obj1.Left + obj1.Width / 2
y1 = obj1.Top + obj1.Height / 2

x2 = 80 'point to west
y2 = y1
If nmLine = "lineB" Then
On Error Resume Next
Set obj1 = ActiveSheet.Shapes("lineF")
If Err = 0 Then 'prevent from going to same direction &
position
y2 = y1 + 15
End If
On Error GoTo 0
End If

'draw line
Set obj1 = ActiveSheet.Shapes.AddLine(x1, y1, x2, y2) 'draw!
obj1.Name = nmLine
With obj1.Line
'.Weight = 2.25
.Visible = msoTrue
.Style = msoLineSingle
.BeginArrowheadStyle = msoArrowheadOval
.EndArrowheadStyle = msoArrowheadOval
.BeginArrowheadWidth = msoArrowheadNarrow
.BeginArrowheadLength = msoArrowheadLengthMedium
.EndArrowheadWidth = msoArrowheadNarrow
.EndArrowheadLength = msoArrowheadLengthMedium
.EndArrowheadStyle = msoArrowheadTriangle
.ForeColor.SchemeColor = 14
End With

'assign macro
obj1.OnAction = "'" & ThisWorkbook.Name & "'!" & nmLine & "_Click"
obj1.AlternativeText = uid 'tag

'draw label
Set obj1 = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal,
x2, y2, 20, 10)
If nmLine = "lineF" Then
obj1.Name = "LblF"
obj1.TextFrame.Characters.Text = uid
Else
obj1.Name = "LblB"
obj1.TextFrame.Characters.Text = uid
End If
obj1.TextFrame.Characters.Font.Size = 8
obj1.TextFrame.Characters.Font.ColorIndex = 7
obj1.TextFrame.AutoSize = True
obj1.Line.Visible = msoFalse
obj1.Fill.Visible = msoFalse
obj1.OnAction = "'" & ThisWorkbook.Name & "'!" & nmLine & "_Click"
obj1.AlternativeText = uid 'tag


End Sub

Sub LineF_Click()
HighlightObj ActiveSheet.Shapes("LineF").AlternativeText
End Sub

Sub LineB_Click()
HighlightObj ActiveSheet.Shapes("LineB").AlternativeText
End Sub

Private Sub HighlightObj(ByVal strUID As String)
Dim x1 As Single, y1 As Single, xShp As Excel.Shape

With ActiveSheet
.Unprotect "abc"
.Activate
DelPointers
Set xShp = .Shapes(strUID)
End With

x1 = xShp.Left + xShp.Width
y1 = xShp.Top + xShp.Height / 2
Set xShp = ActiveSheet.Shapes.AddLine(x1 + 10, y1 + 10, x1, y1)
xShp.Name = "LineP"
With xShp.Line
.Visible = msoTrue
.Style = msoLineSingle
.BeginArrowheadStyle = msoArrowheadNone
.EndArrowheadStyle = msoArrowheadTriangle
.BeginArrowheadWidth = msoArrowheadWidthMedium
.BeginArrowheadLength = msoArrowheadLengthMedium
.EndArrowheadWidth = msoArrowheadWidthMedium
.EndArrowheadLength = msoArrowheadLengthMedium
.ForeColor.SchemeColor = 14
End With
ActiveSheet.Protect "abc", DrawingObjects:=True

End Sub
'**** end code ****