Is there a way to edit connections through VBA?
For example, change the line weight of a connector when running a VBA script.
Sub Macro1()
Dim shp As Shape, mst As Master
' iterate all shapes per page
For Each shp In ActivePage.Shapes
' declare parent master for current shape
Set mst = shp.Master
' Process only shapes that have parent master-shape
If Not (mst Is Nothing) Then
' change only shapes, which master-shape is dynamic connector
If mst.Name = "Dynamic connector" Then shp.Cells("LineWeight").Formula = "0.5 pt"
End If
Next
End Sub
This code set Line Weight of each connector on page to 0.5 pt
This code changed Line Weight of selected shape
Set shp = ActiveWindow.Selection.PrimaryItem
shp.Cells("LineWeight").Formula = "0.5 pt"
Related
I need to iterate through all dynamic connectors on a visio document and change the colour of the connector line based on the dynamic connector text label - The code is based off a previous question to change line width of dynamic connectors.
I cant find a box defining the text label
Sub Macro1()
Dim shp As Shape, mst As Master
' iterate all shapes per page
For Each shp In ActivePage.Shapes
' declare parent master for current shape
Set mst = shp.Master
' Process only shapes that have parent master-shape
If Not (mst Is Nothing) Then
' change only shapes, which master-shape is dynamic connector
If mst.Name = "Dynamic connector" Then
' Now i dont know how to proceed - forgive me i am new to coding - i know the syntax is wrong, im just trying to give somthing to go off
If shp.Text = "A" Then shp.Cells("LineColour").Formula = RGB(255,255,0))
Else If shp.Text = "G" Then shp.Cells("LineColour").Formula = RGB(0,255,0))
Else If shp.Text = "R" Then shp.Cells("LineColour").Formula = RGB(255,0,0))
End If
End
But shape text does not appear to be a property - even though the connector defiantly has text, and properties of this text such as font do appear.
Any help would be great - cheers
Maybe:
ActivePage.Shapes(shp.Name).TextFrame.Characters.Text = "Hello World!"
'or
shp.TextFrame.Characters.Text = "Hello World!"
' This macro works in Excel
Sub Macro1()
Dim shp As Shape
Me.Shapes.AddShape msoShapeLeftArrow, 200, 200, 10, 10
For Each shp In Me.Shapes
shp.TextFrame.Characters.Text = "A"
Debug.Print shp.name, shp.TextFrame.Characters.Text
Next
End Sub
After selecting a shape (f.e. square or more squares) all the connectors glued to this shape would highlight red, yellow whatever.
The found code below is not working for me, any advice? (I am not coder, so please have patience with me)
Set shpAtEnd = cnx(1).ToSheet
' use HitTest to determine whether Begin end of connector
' is outside shpAtEnd
x = shpAtEnd.HitTest(shpTaskLink.Cells("BeginX"), _
shpTaskLink.Cells("BeginY"), 0.01)
If x = visHitOutside Then
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 2
Else
' do other stuff
End If
This is my first answer on stackoverflow and I hope the following VBA code can solve your problem on how to highlight connectors or connected shapes in Visio!
Public Sub HighlightConnectedShapes()
Dim vsoShape As Visio.Shape
Dim connectedShapeIDs() As Long
Dim connectorIDs() As Long
Dim intCount As Integer
' Highlight the selected shape
Set vsoShape = ActiveWindow.Selection(1)
vsoShape.CellsU("Fillforegnd").FormulaU = "RGB(146, 212, 0)"
vsoShape.Cells("LineColor").FormulaU = "RGB(168,0,0)"
vsoShape.Cells("LineWeight").Formula = "2.5 pt"
' Highlight connectors from/to the selected shape
connectorIDs = vsoShape.GluedShapes _
(visGluedShapesAll1D, "")
For intCount = 0 To UBound(connectorIDs)
ActivePage.Shapes.ItemFromID(connectorIDs(intCount)).Cells("LineColor").FormulaU = "RGB(168,0,0)"
ActivePage.Shapes.ItemFromID(connectorIDs(intCount)).Cells("LineWeight").Formula = "2.5 pt"
Next
' Highlight shapes that are connected to the selected shape
connectedShapeIDs = vsoShape.connectedShapes(visConnectedShapesAllNodes, "")
For intCount = 0 To UBound(connectedShapeIDs)
ActivePage.Shapes.ItemFromID(connectedShapeIDs(intCount)).Cells("LineColor").FormulaU = "RGB(168,0,0)"
ActivePage.Shapes.ItemFromID(connectedShapeIDs(intCount)).Cells("LineWeight").Formula = "2.5 pt"
Next
End Sub
To run the macro, you can consider associating with double-click behavior of shapes.
If you only need to highlight incoming/outgoing connectors and incoming/outgoing shapes, replace visGluedShapesAll1D with visGluedShapesIncoming1D/visGluedShapesOutgoing1D and visConnectedShapesAllNodes with visConnectedShapesIncomingNodes/visConnectedShapesOutgoingNodes.
Learn more at visgluedshapesflags and visconnectedshapesflags. Good luck!
The following code will loop though all 1d-Shapes glued to the first shape in your Selection and write their name to the Immediate window. This should be a good starting point.
Visio has no Event that fires if a Shape is selected (at least not without some workarounds), so maybe bind the macro to a keybind.
The visGluedShapesAll1D flag can be replace with another filter as described here: Microsoft Office Reference
Sub colorConnectors()
If ActiveWindow.Selection(1) Is Nothing Then Exit Sub
Dim selectedShape As Shape
Set selectedShape = ActiveWindow.Selection(1)
Dim pg As Page
Set pg = ActivePage
Dim gluedConnectorID As Variant 'variant is needed because of "For Each" Loop
For Each gluedConnectorID In selectedShape.GluedShapes(visGluedShapesAll1D, "")
Debug.Print pg.Shapes.ItemFromID(gluedConnectorID).NameU
Next gluedConnectorID
End Sub
I'm trying to optimise my macro which allow me to ungroup all the shapes that are located in that active Page and if those shapes are already Ungrouped this macro will Group them
What I want to do is to modify this code to allow to group and Ungroup all in the Active page only not all te document . I'm a little noobi with VBA
this is my code
Private Sub degroupage_Click()
Dim mydocument As Document
Set mydocument = ActiveDocument
On Error Resume Next
ActiveDocument.Unprotect 'enregistré manuellement
Dim S As Shape, t As Shape
For i = 0 To mydocument.Shapes.Item(1).GroupItems.Count
For Each S In mydocument.Shapes
If S.Type = msoGroup Then S.Ungroup 'Ungrouping all shapes in all the document :(
If S.Selection.Ungroup = True Then
ActiveDocument.Selection.ShapeRange.Regroup ' Problem here
Next
Next
End Sub
I need a quick help
the error is methode unfound for the Regroup and S.Selection.Ungoup
I'm trying to create a macro to change the thickness of connectors that are connected to a specific block. This is what I have so far:
Private Sub HighlightPaths_Click()
Dim selection As Shape
Dim connections() As Long
Dim i As Integer
'Msgbox glued shapes
If ActiveWindow.selection.Count = 0 Then
MsgBox ("Select a shape then click this button.")
Else
'Set shape to current selection
Set selection = ActiveWindow.selection(1)
'Get array of connectors on selected object
connections() = selection.GluedShapes(visGluedShapesAll1D, "")
'Resize connectors to that shape [ERROR HERE]
For i = 0 To UBound(connections())
connections(i).Cells("LineWeight").Formula = "0.5 pt"
Next
End If
End Sub
I know this comes from the fact that I'm trying to access the Cells property in a type that is not applicable. Do I have to search for the returns of the Glue method in the list of master shapes to find the dynamic connector master shapes?
Array connections(), contains connected shapes IDs.
You need get shape object, before change it Line Weight.
ActivePage.Shapes(connections(i)).Cells("LineWeight").Formula = "0.5 pt"
I work from excel, and i open several powerpoint in a loop inside a directory, in vba.
While i run the macro (from excel), I make a loop within every shape inside every slides in powerpoints presentation.
I stop the macro to see if AutoShapeType = -2, and i select it in vba just to check visualy if the shape is the right shape i want.
Otherwise, if the selected shape doesn't seems right, I select it manually and I want to know how the syntaxe to get the id of the current selected shape, in order to name it.
Set PPtapp = CreateObject("Powerpoint.Application")
PPtapp.Visible = True
Dim sld As Slide
Dim numslide As Long
Dim nbslide As Long
Dim WVL_CptShape As Integer
'list of every powerpoint path
ppt = ThisWorkbook.Worksheets("Template").Range("A" & i).Value
For i = 2 To ThisWorkbook.Worksheets("Template").Range("A65536").End(xlUp).Row + 1
Set PptDoc = PPtapp.Presentations.Open(ppt)
With PptDoc
For Each sld In PptDoc.Slides
For WVL_CptShape = 1 To .Slides(sld.SlideNumber).Shapes.Count
WVL_Id = .Slides(sld.SlideNumber).Shapes(WVL_CptShape).ID
If PptDoc.Slides(sld.SlideNumber).Shapes(WVL_CptShape).AutoShapeType = -2 Then
'I select the shape to see visualy if it's a good selection and I stop the macro
PptDoc.Slides(sld.SlideNumber).Shapes(WVL_CptShape).Select
Stop
'if the selection doesnt seems right I select the right shape manualy
'Question : in vba, i want to change the name of the selected shape.
'But i don't know how to get the id of the current selected shape (see below : ID_OF_CURRENT_SHAPE_SELECTED_MANUALY)
'I would like to rename it, in order to recognize it easily next time
PptDoc.Slides(sld.SlideNumber). Shapes(ID_OF_CURRENT_SHAPE_SELECTED_MANUALY).Selection.Name = "Myshape"
end if
Next WVL_CptShapeNext
sld.Close
End With
Next
PPtapp.Quit
Set PPtapp = Nothing
Set PptDoc = PPtapp.Presentations.Open(ppt)
With PptDoc
For Each sld In PptDoc.Slides
For WVL_CptShape = 1 To sld.Shapes.Count
WVL_Id = sld.Shapes(WVL_CptShape).ID
If sld.Shapes(WVL_CptShape).AutoShapeType = -2 Then
'I select the shape to see visualy if it's a good selection and I stop the macro
sld.Shapes(WVL_CptShape).Select
Stop
' And to change the name of the shape:
sld.Shapes(WVL_CptShape).Name = "New name for shape"
' or better, in case you selected a different shape:
ActiveWindow.Selection.ShapeRange(1).Name = "New name for shape"
In this type of situation, you want to work with the shape's Index, not its ID.
Note that you can iterate through the shapes collection on a slide just as you can iterate through the slides collection in a presentation. It makes the code a lot simpler to write and to follow:
Set PptDoc = PPtapp.Presentations.Open(ppt)
With PptDoc
For Each sld In PptDoc.Slides
For each shp in sld.shapes
If shp.AutoShapeType = -2 Then
'I select the shape to see visualy if it's a good selection and I stop the macro
shp.Select
Stop