I'm trying to write a sub/function that will take a shape and add n connection points to it distributed around the shape. For example, if I wanted a shape to have 8 connection points distributed around it that scale when the shape does, I'd call the sub with the shape and 8 for number of divisions.
I'm having real trouble doing this automatically and have separate subs for each type of divisio (4 parts, 8 parts). How can I make this work?
What I have below for 8 parts is an example of what I'm doing
Public Sub CP_Add_Square_Eighths(theShape As Shape)
Shape_Add_CP_XY theShape, "=width/2", "=height/2"
Shape_Add_CP_XY theShape, "=width", "=height/4"
Shape_Add_CP_XY theShape, "=width", "=height-(height/4)"
Shape_Add_CP_XY theShape, "0", "=height/4"
Shape_Add_CP_XY theShape, "0", "=height-(height/4)"
Shape_Add_CP_XY theShape, "=width/4", "0"
Shape_Add_CP_XY theShape, "=width-(width/4)", "0"
Shape_Add_CP_XY theShape, "=width/4", "=height"
Shape_Add_CP_XY theShape, "=width-(width/4)", "=height"
Shape_Add_CP_XY theShape, "=width/2", "=height"
Shape_Add_CP_XY theShape, "=width/2", "0"
Shape_Add_CP_XY theShape, "=width", "=height/2"
Shape_Add_CP_XY theShape, "0", "=height/2"
' corner points
End Sub
Sub Shape_Add_CP_XY(theShape As Shape, sX As String, sY As String)
Dim rowNumber As Integer
rowNumber = theShape.AddRow(Visio.visSectionConnectionPts, Visio.visRowConnectionPts, Visio.VisRowTags.visTagCnnctPt)
theShape.CellsSRC(Visio.visSectionConnectionPts, Visio.visRowConnectionPts, Visio.visX).Formula = sX
theShape.CellsSRC(Visio.visSectionConnectionPts, Visio.visRowConnectionPts, Visio.visY).Formula = sY
End Sub
VBA aside, its a bit more complicated then your macro suggests
For example, assume you want 4 evenly spaced connection points on a side
Then width/5 is the interval and you want
connection point 1 = 1* width/5, height*1
connection point 4 = 4*width/5, height *1
Also, the specific case of a square is pretty simple
A circle is more complex yet
connection point n = n * R * cos(360/(N+1)), n*R*sin(360/(N+1))
where n = slice R is the radius (sqrt((width/2)^2+(height/2)^2) N = total connection points you want
Ellipsis are even uglier.
What I would do would be
- take shape in question
- open shapesheet and add connection points via formulas...until you get the results you want
- Then work to code into VBA.
Assuming the question is how to facilitate the choice of the number of connection points per shape, the use and creation of a custom user form would do this. The form could allow selection from a list, or check boxes, or an arbitrary number of points. The form would call the appropriate macro based upon the input. Whether there are multiple macros or a single macro to do the actual work is irrelevant ... it's just code. Multiple macs makes the coding easier to do.
Wapperdude
Well, decided to re-address this topic...in case someone stumbles across it and wants a solution.
Yes, there probably are a variety of solutions for doing this out there in the all pervading ether. But, I wanted to see how difficult it might be. Not so bad. It's quite repetitive.
Rather than creating a single, all encompassing macro that uses an interface to get the number of points, I took the approach that there would be separate macros for each desired point count. Yep. Pretty lazy. However, there is enough structure in the program, that someone with initiative could convert it...sort of the unified macro of connection point addition.
I'm just adding the code, no sample file...
Sub addCpt8()
'This is for the case of 8 total points to be added to selected shape.
'The macro is hard coded for this specific case. Assumes, that there is
'a specific macro for number of connection points per shape.
'Code is structured using CASE STATEMENTS: one case for each side of shape.
'It also uses WITH STATEMENT for code typing shorthand
Dim vsoRow As Visio.Row
Dim vsoShp As Visio.Shape
Dim intRowIndex As Integer
Dim shpEdge As Integer
Dim i As Integer
Dim j As Integer
Dim numSidePts As Integer
numSidePts = 2 'This is number of connection points per side
If Visio.ActiveWindow.Selection.Count <> 1 Then 'Requires a shape to be selected.
MsgBox "Select a shape, then re-run macro."
Exit Sub
Else
Set vsoShp = ActiveWindow.Selection(1)
End If
For shpEdge = 1 To 4 'Loop thru each edge of shape. Only rectilinear shapes considered.
Select Case shpEdge
Case 1 'Beginning edge is Left rising edge
For i = 0 To numSidePts - 1
intRowIndex = vsoShp.AddRow(visSectionConnectionPts, visRowLast, visTagCnnctPt) 'There is new row for each connection point added
Set vsoRow = vsoShp.Section(visSectionConnectionPts).Row(intRowIndex)
With vsoRow
.Cell(visCnnctX).FormulaU = "Width*0"
If i = 0 Then
.Cell(visCnnctY).FormulaU = "Height*0.25"
Else
.Cell(visCnnctY).FormulaU = "Height*0.75"
End If
.Cell(visCnnctDirX).FormulaU = 1#
.Cell(visCnnctDirY).FormulaU = 0#
.Cell(visCnnctType).FormulaU = visCnnctTypeInward
End With
Next
Case 2 '2nd edge is the top edge
For i = 0 To numSidePts - 1
intRowIndex = vsoShp.AddRow(visSectionConnectionPts, visRowLast, visTagCnnctPt) 'There is new row for each point added
Set vsoRow = vsoShp.Section(visSectionConnectionPts).Row(intRowIndex)
With vsoRow
.Cell(visCnnctY).FormulaU = "Height*1"
If i = 0 Then
.Cell(visCnnctX).FormulaU = "Width*0.25"
Else
.Cell(visCnnctX).FormulaU = "Width*0.75"
End If
.Cell(visCnnctDirX).FormulaU = 1#
.Cell(visCnnctDirY).FormulaU = 0#
.Cell(visCnnctType).FormulaU = visCnnctTypeInward
End With
Next
Case 3 '3rd edge is right, falling edge
For i = 0 To numSidePts - 1
intRowIndex = vsoShp.AddRow(visSectionConnectionPts, visRowLast, visTagCnnctPt) 'There is new row for each point added
Set vsoRow = vsoShp.Section(visSectionConnectionPts).Row(intRowIndex)
With vsoRow
.Cell(visCnnctX).FormulaU = "Width*1"
If i = 0 Then
.Cell(visCnnctY).FormulaU = "Height*0.75" 'Note, order is reversed, so the points remain sequentally placed
Else
.Cell(visCnnctY).FormulaU = "Height*0.25"
End If
.Cell(visCnnctDirX).FormulaU = 1#
.Cell(visCnnctDirY).FormulaU = 0#
.Cell(visCnnctType).FormulaU = visCnnctTypeInward
End With
Next
Case 4 '4th edge is the bottom edge
For i = 0 To numSidePts - 1
intRowIndex = vsoShp.AddRow(visSectionConnectionPts, visRowLast, visTagCnnctPt) 'There is new row for each point added
Set vsoRow = vsoShp.Section(visSectionConnectionPts).Row(intRowIndex)
With vsoRow
.Cell(visCnnctY).FormulaU = "Height*0"
If i = 0 Then
.Cell(visCnnctX).FormulaU = "Width*0.75"
Else
.Cell(visCnnctX).FormulaU = "Width*0.25"
End If
.Cell(visCnnctDirX).FormulaU = 1#
.Cell(visCnnctDirY).FormulaU = 0#
.Cell(visCnnctType).FormulaU = visCnnctTypeInward
End With
Next
End Select
Next
End Sub
Enjoy!
Wapperdude
Hello,
I decided to reply this topic because the program works only with shapes with 4 sides. How can you to do this with a triangle or a circle ?
Quote from: Miguel on March 29, 2017, 08:59:47 AMHow can you to do this with a triangle or a circle ?
it need new code !
that utility (https://yadi.sk/d/qbpj9WI9d2eqF) can place points on circles
(http://forumimage.ru/uploads/20151215/145021495232266829.png)
but it have only russian interface ::)
read more: Mass placement of connection points on shapes (https://translate.google.ru/translate?sl=ru&tl=en&js=y&prev=_t&hl=ru&ie=UTF-8&u=http%3A%2F%2Fvisio.getbb.ru%2Fviewtopic.php%3Ff%3D15%26t%3D853&edit-text=&act=url)
QuoteI decided to reply this topic because the program works only with shapes with 4 sides. How can you to do this with a triangle or a circle ?
I am in the process of updating the code, but, it will take some time. The goal will be to allow any (within reason) number of sides for a recti-linear shape, from 1 to some number..., and will do circles, but no ovals and no non-linear row types. Initial release may be only 1 to 4 sides.
It will have a more user friendly interface.
Wapperdude
Quote from: wapperdude on March 30, 2017, 05:51:34 AMI am in the process of updating the code, but, it will take some time. The goal will be to allow any (within reason) number of sides for a recti-linear shape, from 1 to some number..., and will do circles, but no ovals and no non-linear row types. Initial release may be only 1 to 4 sides.
It will have a more user friendly interface.
Ok, it's perfect. I will show patience! Thank you ;D ;D