I am trying to assign a merged shape to a new layer. I have tried to assign the initial shape but it didn't work. This is part of my coding so far.
Dim vsoLayer As Visio.Layer
Dim vsoLayers As Visio.Layers
Set vsoLayers = ActivePage.Layers
Set vsoLayer = vsoLayers.Add("Layer1")
Dim vsoShapeA1 As Visio.shape
Set vsoShapeA1 = ActivePage.DrawRectangle(1, 5, 5, 1)
vsoShapeA1.Cells("Fillforegnd").Formula = "RGB(215,135,131)"
vsoShapeA1.BringToFront
Dim vsoShapeA2 As Visio.shape
Set vsoShapeA2 = ActivePage.DrawRectangle(2, 6, 6, 1)
vsoShapeA2.Cells("Fillforegnd").Formula = "RGB(215,135,131)"
vsoShapeA2.BringToFront
ActiveWindow.DeselectAll
vsoSelection.Select vsoShapeA1, visSelect
vsoSelection.Select vsoShapeA2, visSelect
vsoSelection.Union
vsoLayer.Add (?)......
Then I am stuck to assign the merged shape to a layer. Needing help. Thanks.
Union will remove the existing shapes and create a new shape. The new shape will be the most recent shape in the page's Shapes collection. You can use that to get a reference to the new shape and add it to the layer:
Set vsoNewShape = ActivePage.Shapes.Item(ActivePage.Shapes.Count)
vsoLayer.Add vsoNewShape, 0
Related
I am trying to get the dimensions of the main placeholder in the Slide Master Text placeholder 2 - that in the code would be "MasterPlaceholder" - (whose size has been modified, and the new dimensions are pulled only in the third Layout, as shown in the picture) and set them as the basis for the resizing of all other placeholders in the other Layouts. Given a certain distance between Heading's placeholders and Body/Generic placeholders, I would like to loop through all Layouts and apply the new size.
However, I do not know how to point to this shape and I tried several ways (also "ActivePresentation.Designs(1).SlideMaster.Shapes.Placeholders.("Text Placeholder 2")", "ActivePresentation.Designs(1).SlideMaster.Shapes.Placeholders.Name("Text Placeholder 2")", but I cannot find a way to point it without errors.
Could someone please let me know how to properly refer to it? This would also help me find a way to refer to "PlcHlder", which would be the shape to be ridimensioned
Sub PlaceHolderResizer()
Dim LeftLimit As Single
Dim TopLimit As Single
Dim RightLimit As Single
Dim BottomLimit As Single
Dim DrawingAreaWidth As Single
Dim DrawingAreaHeight As Single
Dim MasterPlaceholder As Shape
Dim PlcHldr As Shape
Dim oShape As Shape
Dim HorizontalDistance As Single
Dim VerticalDistance As Single
Dim HeadingToPlaceholder As Single
HorizontalDistance = 360
VerticalDistance = 144
HeadingToPlaceholder = 144
Set MasterPlaceholder = SlideMaster.Shapes.Placeholders.Name("Text Placeholder 2")
LeftLimit = MasterPlaceholder.Left
TopLimit = MasterPlaceholder.Top
RightLimit = MasterPlaceholder.Left + oShape.Width
BottomLimit = MasterPlaceholder.Top + oShape.Height
DrawingAreaWidth = MasterPlaceholder.Width
DrawingAreaHeight = MasterPlaceholder.Height
For Each oShape In ActivePresentation.Designs(1).SlideMaster.CustomLayouts(4).Shapes
If oShape.Name = "Content Placeholder 2" Then
oShape = PlcHldr
oShape.Left = LeftLimit
oShape.Width = (DrawingAreaWidth / 2) - HorizontalDistance
End If
Next oShape
End Sub
On the slide master, there can only be one text placeholder. So you can use the placeholder Type property to identify it and get its name:
Sub GetPlaceHolderName()
Dim oShape As Shape
For Each oShape In ActivePresentation.SlideMaster.Shapes
If oShape.PlaceholderFormat.Type = ppPlaceholderBody Then
MsgBox oShape.Name
End If
Next oShape
End Sub
Looping through object collections to get names is par for the course with PowerPoint VBA, you'll use that technique very often.
As in https://learn.microsoft.com/en-us/office/vba/api/powerpoint.placeholders, I assigned the Index 2 to the shape (because there is a title, which would be 1) and finally the placeholder was re-dimensioned (the size at this moment does not matter, since it is something I will fix later). The code still needs great improvement, but at least I saw some action in the item I was referring to.
I will have to find a way to point to the placeholder by name somehow, something more talkative than an index number.
Sub PlaceHolderResizer()
Dim LeftLimit As Single
Dim TopLimit As Single
Dim RightLimit As Single
Dim BottomLimit As Single
Dim DrawingAreaWidth As Single
Dim DrawingAreaHeight As Single
Dim MasterPlaceholder As Shape
'Dim PlcHldr As Shape
Dim oShape As Shape
Dim HorizontalDistance As Single
Dim VerticalDistance As Single
Dim HeadingToPlaceholder As Single
HorizontalDistance = 72
VerticalDistance = 144
HeadingToPlaceholder = 144
Set MasterPlaceholder = ActivePresentation.SlideMaster.Shapes.Placeholders(2) ' here is how I should have called it
LeftLimit = MasterPlaceholder.Left
TopLimit = MasterPlaceholder.Top
' RightLimit = MasterPlaceholder.Left + oShape.Width
' BottomLimit = MasterPlaceholder.Top + oShape.Height
DrawingAreaWidth = MasterPlaceholder.Width
DrawingAreaHeight = MasterPlaceholder.Height
For Each oShape In ActivePresentation.Designs(1).SlideMaster.CustomLayouts(4).Shapes
If oShape.Name = "Content Placeholder 2" Then
' oShape = PlcHldr
oShape.Left = LeftLimit
oShape.Width = DrawingAreaWidth - HorizontalDistance
End If
Next oShape
End Sub
I am a newbie in PowerPoint VBA. I want to merge two shapes using VBA. So I search in the web & found the solution here https://stackoverflow.com/a/46025003/17766045
Dim shp1 As Shape
Dim shp2 As Shape
Set shp1 = ActivePresentation.Slides(1).Shapes.AddShape(msoShapeOval, 100, 100, 50, 50)
Set shp2 = ActivePresentation.Slides(1).Shapes.AddShape(msoShapePie, 100, 100, 50, 50)
Call ActiveWindow.Selection.SlideRange(1).Shapes.Range(Array(shp1.ZOrderPosition, shp2.ZOrderPosition)).MergeShapes(msoMergeCombine)
But I don't configure how to rename that merge shape.
this merge shape is not on top or bottom in the selection pane its lies between other shapes
When you merge multiple shapes, it creates a new shape, and newly created shapes will be at the top of the Z-order.
For some odd reason, .MergeShapes doesn't return a reference to the newly created shape, but since it'll be at the top of the Z-order, you can reference it as shown in the code sample below:
Sub thing()
Dim shp1 As Shape
Dim shp2 As Shape
Dim aShapeArray As Variant
Dim oRange As ShapeRange
Set shp1 = ActivePresentation.Slides(1).Shapes.AddShape(msoShapeOval, 100, 100, 50, 50)
Set shp2 = ActivePresentation.Slides(1).Shapes.AddShape(msoShapePie, 100, 100, 50, 50)
' Using shape names rather than z-order position to fill the array and
' breaking the merge step into several simpler/easier to understand steps:
Set aShapeArray = ActivePresentation.Slides(1).Shapes.Range(Array(shp1.Name, shp2.Name))
Set oRange = aShapeArray
oRange.MergeShapes (msoMergeCombine)
ActivePresentation.Slides(1).Shapes(ActivePresentation.Slides(1).Shapes.Count).Name = "BINGO!"
End Sub
I am trying to instantiate a dynamic array after erasing it.
I use an array to store shapes that I create so that I dont need to loop every shape on the page. Since there are many already. Every new page I erase the array but then run into a "subscript out of range" error when I try to add the first shape to the array.
Dim SeqShapes() As Shape
For PageCount = 0 to activeDocument.Pages.Count
Erase SeqShapes
For ShapesNeeded = 0 to ShapesCount
Set NewShape = ActivePage.Drop(SomeShape, 20, 20)
SeqShapes(UBound(SeqShapes)) = NewShape
Next
'Some more code
Next
This returns an error because there are no entries in the array.
I don't want to use a fixed array because there is no way to know how many shapes will be created beforehand.
I have tried adding a dummy record but can't seem to figure out the syntax:
Dim SeqShapes() As Shape
Dim DummyShape As Shape
For PageCount = 0 to activeDocument.Pages.Count
Erase SeqShapes
SeqShapes(0) = DummyShape
For ShapesNeeded = 0 to ShapesCount
Set NewShape = ActivePage.Drop(SomeShape, 20, 20)
SeqShapes(UBound(SeqShapes)) = NewShape
Next
'Some more code
Next
Any help would be greatly appreciated.
Use a collection rather than an array
Dim SeqShapes As Collection
For PageCount = 0 to activeDocument.Pages.Count
Set SeqShapes = Nothing ' Easiest way to clear it is to recreate it.
Set SeqShapes = New Collection
Dim ShapesNeeded
Dim newShape As Shape
For ShapesNeeded = 0 To 3
Set newShape = ActivePage.Drop(SomeShape, 20, 20)
SeqShapes.Add newShape ' Add the shape into Collection
Next ShapesNeeded
...
Next PageCount
To loop over all shapes in the collection:
' Using ForEach (you have to declare you running variable as Variant)
Dim sh As Variant
For Each sh In SeqShapes
Debug.Print sh.Name
Next sh
' Using for
Dim i As Long
For i = 1 To SeqShapes.Count
Debug.Print SeqShapes(i).Name
Next i
I want to glue a shape to another one via VBA.
All the shapes are created with an UserForm Module.
I want certain shapes to be connected with an arrow (which is also dropped on the page via an UserForm). It works fine connecting two shapes which are not in a group. Now I want to connect two shapes where one or both of them may be in a Group.
This works fine with non-grouped shapes
'get shp, src, aim
[...]
shp.Cells("BeginX").GlueTo src.Cells("PinX")
shp.Cells("EndX").GlueTo aim.Cells("PinX")
I get the aim and src Shapes using this function:
Function getShape(id As Integer, propName As String) As Shape
Dim shp As Shape
Dim subshp As Shape
For Each shp In ActivePage.Shapes
If shp.Type = 2 Then
For Each subshp In shp.GroupItems
If subshp.CellExistsU(propName, 0) Then
If subshp.CellsU(propName).ResultIU = id Then
Set getShape = subshp
Exit For
End If
End If
Next subshp
End If
If shp.CellExistsU(propName, 0) Then
If shp.CellsU(propName).ResultIU = id Then
Set getShape = shp
Exit For
End If
End If
Next
End Function
I think there is something wrong with how I iterate through the subshapes.
Any help is appreciated.
Ah, #Surrogate beat me to it :) but since I've started writing...in addition to his answer, which shows nicely how to adapt the built in Dynamic connector here's a go with your group finding method + a custom connector.
The code assumes a few things:
a page with two 2D shapes already dropped
one of the shapes is a group shape containing a subshape with the correct Shape Data
A custom master named 'MyConn' which is simple a 1D line with no other modifications
Public Sub TestConnect()
Dim shp As Visio.Shape 'connector
Dim src As Visio.Shape 'connect this
Dim aim As Visio.Shape 'to this
Dim vPag As Visio.Page
Set vPag = ActivePage
Set shp = vPag.Drop(ActiveDocument.Masters("MyConn"), 1, 1)
shp.CellsU("ObjType").FormulaU = 2
Set src = vPag.Shapes(1)
Set aim = getShape(7, "Prop.ID")
If Not aim Is Nothing Then
shp.CellsU("BeginX").GlueTo src.CellsU("PinX")
shp.CellsU("EndX").GlueTo aim.CellsU("PinX")
End If
End Sub
Function getShape(id As Integer, propName As String) As Shape
Dim shp As Shape
Dim subshp As Shape
For Each shp In ActivePage.Shapes
If shp.Type = 2 Then
For Each subshp In shp.Shapes
If subshp.CellExistsU(propName, 0) Then
If subshp.CellsU(propName).ResultIU = id Then
Set getShape = subshp
Exit For
End If
End If
Next subshp
End If
If shp.CellExistsU(propName, 0) Then
If shp.CellsU(propName).ResultIU = id Then
Set getShape = shp
Exit For
End If
End If
Next
End Function
Note that if you read the docs for Cell.GlueTo, you'll see this item:
The pin of a 2-D shape (creates dynamic glue): The shape being glued
from must be routable (ObjType includes visLOFlagsRoutable ) or have a
dynamic glue type (GlueType includes visGlueTypeWalking ), and does
not prohibit dynamic glue (GlueType does not include
visGlueTypeNoWalking ). Gluing to PinX creates dynamic glue with a
horizontal walking preference and gluing to PinY creates dynamic glue
with a vertical walking preference.
and hence why I'm setting the ObjType cell to 2 (VisCellVals.visLOFlagsRoutable). Normally you'd set this in your master instance and so wouldn't need that line of code.
Please try this code
Dim connector As Shape, src As Shape, aim As Shape
' add new connector (right-angle) to page
Set connector = Application.ActiveWindow.Page.Drop(Application.ConnectorToolDataObject, 0, 0)
' change Right-angle Connector to Curved Connector
connector.CellsSRC(visSectionObject, visRowShapeLayout, visSLOLineRouteExt).FormulaU = "2"
connector.CellsSRC(visSectionObject, visRowShapeLayout, visSLORouteStyle).FormulaU = "1"
Set src = Application.ActiveWindow.Page.Shapes.ItemFromID(4)
Set aim = Application.ActiveWindow.Page.Shapes.ItemFromID(2)
Dim vsoCell1 As Visio.Cell
Dim vsoCell2 As Visio.Cell
Set vsoCell1 = connector.CellsU("BeginX")
Set vsoCell2 = src.Cells("PinX")
vsoCell1.GlueTo vsoCell2
Set vsoCell1 = connector.CellsU("EndX")
Set vsoCell2 = aim.Cells("PinX")
vsoCell1.GlueTo vsoCell2
Is there any way to get a shape's Id if you know it's Name?
For example, if I have this:
Dim myshape As Shape
myshape.Name
Can I get it's Id?
myshape.Id = getIdByName(myshape.Name)
Sure, it's pretty straigtforward:
Sub PrintShapeID()
Debug.Print getIDByName("My Shape", 1)
End Sub
Function getIDByName(shapeName As String, slide As Integer)
Dim ap As Presentation: Set ap = ActivePresentation
Dim sl As slide: Set sl = ap.Slides(slide)
Dim sh As Shape: Set sh = sl.Shapes(shapeName)
getIDByName = sh.Id
End Function
This works for the slide that you specify. You can also loop through all slides, but note that there may be more than one shape with the same name so you'd have to figure out which one you want.