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
Related
I've written some code that formats text. The code doesn't work if user has put the cursor in a shape that is part of a group of shapes, the solution for which is to ungroup the shapes.
I want to regroup the shapes after executing the formatting code.
I am able to store the underlying shapes as objects, as well as their names. But, the normal approach to grouping (using shape names) doesn't work, because there can be multiple instances of those shape names on a given slide. E.g. this doesn't work as there could be multiple instances of "textbox" on the slide:
Set TempShapeGroup = TempSlide.Shapes.Range(Array("textbox", "header", "separator")).Group
https://learn.microsoft.com/en-us/office/vba/api/powerpoint.shaperange.group
But, I have the shape objects stored in an array, the crux of which is this (the object 'TempShape' is the group of shapes):
Dim ShapesArray() As Shape
ReDim ShapesArray(1 To TempShape.GroupItems.Count)
For i = 1 To TempShape.GroupItems.Count
Set ShapesArray(i) = TempShape.GroupItems.Item(i)
Next i
So, what I want to do is recreate the group of shapes, using the array of shape objects, so something to the effect of the below would be ideal:
Set MyShapesGroup= ShapesArray.Group
But any way to group shapes using Shape objects would be fine.
TIA
Here's some starter code that you can modify into a function that'll return a reference to the paragraph that contains the current selection cursor. It doesn't really need all the debug.print stuff, of course, but that might help to illustrate the object hierarchy:
Sub WhereIsTheCursor()
Dim oRng As TextRange
Dim oParentRange As TextRange
Dim x As Long
Dim lSelStart As Long
Dim lSelLen As Long
With ActiveWindow.Selection.TextRange
' find the selection start relative to first character in shape
lSelStart = .Start
' lSelLen = .Length
Debug.Print TypeName(.Parent)
Debug.Print TypeName(.Parent.Parent)
Debug.Print TypeName(.Parent.Parent.Parent)
Debug.Print .Paragraphs.Count
Set oRng = .Characters(.Start, .Length)
Debug.Print oRng.Text
' Reference the overall shape's textrange
Set oParentRange = .Parent.Parent.TextFrame.TextRange
' For each paragraph in the range ...
For x = 1 To oParentRange.Paragraphs.Count
' is the start of the selection > the start of the paragraph?
If lSelStart > oParentRange.Paragraphs(x).Start Then
' is the start < the start + length of the paragraph?
If lSelStart < oParentRange.Paragraphs(x).Start _
+ oParentRange.Paragraphs(x).Length Then
' bingo!
MsgBox "The cursor is in paragraph " & CStr(x)
End If
End If
Next
End With
End Sub
Not sure I'm completely understanding the problem, but this may help:
If the user has selected text within a shape, it doesn't really matter whether the shape is part of a group or not. You may need to test the .Selection.Type and handle things differently depending on whether the .Type is text or shaperange. Example:
Sub FormatCurrentText()
If ActiveWindow.Selection.Type = ppSelectionText Then
With ActiveWindow.Selection.TextRange
.Font.Name = "Algerian"
End With
End If
End Sub
I would like to simplify updating my orgcharts in Visio. So far I have a macro borrowed from here https://bvisual.net/2010/01/28/applying-selected-datagraphic-to-the-whole-document/ and written out below. I would like to adapt it to make some changes to the format of the text withing shapes e.g. to make the font bold and potentially to change it's colour. I'm finding it really difficult to find examples of this online so any help/suggestion would be greatly appreciated.
Public Sub ApplyDataGraphicToDocument()
Dim mstDG As Visio.Master
Dim shp As Visio.Shape
Dim pag As Visio.Page
Dim firstProp As String
If Visio.ActiveWindow.Selection.Count = 0 Then
MsgBox "Please select a shape which already has data graphics"
Exit Sub
Else
Set shp = Visio.ActiveWindow.Selection.PrimaryItem
If shp.DataGraphic Is Nothing Then
MsgBox "Please select a shape which already has data graphics"
Exit Sub
Else
'Get the shapes DataGraphic master
Set mstDG = shp.DataGraphic
'Get the name of the first Shape Data row
firstProp = "Prop." & _
shp.CellsSRC(Visio.visSectionProp, 0, 0).RowNameU
End If
End If
For Each pag In Visio.ActiveDocument.Pages
If pag.Type = visTypeForeground Then
For Each shp In pag.Shapes
'Check that the named Shape Data row exists
If shp.CellExistsU(firstProp, Visio.visExistsAnywhere) Then
'Set the DataGraphic
shp.DataGraphic = mstDG
End If
Next
End If
Next
End Sub
You can modify the default OrgChart shapes, although it is not officially supported. To change the default shapes (make their font bold), you'll need to edit the templates (masters) for those OrgChart shapes. In the same blog you can find more information on customizing the OrgChart diagrams, here: https://bvisual.net/2012/05/08/creating-a-custom-org-chart-template-with-extra-properties
The procedure is mostly the same, just instead of adding the properties, you make the text bold.
I would like to set font type (calibri)of text( where ever there is an alphabet in presentation, it should be "calibri") in every slide by running the single macro using VBA. The problem is, it is unable to change the font present in 'chart', 'flow chart diagram' where it has boxes like rectangle, round cornered rectangles etc.How to manipulate that text as well? Please help!
As shown in the image the font of climate in rectangle is not changing.Different font type in rectangle
The solution to this problem is pretty tedious as there are so many different types of shapes and textranges to account for. I can't post my entire solution as I don't own the intellectual property, but this should get you on the right track:
Sub MakeFontsThemeFonts()
Dim oSld As Slide
Dim oShp As Shape
Dim oShp2 As Shape
Dim oTxtRange As TextRange
' Set majorFont and minorFont to Calibri
ActivePresentation.SlideMaster.Theme.ThemeFontScheme.majorFont.Item(1) = "Calibri"
ActivePresentation.SlideMaster.Theme.ThemeFontScheme.minorFont.Item(1) = "Calibri"
For Each oSld in ActivePresentation.Slides
For Each oShp in oSld.Shapes
If oShp.HasChart Then
' Call your chart handler
ElseIf oShp.HasTable Then
' Call your table handler
ElseIf oShp.HasSmartArt Then
' Call your SmartArt handler
ElseIf oShp.HasTextFrame Then
If oShp.HasText Then
Set oTxtRange = oShp.TextFrame.TextRange
Call RefontTextRange (oTxtRange)
End If
ElseIf oShp.Type = msoGroup Then
For Each oShp2 in oShp.GroupItems
If oShp2.Type = ... Then
' And so on, you wind up having to check for
' everything that's grouped all over again
End If
Next
End If
Next
Next
End Sub
Sub RefontTextRange (oTxtRange As TextRange)
With oTxtRange.Font
' Sets the textrange to the body font. If you want to make some stuff the heading font and some stuff the body font, you need to do more checking before sending here
.Name = "+mn-lt"
End With
End Sub
So that's the start of the solution, but this will get maddening for a few reasons. For tables, you'll have to parse the TextRange of every cell individually and pass those TextRanges on to your Refont sub. For charts, you may have to check for every imaginable chart element before setting your TextRange and refonting (my case was more complex than just setting the font to be the theme font, and I didn't have success trying to format the ChartArea all at once).
Are you having the issue with "floating" shapes inside of a chart? When you say "flow chart," is that an embedded Visio diagram or native SmartArt? There are many ways to skin this cat, but the solution will require you to identify every possible type of text container that can be accessed using VBA.
Here's one more tip that might help you get at those floating shapes within charts:
oShp.Chart.Shapes(1).TextFrame.TextRange.Font.Name = "+mn-lt"
But of course first you need to make sure you've got a chart, that it's got shapes in it, that those shapes have a textframe...
If you leverage the features already built in to PowerPoint, you won't need any code at all. The font theme is built to handle these situations. Format all text with font choices that include the (body) or (headings) tag in the name. Then when you switch the font theme from Arial to Calibri, all text, including charts and SmartArt, will be updated.
For a presentation that is already formatted with local formatting instead of using a font theme, unzipping the file to XML and using a good text editor's Find and Replace functions, you can quickly replace all instances of a font without programming.
Find 'typeface="Arial"'
Replace 'typeface="Calibri"'
Then rezip the files and restore the file ending.
It seems you only need to change the master slides (including notesmaster, slidemaster), instead of working on each slide. Here are my codes
Sub ChangeFont()
' https://stackoverflow.com/a/57212464/2292993
' affect SmartArt font
ActivePresentation.SlideMaster.Theme.ThemeFontScheme.majorFont.Item(1) = "Garamond"
ActivePresentation.SlideMaster.Theme.ThemeFontScheme.minorFont.Item(1) = "Garamond"
For i = 1 To Application.ActivePresentation.NotesMaster.Shapes.Count
With Application.ActivePresentation.NotesMaster.Shapes(i).TextFrame.TextRange.Font
.Name = "Garamond"
If Application.ActivePresentation.NotesMaster.Shapes(i).Name Like "Notes*" Then
.Bold = msoFalse
.Size = 16
End If
End With
Next i
' http://skp.mvps.org/2007/ppt003.htm
' Each design contained a slide master and possibly a title master. Several designs could be stored within a presentation.
' The slide master can contain several custom layouts which can be fully customized.
For Each oDesign In ActivePresentation.Designs
' slide master
Set sm = oDesign.SlideMaster
For j = 1 To sm.Shapes.Count
If sm.Shapes(j).HasTextFrame Then
With sm.Shapes(j).TextFrame.TextRange.Font
.Name = "Garamond"
End With
End If
Next j
' custom layouts
lngLayoutCount = oDesign.SlideMaster.CustomLayouts.Count
For I = 1 To lngLayoutCount
Set oCL = oDesign.SlideMaster.CustomLayouts(I)
For j = 1 To oCL.Shapes.Count
If oCL.Shapes(j).HasTextFrame Then
With oCL.Shapes(j).TextFrame.TextRange.Font
.Name = "Garamond"
End With
End If
Next j
Next I
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
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"