M
MikeZz
Hi,
I modifed a routine I found in the internet to draw lines between to cells.
It works perfectly in excel 2003 but 2007 I get the following error:
Method 'Select' of object 'Shape' failed. Run time Error.
in the code look for this line to find the error:
'GET 2007 ERROR HERE (Works in 2003)
Thanks for ANY help! It's driving me nuts.
MikeZz
Private Sub DrawArrow(r1 As Range, r2 As Range, Optional lineName, Optional
linecolor, Optional scriptNo, Optional lineEnds)
' shg 2008-0803
' Draws a line beween the center of the two ranges
Dim x1 As Double
Dim x2 As Double
Dim y1 As Double
Dim y2 As Double
Dim screenTipText
Dim linkR, linkC
Dim linkAdd
Dim LineShape As Shape
Dim cityNo
Dim cityIdx
Dim cityMax
Dim this_Comd
Dim colorThis
Application.StatusBar = "Drawing Arrow: " & scriptNo & " of " & sCount
' Application.ScreenUpdating = True
cityNo = arrScript(scriptNo, script_Type)
cityIdx = arrScript(script_Cidx, script_Type)
cityMax = arrCityInfo(rowCityLast, cityNo)
If IsMissing(linecolor) Then
linecolor = 12
End If
this_Comd = arrScript(scriptNo, script_Comd)
If this_Comd = "attack" Then
colorThis = "Red"
ElseIf this_Comd = "transport" Then
colorThis = "Green"
Else
colorThis = "Black"
End If
With r1
x1 = .Left + .Width / 2
y1 = .Top + .Height / 2
End With
With r2
x2 = .Left + .Width / 2
y2 = .Top + .Height / 2
End With
With shtMap.Shapes.AddLine(x1, y1, x2, y2)
Set LineShape = shtMap.Shapes(shtMap.Shapes.Count)
End With
' LineShape.Line.Visible = False
Dim shpCount
If IsMissing(scriptNo) Then
Else
screenTipText = Get_Arrow_ScreenTip(scriptNo)
shpCount = ActiveSheet.Shapes.Count
linkR = arrScript(scriptNo, script_CelR)
linkC = arrScript(scriptNo, script_CelC)
linkAdd = "Scripts!" & Sheets("Scripts").Cells(linkR, linkC).Address
Application.StatusBar = "Adding Hyperlink Line: " & lineName & " "
& linkAdd
If AddLineHyper = True Then
If AddLineHoover = True Then
'GET 2007 ERROR HERE (Works in 2003)
LineShape.Select
ActiveSheet.Hyperlinks.Add Anchor:=LineShape, Address:= _
"", SubAddress:=linkAdd, ScreenTip:=screenTipText
Else
'GET 2007 ERROR HERE (Works in 2003)
LineShape.Select
ActiveSheet.Hyperlinks.Add Anchor:=LineShape, Address:= _
"", SubAddress:=linkAdd
End If
End If
End If
Set LineShape = Nothing
End Sub
I modifed a routine I found in the internet to draw lines between to cells.
It works perfectly in excel 2003 but 2007 I get the following error:
Method 'Select' of object 'Shape' failed. Run time Error.
in the code look for this line to find the error:
'GET 2007 ERROR HERE (Works in 2003)
Thanks for ANY help! It's driving me nuts.
MikeZz
Private Sub DrawArrow(r1 As Range, r2 As Range, Optional lineName, Optional
linecolor, Optional scriptNo, Optional lineEnds)
' shg 2008-0803
' Draws a line beween the center of the two ranges
Dim x1 As Double
Dim x2 As Double
Dim y1 As Double
Dim y2 As Double
Dim screenTipText
Dim linkR, linkC
Dim linkAdd
Dim LineShape As Shape
Dim cityNo
Dim cityIdx
Dim cityMax
Dim this_Comd
Dim colorThis
Application.StatusBar = "Drawing Arrow: " & scriptNo & " of " & sCount
' Application.ScreenUpdating = True
cityNo = arrScript(scriptNo, script_Type)
cityIdx = arrScript(script_Cidx, script_Type)
cityMax = arrCityInfo(rowCityLast, cityNo)
If IsMissing(linecolor) Then
linecolor = 12
End If
this_Comd = arrScript(scriptNo, script_Comd)
If this_Comd = "attack" Then
colorThis = "Red"
ElseIf this_Comd = "transport" Then
colorThis = "Green"
Else
colorThis = "Black"
End If
With r1
x1 = .Left + .Width / 2
y1 = .Top + .Height / 2
End With
With r2
x2 = .Left + .Width / 2
y2 = .Top + .Height / 2
End With
With shtMap.Shapes.AddLine(x1, y1, x2, y2)
Set LineShape = shtMap.Shapes(shtMap.Shapes.Count)
End With
' LineShape.Line.Visible = False
Dim shpCount
If IsMissing(scriptNo) Then
Else
screenTipText = Get_Arrow_ScreenTip(scriptNo)
shpCount = ActiveSheet.Shapes.Count
linkR = arrScript(scriptNo, script_CelR)
linkC = arrScript(scriptNo, script_CelC)
linkAdd = "Scripts!" & Sheets("Scripts").Cells(linkR, linkC).Address
Application.StatusBar = "Adding Hyperlink Line: " & lineName & " "
& linkAdd
If AddLineHyper = True Then
If AddLineHoover = True Then
'GET 2007 ERROR HERE (Works in 2003)
LineShape.Select
ActiveSheet.Hyperlinks.Add Anchor:=LineShape, Address:= _
"", SubAddress:=linkAdd, ScreenTip:=screenTipText
Else
'GET 2007 ERROR HERE (Works in 2003)
LineShape.Select
ActiveSheet.Hyperlinks.Add Anchor:=LineShape, Address:= _
"", SubAddress:=linkAdd
End If
End If
End If
Set LineShape = Nothing
End Sub