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.
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
Is there any way to select the multiples shape from slide with the same shape name.
For e.g., I have 5 shapes with the name "Textbox 60". And I want run a macro which select all the shapes from a slide named "Textbox 60". Have used the below code.
ActiveWindow.View.Slide.Shapes.Range("Textbox 60").Select
Here's one approach:
Sub Tester()
SelectByName ActivePresentation.Slides(1), "Textbox1"
End Sub
Sub SelectByName(sld As Slide, nm As String)
Dim s As Shape, first As Boolean
first = True
For Each s In sld.Shapes
If s.Name = nm Then
s.Select first 'Argument determines whether to add to
first = False ' existing selection, or replace it
End If
Next s
End Sub
You should try following #TinMan's suggestion though - that is the "better" way to go.
Activating and Selecting Objects should be avoided whenever possible. You are better of working with the Shapes using a ShapeRange.
Sub Main()
Dim ShapeRange As ShapeRange
Set ShapeRange = FindShapes(ActiveWindow.View.Slide, "Textbox 60")
If Not ShapeRange Is Nothing Then
End If
End Sub
Function FindShapes(Slide As Slide, Pattern As String) As ShapeRange
Dim Results() As Long
ReDim Results(1 To Slide.Shapes.Count)
Dim n As Long
Dim Index As Long
For Index = 1 To Slide.Shapes.Count
With Slide.Shapes(Index)
.Name = "Textbox 60"
If .Name Like Pattern Then
n = n + 1
Results(n) = Index
End If
End With
Next
If n > 0 Then
ReDim Preserve Results(1 To n)
Set FindShapes = Slide.Shapes.Range(Results)
End If
End Function
Note: I rewrote the code to handle multiple shapes with the same name.
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!
I'm trying to explore how do I apply some formatting to only few selected words in a textbox but so far unable to accomplish this myself.
Somehow with the code I created below, I can only use it to select all the words in the textbox instead of just a few words I want.
It would be great if anyone can provide me a simpler/ existing codes that can help me solve this please ?
Thanks in advance
Sub ActiveTextRange()
Dim sld As slide
Dim sh As Shape
Dim wordcount As Long, j As Long, x As Long, y As Long, z As Long
wordcount = ActiveWindow.Selection.ShapeRange(1).textFrame.TextRange.Words.Count
With ActiveWindow.Selection.ShapeRange(1)
.textFrame.TextRange.Words(Start:=1, Length:=wordcount).Font.Color.RGB = RGB(230, 0, 0)
End With
End Sub
The following might help. Key to this is being able to track the location of the specific text you want to change in amongst larger chunks of text; my suggestion is to format each bit of text as you add it to the shape. Cheers.
Option Explicit
Sub ActiveTextRange()
Dim vPresentation As presentation
Dim vSlide As Slide
Dim vShape As Shape
Dim vAddThisText As String
' Create a new presentation, add a slide and a rectangle shape
Set vPresentation = Application.Presentations.Add
Set vSlide = vPresentation.Slides.Add(vPresentation.Slides.Count + 1, ppLayoutBlank)
Set vShape = vSlide.Shapes.AddShape(msoShapeRectangle, 10, 10, 600, 300)
' Make the shape white with a 3pt dark red border
vShape.Fill.ForeColor.RGB = rgbWhite
With vShape.Line
.ForeColor.RGB = rgbDarkRed
.Weight = 3
End With
' Setup the shape to be left aligned, font color, top anchored, etc
With vShape.TextFrame
.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignCenter
.TextRange.Font.Color.RGB = rgbBlack
.VerticalAnchor = msoAnchorMiddle
.TextRange.ParagraphFormat.SpaceAfter = 6
.TextRange.ParagraphFormat.WordWrap = msoCTrue
End With
' And now format the word red, which is the 7th character and is 3 long
vAddThisText = "Hello Red World"
vShape.TextFrame.TextRange.InsertAfter vAddThisText
With vShape.TextFrame.TextRange.Characters(7, 3)
.Font.Color.RGB = rgbRed
' and change other attributes if needed etc
End With
End Sub
And the output is ...
This colors the second and third words red in a Title placeholder. After Words, the first number is the starting position and the second number is the length:
Sub ColorWords()
Dim objSlide As Slide
Dim objShape As Shape
For Each objSlide In ActivePresentation.Slides
For Each objShape In objSlide.Shapes
If objShape.Type = msoPlaceholder Then
If objShape.PlaceholderFormat.Type = ppPlaceholderTitle Or objShape.PlaceholderFormat.Type = ppPlaceholderCenterTitle Then
With objShape.TextFrame2.TextRange.Words(2, 2).Font.Fill
.Solid
.ForeColor.RGB = RGB(255, 0, 0)
End With
End If
End If
Next objShape
Next objSlide
End Sub
To color a word selection, use:
ActiveWindow.Selection.TextRange.Font.Color.RGB = RGB(Red:=255, Green:=0, Blue:=0)
OK. I think I better understand the ask ... but I'm assuming in this response you're selecting text ... rather than just a shape itself. So you're editing the powerpoint, select some text in a shape, and want to run a macro to format(?) It should be as simple as creating the following in a code module (and then I created a custom access toolbar link to run the macro at the top of PowerPoint to make it quick):
Option Explicit
Sub ActiveTextRange()
ActiveWindow.Selection.TextRange.Font.Color.RGB = rgbRed
End Sub
Before:
Select the text "Red" and run macro:
Btw ... if you want to select just the shape and have some logic choose the text, the concept is a mix of this and my first answer.
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