Author Topic: Macro to Format Connectors the way I like them  (Read 1340 times)

0 Members and 1 Guest are viewing this topic.

safewithyou247

  • Newbie
  • *
  • Posts: 5
Macro to Format Connectors the way I like them
« on: December 21, 2016, 01:19:51 PM »
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.

Code: [Select]
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

safewithyou247

  • Newbie
  • *
  • Posts: 5
Re: Macro to Format Connectors the way I like them
« Reply #1 on: January 09, 2017, 10:09:10 AM »
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.

Code: [Select]
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

MacGyver

  • Full Member
  • ***
  • Posts: 85
Re: Macro to Format Connectors the way I like them
« Reply #2 on: January 19, 2017, 01:20:52 PM »
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

Code: [Select]
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