OskarBravo
New Member
- Joined
- May 8, 2012
- Messages
- 1
Hi all,
i can´t get this code to work correctly in Excel 2010. It is used to make simple organization charts, by pasting a Autoshape circle and connecting it with a line to another circle, this works fine.
The macro can also be used to remove the circle and line again by using the same command, this part doesn´t work anymore. I think the problems is that the circle is not pasted in to same place as in Excel 2003.
Any solutions?
Thanks in advance,
Oskar
i can´t get this code to work correctly in Excel 2010. It is used to make simple organization charts, by pasting a Autoshape circle and connecting it with a line to another circle, this works fine.
The macro can also be used to remove the circle and line again by using the same command, this part doesn´t work anymore. I think the problems is that the circle is not pasted in to same place as in Excel 2003.
Any solutions?
Thanks in advance,
Oskar
Sub mcroInsertStructure()
'
'
' Keyboard Shortcut: Ctrl+s
'
On Error Resume Next
Range(Selection.TopLeftCell.Address).Select
Dim shloop As Shape
Dim r As Range
Set r = ActiveCell
Sheets("Symbols").Shapes("Oval 2").Copy
ActiveSheet.Paste
For Each shloop In ActiveSheet.Shapes
If (shloop.AutoShapeType = 9 Or shloop.AutoShapeType = 77) And shloop.Name <> Selection.Name Then
If shloop.Top = Selection.Top And shloop.Left = Selection.Left Then
Call DeleteConnector(shloop)
shloop.Delete
Selection.Delete
Exit Sub
End If
End If
Next shloop
Call mcroConnector
Range(r.Address).Select
End Sub
Sub mcroInsertAttribute()
'
' Keyboard Shortcut: Ctrl+a
'
On Error Resume Next
Range(Selection.TopLeftCell.Address).Select
Dim shloop As Shape
Dim r As Range
Set r = ActiveCell
Sheets("Symbols").Shapes("AutoShape 1").Copy
ActiveSheet.Paste
For Each shloop In ActiveSheet.Shapes
If (shloop.AutoShapeType = 9 Or shloop.AutoShapeType = 77) And shloop.Name <> Selection.Name Then
If shloop.Top = Selection.Top And shloop.Left = Selection.Left Then
Call DeleteConnector(shloop)
shloop.Delete
Selection.Delete
Exit Sub
End If
End If
Next shloop
Call mcroConnector
Range(r.Address).Select
End Sub
Sub DeleteConnector(s As Shape)
Dim ConncetorName As String
connectorname = mcroConnector()
Dim shloop As Shape
If connectorname <> "" Then
For Each shloop In ActiveSheet.Shapes
If shloop.Left = ActiveSheet.Shapes(connectorname).Left And _
shloop.Width = ActiveSheet.Shapes(connectorname).Width And _
shloop.Top = ActiveSheet.Shapes(connectorname).Top And _
shloop.Height = ActiveSheet.Shapes(connectorname).Height Then
shloop.Delete
ActiveSheet.Shapes(connectorname).Delete
Exit Sub
End If
Next shloop
End If
End Sub
Function mcroConnector() As String
On Error GoTo endsub
Dim sh As Shape
Dim shloop As Shape
Dim shEnd As String
Set sh = ActiveSheet.Shapes.AddConnector(msoConnectorElbow, 6.75, 11.25, 54.75, 34.5)
'Selection.ShapeRange.Flip msoFlipHorizontal
'Selection.ShapeRange.Flip msoFlipVertical
sh.ConnectorFormat.BeginConnect Selection.ShapeRange(1), 3
shEnd = ""
For Each shloop In ActiveSheet.Shapes
If shloop.AutoShapeType = 9 And shloop.Name <> Selection.ShapeRange(1).Name Then
If shloop.Top < Selection.ShapeRange(1).Top And shloop.Left < Selection.ShapeRange(1).Left Then
If shEnd = "" Then
shEnd = shloop.Name
Else
If shloop.Top >= ActiveSheet.Shapes(shEnd).Top Then
shEnd = shloop.Name
End If
End If
End If
End If
Next shloop
If shEnd = "" Then sh.Delete
sh.ConnectorFormat.EndConnect ActiveSheet.Shapes(shEnd), 5
mcroConnector = sh.Name
endsub:
End Function