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
Related
I'm tring to split a table if the table overflows the slide. I found some code that I modified slightly.
But when I try to add a row on the new table to copy the header from the original table I get an error.
If I add the line:
``` oTableShape.Table.Rows.Add BeforeRow:=1```
after the final next in the CopyToNewTable routine, I get an error at:
``` oSourceShape.Table.cell(RowIndex + I - 1, J).Shape.textFrame.textRange.Copy```
which is a couple of lines above. The error is:
```Method 'Copy' of object ' Textrange' failed.```
If I delete it, the add befor, it works fine.
Code follows.
Thanks in advance
Function GetRowOverFlowIndex(oShape As Shape, oPres As Presentation) As Long
Dim Index As Long
Dim sngSldHeight As Single
Dim sngCurrHeight As Single
sngSldHeight = txDrawAreaTop + txDrawAreaHeight ' oPres.PageSetup.SlideHeight
'Get the top position of the shape on the slide
sngCurrHeight = oShape.Top
For Index = 1 To oShape.Table.Rows.Count
'Check if the current height exceeds that of the slide height
If sngCurrHeight + oShape.Table.Rows(Index).Height > sngSldHeight Then
'We have found the row at which the table moves off the slide.
GetRowOverFlowIndex = Index
Exit Function
Else
'Increment the current height
sngCurrHeight = sngCurrHeight + oShape.Table.Rows(Index).Height
End If
Next
End Function
'' Copy that row onwards to a new slide
Sub CopyToNewTable(oSlide As slide, oSourceShape As Shape, RowIndex As Long)
Dim oTableShape As Shape
Dim I As Long
Dim J As Long
Set oTableShape = oSlide.Shapes.AddTable(oSourceShape.Table.Rows.Count - RowIndex + 1, _
oSourceShape.Table.Columns.Count, _
oSourceShape.left, _
oSourceShape.Top, _
oSourceShape.Width)
For I = 1 To oTableShape.Table.Rows.Count
For J = 1 To oTableShape.Table.Columns.Count
'Copy the text from the cell.
oSourceShape.Table.cell(RowIndex + I - 1, J).Shape.textFrame.textRange.Copy
'Paste it into the new location.
oTableShape.Table.cell(I, J).Shape.textFrame.textRange.Paste
Next
oTableShape.Table.Rows(I).Height = oSourceShape.Table.Rows(RowIndex + I - 1).Height
Next
oTableShape.Table.Rows.Add BeforeRow:=1
End Sub
'' Delete the copied rows from the source table from the main routine.
'' Let us bring it altogether into this routine.
Sub SplitTable()
Dim RowIndex As Long
Dim oShp As Shape
Dim oSld As slide
Dim I As Long
Set oShp = ActiveWindow.Selection.ShapeRange(1)
'Check if the selected shape is a table.
If Not oShp.HasTable Then
MsgBox "This is not a table.", vbExclamation
Exit Sub
End If
'Get the row at which table moves off the slide
RowIndex = GetRowOverFlowIndex(oShp, ActivePresentation)
'If no rows are out of slide, just get out otherwise process it
If RowIndex > 0 Then
'Add a new slide for the a new table
Set oSld = ActivePresentation.Slides.Add(oShp.Parent.SlideIndex + 1, oShp.Parent.Layout)
'Now copy the rows to the new table.
Call CopyToNewTable(oSld, oShp, RowIndex)
'Delete the rows from the original table
For I = oShp.Table.Rows.Count To RowIndex Step -1
oShp.Table.Rows(I).Delete
Next
End If
End Sub
I followed #timwilliams advice and re-wrote the routine to duplicate the slide and delete the unnecessary rows on each slide's tables. Thanks Tim for the steerirng!
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 playing with a progress bar (with basically zero experience with VBA whatsoever). I found the following snippet online:
Sub ProgressBar()
On Error Resume Next
With ActivePresentation
.SectionProperties.SlidesCount(
For N = 2 To .Slides.Count
.Slides(N).Shapes("Progress_Bar").Delete
Set s = .Slides(N).Shapes.AddShape(msoShapeRectangle, 0, .PageSetup.SlideHeight - 10, N * .PageSetup.SlideWidth / .Slides.Count, 10)
Call s.Fill.Solid
s.Fill.ForeColor.RGB = RGB(128, 128, 128)
s.Line.Visible = False
s.Name = "Progress_Bar"
Next N:
End With
End Sub
Note the part with For N = 2 To .Slides.Count. I'd like the progress bar not to reach from the second slide the last one but rather from the second slide to the last slide of the section I called "conclusion". How can I do that?
Thanks!
Edit: My current workaround is a hard coded number of slides that I define as a variable at the beginning of the macro and then use the variable throughout the rest of it.
Here are a couple of bits that should get you started:
LastSlideOf returns the slide index of the last slide in the named section passed to it:
Function LastSlideOf(sSectionName As String) As Long
Dim x As Long
With ActivePresentation.SectionProperties
x = SectionIndexOf(sSectionName)
LastSlideOf = (.FirstSlide(x) + .SlidesCount(x)) - 1
End With
End Function
Function SectionIndexOf(sSectionName As String) As Long
Dim x As Long
With ActivePresentation.SectionProperties
For x = 1 To .Count
If .Name(x) = sSectionName Then
SectionIndexOf = x
End If
Next
End With
End Function