I have used VBA in the past mostly with excel, but I am not very experienced.
I want to cycle through multiple boxes and make each of them have coincident edges. Like they are sitting on top of each other. I am having trouble identifying the position of the first shape in my selection. I've tried a number of different objects including selection.shaperange.
Dim shp As Visio.Shape
Dim shp1 As Visio.Shape
Dim Pos As Double
Set shp1 = ActiveWindow.Selection.ShapeRange.Item
Pos = shp1.Cells("PinY")
For Each shp In Application.ActiveWindow.Selection
'Change the cell name to the one you want
If shp <> ActiveWindow.Selection.Item(1) Then
Pos = Pos + 6
End If
shp.CellsSRC(visSectionControls, visRowXFormOut, visXFormPinY).FormulaU = Pos & "mm"
Pos = shp.Cells("PinY")
Next shp
End Sub
Can you help me get the position of the first selected item and then I may be able to figure out the rest.
This code will abut the left sides of all but the first-selected shape with the right side of the first-selected shape:
Option Explicit
Public Sub AbutLeftsToPrimaryRight()
Dim sel As Visio.Selection
Set sel = Visio.ActiveWindow.Selection
If (sel.Count < 2) Then
Debug.Print "Select two or more shapes (Use Shift + Click)!"
GoTo Cleanup
End If
Dim shp0 As Visio.Shape
Dim shp As Visio.Shape
'// Get the selection and the primary selected shape,
'// which is item(1). See also: Selection.PrimaryItem
Set shp0 = sel(1)
'// Quick calculate the right side of shp0:
'// PinX - LocPinX + Width.
Dim dRight0 As Double
dRight0 = shp0.CellsU("PinX").ResultIU - shp0.CellsU("LocPinX").ResultIU + shp0.CellsU("Width").ResultIU
'// If shapes are rotated, flipped, or not rectangular,
'// then you'll need to use shp.BoundingBox, which
'// is more complicated
Dim dLeft As Double
Dim dx As Double, px As Double
Dim i As Integer
For i = 2 To sel.Count
'// Get the ith shape:
Set shp = sel(i)
'// Get its Pin:
px = shp.CellsU("PinX").ResultIU
'// Calculate the left side of the shape:
'// PinX - LocPinX:
dLeft = px - shp.CellsU("LocPinX").ResultIU
'// The offset:
dx = dLeft - dRight0
'// Set the new pin:
shp.CellsU("PinX").ResultIUForce = px - dx
Next i
Cleanup:
Set shp0 = Nothing
Set shp = Nothing
Set sel = Nothing
End Sub
Hope this helps!
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 need to generate a random number between 1 and 30 and display it on every slide. I found the following code online:
Sub UpdateRandomNumber(oSh As Shape)
Dim X As Long
'Make the shape’s text a random number
'X or less
'Change 12 below to any number you’d like:
X = 30
oSh.TextFrame.TextRange.Text = CStr(Random(X))
End Sub
Function Random(High As Long) As Long
'Generates a random number less than or equal to
'the value passed in High
Randomize
Random = Int((High * Rnd) + 1)
End Function
Sub RandomNumber()
End Sub
I need the code to do one thing differently:
The object prompting the action is in the same spot on all slides. When generating and displaying a random number, all slides should be changed accordingly.
When I leave the slide, the previously generated number should be shown instead of the one that was previously generated on this slide.
This creates a random number between 1 and 30. Change the shape name to the actual shape used in your file:
Sub ShapeNumber()
Dim X As Long
Dim ShapeNumber As String
Dim oSlide As Slide
Dim oShape As Shape
X = 30
Randomize
ShapeNumber = Int((X * Rnd) + 1)
For Each oSlide In ActivePresentation.Slides
For Each oShape In oSlide.Shapes
If oShape.Name = "Rectangle 3" Then
oShape.TextFrame.TextRange.Text = ShapeNumber
End If
Next oShape
Next oSlide
End Sub
I would like to align ( in this case center)a shape( round cornered rectangle) within sharp cornered rectangle in a slide i.e the center point of both shapes should be equal using VBA without using 'Selection'.I am thinking to reference them via names(Like, wherever these two shapes come as a bunch, macro should align them) but not sure how to start.
Excuse me for the layman's explanation. Any thoughts would really be helpful and push me to start.
You'll have to set up a loop to check each shape in the slide, finding if its Type is an AutoShape, then if its AutoShapeType is msoShapeRoundedRectangle or msoShapeRectangle. As each are found, you would store the name of each in a variable. If both are found then you would get the left, top, width and height measurements for each and set those values so the centers align.
Sub CenterShapes()
Dim oSlide As Slide
Dim oShape As Shape
Dim bFoundRRect As Boolean, bFoundRect As Boolean
Dim RRectName$, RectName$
For Each oSlide In ActivePresentation.Slides
For Each oShape In oSlide.Shapes
If oShape.Type = msoAutoShape Then
If oShape.AutoShapeType = msoShapeRoundedRectangle Then
bFoundRRect = True
RRectName$ = oShape.Name
End If
If oShape.AutoShapeType = msoShapeRectangle Then
bFoundRect = True
RectName$ = oShape.Name
End If
End If
Next oShape
If bFoundRRect = True And bFoundRect = True Then
RRectVCenter = oSlide.Shapes(RRectName$).Top + (oSlide.Shapes(RRectName$).Height / 2)
RRectHCenter = oSlide.Shapes(RRectName$).Left + (oSlide.Shapes(RRectName$).Width / 2)
RectVCenter = oSlide.Shapes(RectName$).Top + (oSlide.Shapes(RectName$).Height / 2)
RectHCenter = oSlide.Shapes(RectName$).Left + (oSlide.Shapes(RectName$).Width / 2)
VDif = RRectVCenter - RectVCenter
HDif = RRectHCenter - RectHCenter
oSlide.Shapes(RectName$).Top = oSlide.Shapes(RectName$).Top + VDif
oSlide.Shapes(RectName$).Left = oSlide.Shapes(RectName$).Left + HDif
End If
Next oSlide
End Sub
This example assumes you know, or determine with your code, the names of the shapes you want to align. Then it's a quick manner of setting up a ShapeRange and using the built-in alignment functions in PowerPoint.
Option Explicit
Sub AlignMe()
Dim theseShapeNames As Variant
theseShapeNames = Array("Rectangle 3", "Rectangle 4", "Rectangle 5")
Dim thisSlide As Slide
Dim theseShapes As ShapeRange
Set thisSlide = ActivePresentation.Slides(1)
Set theseShapes = thisSlide.Shapes.Range(theseShapeNames)
theseShapes.Align msoAlignCenters, msoFalse
End Sub
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.