Macro to add a connection point to the center of every circle in a dwg

Y

Yury

Hello, I'm trying to figure out how to add a connection point that is
relative to a shape, such as the center of a circle. I'm used to doing this
in Autocad, but not in visio. Can someone show me how to make a macro or
know if one already esists that can find all the circle shapes in a drawing,
and insert a connection point at the center of each one.

(Usiing visio2003)

Thanks in advance..
 
A

Al Edlund

You might try something like this,
Al


' this is called by the following routine to add a standard set of
' connections to the rectangles used

Public Function funcAddConnectionPointToShape(vsoShape As Visio.Shape, _
strLocalRowName As String, _
strRowNameU As String, _
strLabelName As String, _
strConnectType As String, _
strX As String, _
strY As String, _
Optional strDirX As String, _
Optional strDirY As String, _
Optional blnAutoGen As Boolean) As Boolean

Dim vsoCell As Visio.Cell
Dim intRowIndex As Integer
Dim strCurrentTask As String ' for debug

On Error GoTo AddConnectionPt_Err

intRowIndex = vsoShape.AddNamedRow(visSectionConnectionPts, _
strLocalRowName, VisRowIndices.visRowConnectionPts)

If (strLocalRowName <> strRowNameU And _
Len(strRowNameU) > 0) Then
vsoCell.RowNameU = strRowNameU
End If

' Column 0: X
Set vsoCell = vsoShape.CellsSRC(visSectionConnectionPts, _
visRowConnectionPts + intRowIndex, visX)
vsoCell.Formula = strX

' Column 1: Y
Set vsoCell = vsoShape.CellsSRC(visSectionConnectionPts, _
visRowConnectionPts + intRowIndex, visY)
vsoCell.Formula = strY

' Column 2: direction x
Set vsoCell = vsoShape.CellsSRC(visSectionConnectionPts, _
visRowConnectionPts + intRowIndex, visCnnctDirX)
vsoCell.Formula = strDirX

' Column 3: direction y
Set vsoCell = vsoShape.CellsSRC(visSectionConnectionPts, _
visRowConnectionPts + intRowIndex, visCnnctDirY)
vsoCell.Formula = strDirY

' Column 4: type
Set vsoCell = vsoShape.CellsSRC(visSectionConnectionPts, _
visRowConnectionPts + intRowIndex, visCnnctType)
vsoCell.Formula = strConnectType

' Column 5: autogen
Set vsoCell = vsoShape.CellsSRC(visSectionConnectionPts, _
visRowConnectionPts + intRowIndex, visCnnctAutoGen)
vsoCell.ResultIU = blnAutoGen

funcAddConnectionPointToShape = True

Exit Function

AddConnectionPt_Err:

If Err > 0 Then
Debug.Print "Err in funcAddConnectionPointToShape " & Err & " " &
Err.Description & " " & strCurrentTask
funcAddConnectionPointToShape = False
End If

End Function



Public Sub subAddStandardConnections(visShape As Visio.Shape)

Dim visSection As Integer
Dim blnResult As Boolean

On Error GoTo AddStandardConnections_Err

visSection = visSectionConnectionPts

' first see if a connection section exists so that
' we don't overwrite existing connections (oops)

blnResult = visShape.SectionExists(visSection, False)

If blnResult = False Then
visShape.AddSection visSection
End If

' add one in the middle
blnResult = funcAddConnectionPointToShape(visShape, "Middle", "Middle",
"Middle", _
2, "Width * 0.5", "Height * 0.5", 0, False)
' add one on the left
blnResult = funcAddConnectionPointToShape(visShape, "Left", "Left",
"Left", _
2, "0", "Height * 0.5", 0, False)
' add one on the right
blnResult = funcAddConnectionPointToShape(visShape, "Right", "Right",
"Right", _
2, "Width", "Height * 0.5", 0, False)
' add one on the top
blnResult = funcAddConnectionPointToShape(visShape, "Top", "Top", "Top",
_
2, "Width * 0.5", "Height", 0, False)
' add one on the bottom
blnResult = funcAddConnectionPointToShape(visShape, "Bottom", "Bottom",
"Bottom", _
2, "Width * 0.5", "0", 0, False)

AddStandardConnections_Exit:
Exit Sub

AddStandardConnections_Err:
Resume Next

End Sub
 
Y

Yury

OK i think i understand how the script works, but i'm having trouble
inserting it into a drawing.
Do I do the usual Alt+F8 and create a new macro? or is there something else?

hope you dont mind.. just never did scripting before :)
 
M

Markus Breugst

Hi,

I don't know how to find out if the shape is a circle, since these basic
shapes don't seem to have a master. Thus, the macro below just adds one
connection point to the middle of each selected(!) shape, independent of its
type.
Note that the function below does not check if the connection point already
exists. However, it's just meant as an example to show how this could work.

Best regards,
Markus

Public Sub AddConnectionPoint()
Dim selectedShapes As Selection
Dim theShape As Shape
Dim index As Integer
Dim rowNumber As Integer

Set selectedShapes = ActiveWindow.Selection

For index = 1 To selectedShapes.Count
Set theShape = selectedShapes.Item(index)
If theShape.SectionExists(Visio.visSectionConnectionPts, 1) = False
Then
theShape.AddSection (Visio.visSectionConnectionPts)
End If
rowNumber = theShape.AddRow(Visio.visSectionConnectionPts,
Visio.visRowConnectionPts, Visio.VisRowTags.visTagCnnctPt)
theShape.CellsSRC(Visio.visSectionConnectionPts,
Visio.visRowConnectionPts, Visio.visX).Formula = "=Width/2"
theShape.CellsSRC(Visio.visSectionConnectionPts,
Visio.visRowConnectionPts, Visio.visY).Formula = "=Height/2"
Next
End Sub
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Top