Hey Everyone!
Here is a macro that I have been working on for formatting connectors. It has taken me some time to get this to where it functions for me consistently. I am open to suggestions or if you use it and make changes to address issues, please let me know.
I hope this helps someone out there, so they don't have to go through all that I have.
Sub ModifyTextAlongPath()
Dim i As Integer
Dim CurrentSelection As Selection
Dim CurrentShape As Shape
Dim TestInt As Variant
Dim PerInt As String
Dim Vlaidate As Boolean
Dim Success As String
Dim Error As String
Dim StrSwapEnds As String
Dim BolA As Boolean
'Set CurrentSelection to Items Selected on Page
Set CurrentSelection = Application.ActiveWindow.Selection
'Loop through each item selected
For i = 1 To CurrentSelection.Count
'If current item is a shape then set text block information to center text
If TypeOf CurrentSelection.Item(i) Is Shape Then
Set CurrentShape = CurrentSelection.Item(i)
'Change text font to 6pts
CurrentShape.Cells("Char.Size").FormulaForce = "6 pt"
TestInt = CurrentShape.Cells("TxtPinX").Formula
'If a referance is set Then
If TestInt Like "SETATREF*" Then
'Get the value betwen ( )
TestInt = Mid(TestInt, InStr(TestInt, "(") + 1, InStr(TestInt, ")") - InStr(TestInt, "(") - 1)
'Get the value of the Referanced cell
TestInt = CurrentShape.Cells(TestInt).Formula
'If the value is not a Path attribute, then move on
If TestInt Like "*Path,*" Then
'Find the value that has been set for the Path
TestInt = Mid(TestInt, InStr(TestInt, "Path,") + 5, InStr(TestInt, ")") - InStr(TestInt, "Path,") - 5)
'Format number as percent
Else
TestInt = "No value set"
End If
'If there is not Referacne set
Else
'If the value is not a Path attribute, then move on
If TestInt Like "*Path,*" Then
'Find the value that has been set for the Path
TestInt = Mid(TestInt, InStr(TestInt, "Path,") + 5, InStr(TestInt, ")") - InStr(TestInt, "Path,") - 5)
Else
TestInt = "No value set"
End If
End If
Do
'Prompt for location information
Do
TestInt = InputBox("Where does the text need to be placed?" _
& Chr(13) & Chr(10) & "Example: 1 = 1%, 45 = 45 %, 100 = 100%" & Chr(13) & Chr(10) & "Last Input = " & TestInt, "Percentage")
'If the the number is abover 1 then send them back to the question
Select Case TestInt
Case ""
Exit Sub
Case Is <= 100
Validate = True
TestInt = TestInt & "%"
Case Else
Vlaidate = False
Error = MsgBox("The value that you entered is not between 0 and 100." _
& Chr(13) & Chr(10) & "Please correct your last entry.", vbCritical, "Error")
End Select
Loop While Validate = False
'Check to see if controls section exists. If not create it. If so, move on.
If CurrentShape.SectionExists(visSectionControls, False) = False Then
CurrentShape.AddSection (visSectionControls)
'Add a control with name TextPosition
CurrentShape.AddRow visSectionControls, visRowLast, visTagDefault
CurrentShape.CellsSRC(visSectionControls, 0, visCnnctX).RowName = "TextPosition"
End If
'Apply changes
CurrentShape.Cells("TxtPinX").FormulaForce = "SETATREF(Controls.TextPosition)"
CurrentShape.Cells("Controls.TextPosition").FormulaForce = "GUARD(POINTALONGPATH(Geometry1.Path, " & TestInt & "))"
CurrentShape.Cells("TxtPinY").FormulaForce = "SETATREF(Controls.TextPosition.Y)"
CurrentShape.Cells("Controls.TextPosition.Y").FormulaForce = "GUARD(POINTALONGPATH(Geometry1.Path, " & TestInt & "))"
CurrentShape.Cells("TxtAngle").FormulaForce = "GUARD(ANGLEALONGPATH(Geometry1.Path, " & TestInt & "))"
'Ask if the changes were successful
Success = MsgBox("Did this solve your problem", vbQuestion + vbYesNo, "???")
'If the change was not successful and there was no prompt for SwapEnds
If Success = vbNo And BolA <> True Then
'Do you want to swap the line ends
StrSwapEnds = MsgBox("Do the ends of the line need to be swapped?", vbQuestion + vbYesNo, "???")
'Set to true to avoid going trough prompt again.
BolA = True
'If answer yes to SwapEnds prompt
If StrSwapEnds = vbYes Then
'Swap the ends of the current selection
CurrentSelection.SwapEnds
End If
End If
Loop While Success = vbNo
End If
Next i
End Sub
So, I made a few modifications to the code to allow for appropriate formatting when dealing with right-angle lines. For what ever reason Visio flips the text 180 at some points on a right angle routed line. I may build another component into this code to ask you if you want to flip the line only once and never ask again.
Here ya go. I hope it helps someone.
Sub ModifyTextAlongPath()
Dim i As Integer
Dim CurrentSelection As Selection
Dim CurrentShape As Shape
Dim TestInt As Variant
Dim PerInt As String
Dim Vlaidate As Boolean
Dim Success As String
Dim Error As String
Dim StrSwapEnds As String
Dim BolA As Boolean
Dim dblPI As Double
Dim dblTxtAngle As Double
Dim intPageRouteStyle As Integer
Dim intRouteStyle As Integer
'Set CurrentSelection to Items Selected on Page
Set CurrentSelection = Application.ActiveWindow.Selection
'Loop through each item selected
For i = 1 To CurrentSelection.Count
'If current item is a shape then set text block information to center text
If TypeOf CurrentSelection.Item(i) Is Shape Then
Set CurrentShape = CurrentSelection.Item(i)
'Change text font to 6pts
CurrentShape.Cells("Char.Size").FormulaForce = "6 pt"
TestInt = CurrentShape.Cells("TxtPinX").Formula
'If a referance is set Then
If TestInt Like "SETATREF*" Then
'Get the value betwen ( )
TestInt = Mid(TestInt, InStr(TestInt, "(") + 1, InStr(TestInt, ")") - InStr(TestInt, "(") - 1)
'Get the value of the Referanced cell
TestInt = CurrentShape.Cells(TestInt).Formula
'If the value is not a Path attribute, then move on
If TestInt Like "*Path,*" Then
'Find the value that has been set for the Path
TestInt = Mid(TestInt, InStr(TestInt, "Path,") + 5, InStr(TestInt, ")") - InStr(TestInt, "Path,") - 5)
'Format number as percent
Else
TestInt = "No value set"
End If
'If there is not Referacne set
Else
'If the value is not a Path attribute, then move on
If TestInt Like "*Path,*" Then
'Find the value that has been set for the Path
TestInt = Mid(TestInt, InStr(TestInt, "Path,") + 5, InStr(TestInt, ")") - InStr(TestInt, "Path,") - 5)
Else
TestInt = "No value set"
End If
End If
Do
'Prompt for location information
Do
TestInt = InputBox("Where does the text need to be placed?" _
& Chr(13) & Chr(10) & "Example: 1 = 1%, 45 = 45 %, 100 = 100%" & Chr(13) & Chr(10) & "Last Input = " & TestInt, "Percentage")
'If the the number is abover 1 then send them back to the question
Select Case TestInt
Case ""
Exit Sub
Case Is <= 100
Validate = True
TestInt = TestInt & "%"
Case Else
Vlaidate = False
Error = MsgBox("The value that you entered is not between 0 and 100." _
& Chr(13) & Chr(10) & "Please correct your last entry.", vbCritical, "Error")
End Select
Loop While Validate = False
'Check to see if controls section exists. If not create it. If so, move on.
If CurrentShape.SectionExists(visSectionControls, False) = False Then
CurrentShape.AddSection (visSectionControls)
'Add a control with name TextPosition
CurrentShape.AddRow visSectionControls, visRowLast, visTagDefault
CurrentShape.CellsSRC(visSectionControls, 0, visCnnctX).RowName = "TextPosition"
End If
'Apply changes
CurrentShape.Cells("TxtPinX").FormulaForce = "SETATREF(Controls.TextPosition)"
CurrentShape.Cells("Controls.TextPosition").FormulaForce = "GUARD(POINTALONGPATH(Geometry1.Path, " & TestInt & "))"
CurrentShape.Cells("TxtPinY").FormulaForce = "SETATREF(Controls.TextPosition.Y)"
CurrentShape.Cells("Controls.TextPosition.Y").FormulaForce = "GUARD(POINTALONGPATH(Geometry1.Path, " & TestInt & "))"
CurrentShape.Cells("TxtAngle").FormulaForce = "GUARD(ANGLEALONGPATH(Geometry1.Path, " & TestInt & "))"
'Get the radian value of the TxtAngle
dblTxtAngle = CurrentShape.Cells("TxtAngle")
'Set variable to PI
dblPI = 4 * Atn(1)
'Get the value of the Defualt Page RouteStyle
intPageRouteStyle = Application.ActivePage.PageSheet.Cells("RouteStyle")
'Get the value of the shapes Routing Style
intRouteStyle = CurrentShape.Cells("ShapeRouteStyle")
'If the page routing style is Right Angle and the Shape is set to defualt routing or Shape Route Style is Right Angle Then
If intPageRouteStyle = 1 And intRouteStyle = 0 Or intRouteStyle = 1 Then
'If TxtAngle is PI Then
If dblTxtAngle = dblPI Then
'Change the formula to set radian to 0 degrees
CurrentShape.Cells("TxtAngle").FormulaForce = "GUARD(ANGLEALONGPATH(Geometry1.Path, " & TestInt & ")*0)"
End If
End If
dblTxtAngle = CurrentShape.Cells("TxtAngle")
'Ask if the changes were successful
Success = MsgBox("Did this solve your problem", vbQuestion + vbYesNo, "???")
'If the change was not successful and there was no prompt for SwapEnds
If Success = vbNo And BolA <> True Then
'Do you want to swap the line ends
StrSwapEnds = MsgBox("Do the ends of the line need to be swapped?", vbQuestion + vbYesNo, "???")
'Set to true to avoid going trough prompt again.
BolA = True
'If answer yes to SwapEnds prompt
If StrSwapEnds = vbYes Then
'Swap the ends of the current selection
CurrentSelection.SwapEnds
End If
End If
Loop While Success = vbNo
End If
Next i
End Sub
slight improvement but rather than looping through all selected items, and checking if the item is a shape, you could use 'Eor Each' to loop through the selected shapes
Sub ModifyTextAlongPath()
Dim i As Integer
Dim CurrentSelection As Selection
Dim CurrentShape As Shape
Dim TestInt As Variant
Dim PerInt As String
Dim Vlaidate As Boolean
Dim Success As String
Dim Error As String
Dim StrSwapEnds As String
Dim BolA As Boolean
'Set CurrentSelection to Items Selected on Page
Set CurrentSelection = Application.ActiveWindow.Selection
'Loop through each shape selected
For Each CurrentShape In CurrentSelection
'Change text font to 6pts
CurrentShape.Cells("Char.Size").FormulaForce = "6 pt"
TestInt = CurrentShape.Cells("TxtPinX").Formula
'If a referance is set Then
If TestInt Like "SETATREF*" Then
'Get the value betwen ( )
TestInt = Mid(TestInt, InStr(TestInt, "(") + 1, InStr(TestInt, ")") - InStr(TestInt, "(") - 1)
'Get the value of the Referanced cell
TestInt = CurrentShape.Cells(TestInt).Formula
'If the value is not a Path attribute, then move on
If TestInt Like "*Path,*" Then
'Find the value that has been set for the Path
TestInt = Mid(TestInt, InStr(TestInt, "Path,") + 5, InStr(TestInt, ")") - InStr(TestInt, "Path,") - 5)
'Format number as percent
Else
TestInt = "No value set"
End If
'If there is not Referacne set
Else
'If the value is not a Path attribute, then move on
If TestInt Like "*Path,*" Then
'Find the value that has been set for the Path
TestInt = Mid(TestInt, InStr(TestInt, "Path,") + 5, InStr(TestInt, ")") - InStr(TestInt, "Path,") - 5)
Else
TestInt = "No value set"
End If
End If
Do
'Prompt for location information
Do
TestInt = InputBox("Where does the text need to be placed?" _
& Chr(13) & Chr(10) & "Example: 1 = 1%, 45 = 45 %, 100 = 100%" & Chr(13) & Chr(10) & "Last Input = " & TestInt, "Percentage")
'If the the number is abover 1 then send them back to the question
Select Case TestInt
Case ""
Exit Sub
Case Is <= 100
Validate = True
TestInt = TestInt & "%"
Case Else
Vlaidate = False
Error = MsgBox("The value that you entered is not between 0 and 100." _
& Chr(13) & Chr(10) & "Please correct your last entry.", vbCritical, "Error")
End Select
Loop While Validate = False
'Check to see if controls section exists. If not create it. If so, move on.
If CurrentShape.SectionExists(visSectionControls, False) = False Then
CurrentShape.AddSection (visSectionControls)
'Add a control with name TextPosition
CurrentShape.AddRow visSectionControls, visRowLast, visTagDefault
CurrentShape.CellsSRC(visSectionControls, 0, visCnnctX).rowName = "TextPosition"
End If
'Apply changes
CurrentShape.Cells("TxtPinX").FormulaForce = "SETATREF(Controls.TextPosition)"
CurrentShape.Cells("Controls.TextPosition").FormulaForce = "GUARD(POINTALONGPATH(Geometry1.Path, " & TestInt & "))"
CurrentShape.Cells("TxtPinY").FormulaForce = "SETATREF(Controls.TextPosition.Y)"
CurrentShape.Cells("Controls.TextPosition.Y").FormulaForce = "GUARD(POINTALONGPATH(Geometry1.Path, " & TestInt & "))"
CurrentShape.Cells("TxtAngle").FormulaForce = "GUARD(ANGLEALONGPATH(Geometry1.Path, " & TestInt & "))"
'Ask if the changes were successful
Success = MsgBox("Did this solve your problem", vbQuestion + vbYesNo, "???")
'If the change was not successful and there was no prompt for SwapEnds
If Success = vbNo And BolA <> True Then
'Do you want to swap the line ends
StrSwapEnds = MsgBox("Do the ends of the line need to be swapped?", vbQuestion + vbYesNo, "???")
'Set to true to avoid going trough prompt again.
BolA = True
'If answer yes to SwapEnds prompt
If StrSwapEnds = vbYes Then
'Swap the ends of the current selection
CurrentSelection.SwapEnds
End If
End If
Loop While Success = vbNo
Next CurrentShape
End Sub