I struggle with a macro to make all shapes (rectangles in this case) the same size.
Example: I have three rectangles in three different sizes. Now, I want to resize all rectangles to the same size using the first rectangle I have clicked/marked.
How to come around this problem?
There is a macro I have found sizing to the smallest shape range, but not if the "mid rectangle" should be the dominant one...
Sub ResizeToSmallest()
' PPT coordinates are Singles rather than Doubles
Dim sngNewWidth As Single
Dim sngNewHeight As Single
Dim oSh As Shape
' Start with the height/width of first shape in selection
With ActiveWindow.Selection.ShapeRange
sngNewWidth = .Item(1).Width
sngNewHeight = .Item(1).Height
End With
' First find the smallest shape in the selection
For Each oSh In ActiveWindow.Selection.ShapeRange
If oSh.Width < sngNewWidth Then
sngNewWidth = oSh.Width
End If
If oSh.Height < sngNewHeight Then
sngNewHeight = oSh.Height
End If
Next
' now that we know the height/width of smallest shape
For Each oSh In ActiveWindow.Selection.ShapeRange
oSh.Width = sngNewWidth
oSh.Height = sngNewHeight
Next
End Sub
Related
I was working on below given script to convert all the corners in rounded corners, but the rounded corners are not giving same values for all shapes.
I have worked on below scripts
Sub RoundedCorner5()
Dim oShape As Shape
Dim sngRadius As Single ' Radius size in points
sngRadius = 0.05
For Each oShape In ActiveWindow.Selection.ShapeRange
With oShape
oShape.AutoShapeType = msoShapeRoundedRectangle
oShape.TextFrame.WordWrap = msoFalse
oShape.TextEffect.Alignment = msoTextEffectAlignmentCentered
.Adjustments(1) = sngRadius
End With
Next
Set oShape = Nothing
End Sub
Suppose if I have one small rectangle and one big rectangle the the rounded corner values come different for both shapes
By default, round corners are proportional to the shape size. Here is Microsoft's page about adjustments, please note that the units are not points: Adjustments object (PowerPoint)
This code should get you pretty close, change RadiusFactor to get the corner size you prefer:
Sub RoundedCorner5()
Dim oShape As Shape
Dim RadiusFactor As Single
RadiusFactor = 50
For Each oShape In ActiveWindow.Selection.ShapeRange
With oShape
.AutoShapeType = msoShapeRoundedRectangle
.Adjustments(1) = (1 / (oShape.Height + oShape.Width)) * RadiusFactor
.TextFrame.WordWrap = msoFalse
.TextEffect.Alignment = msoTextEffectAlignmentCentered
End With
Next
End Sub
The following code works perfect for this job.
Full credits to: Rembrandt Kuipers
Site where the code is: https://www.brandwares.com/bestpractices/2019/09/uniform-rounded-corners-cool-code/
Sub RoundAllPPCorners()
Dim oSlide As Slide, oShape As Shape, RadiusFactor!
RadiusFactor! = 5
For Each oSlide In ActivePresentation.Slides
For Each oShape In oSlide.Shapes
With oShape
If .AutoShapeType = msoShapeRoundedRectangle Then
minDim = oShape.Height
If oShape.Width < oShape.Height Then
minDim = oShape.Width
End If
.Adjustments(1) = (1 / minDim) * RadiusFactor!
End If
End With
Next oShape
Next oSlide
End Sub
I am trying to create a "sticker" macro for PowerPoint. In short terms I have a button that marks selected slides with a shape that says "Done". This macro is working. However, I also need a macro that deletes the done-sticker on selected slides. What I have right now manages to delete the shape if only one slide is selected. I am very new to VBA in PowerPoint.
Add sticker macro (that works):
Sub StickerDone()
Dim StickerText As String
Dim sld As Slide
StickerText = "Done"
Dim shp As Shape
For Each sld In ActiveWindow.Selection.SlideRange
'Create shape with Specified Dimensions and Slide Position
Set shp = sld.Shapes.AddShape(Type:=msoShapeRectangle, _
Left:=0 * 28.3464567, Top:=0 * 28.3464567, Width:=80, Height:=26.6)
'FORMAT SHAPE
'Shape Name
shp.Name = "StickerDone"
'No Shape Border
shp.Line.Visible = msoFalse
'Shape Fill Color
shp.Fill.ForeColor.RGB = RGB(56, 87, 35)
'Shape Text Color
shp.TextFrame.TextRange.Font.Color.RGB = RGB(255, 255, 255)
'Text inside Shape
shp.TextFrame.TextRange.Characters.Text = StickerText
'Center Align Text
shp.TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignCenter
'Vertically Align Text to Middle
shp.TextFrame2.VerticalAnchor = msoAnchorMiddle
'Adjust Font Size
shp.TextFrame2.TextRange.Font.Size = 14
'Adjust Font Style
shp.TextFrame2.TextRange.Font.Name = "Corbel"
'Rotation
shp.Rotation = 0
Next sld
End Sub
Delete sticker macro (that does not work):
Sub StickerDelete()
Dim shp As Shape
Dim sld As Slide
For Each sld In ActiveWindow.Selection.SlideRange
For Each shp In sld.Shapes
If shp.Name Like "StickerDone" Then
shp.Select
shp.Delete
End If
Next shp
Next sld
End Sub
Deleting objects you are iterating over is generally a bad idea. Add them to an array and delete them after your (inner) loop is done.
Try this:
Sub StickerDelete()
Dim shp As Shape
Dim sld As Slide
ReDim ShapesToDelete(0)
Dim ShapeCount
For Each sld In ActiveWindow.Selection.SlideRange
For Each shp In sld.Shapes
If shp.Name Like "StickerDone" Then
'shp.Select
'shp.Delete
ShapeCount = ShapeCount + 1
ReDim Preserve ShapesToDelete(0 To ShapeCount)
Set ShapesToDelete(ShapeCount) = shp
End If
Next shp
Next sld
For i = 1 To ShapeCount
ShapesToDelete(i).Delete
Next
End Sub
Alright, so for a PHP script, i need all non-image objects to be converted to images (excluding text) from a .pptx file. As i have quite a lot .pptx files, i tought that i might as well use VBA.
For some reason however, my Else If is acting weird.
Sub nieuwemacro()
Dim oSl As Slide
Dim oSh As Shape
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
' MsgBox (oSh.Type)
' modify the following depending on what you want to
' convert
If oSh.Type = 1 Then
ConvertShapeToPic oSh
Else
End If
Next
Next
End Sub
Sub ConvertShapeToPic(ByRef oSh As Shape)
Dim oNewSh As Shape
Dim oSl As Slide
oSh.Fill.ForeColor.RGB = RGB(0, 0, 0)
Set oSl = oSh.Parent
oSh.Copy
Set oNewSh = oSl.Shapes.PasteSpecial(ppPastePNG)(1)
With oNewSh
.Left = oSh.Left
.Top = oSh.Top
Do
.ZOrder (msoSendBackward)
Loop Until .ZOrderPosition = .ZOrderPosition
End With
oSh.Delete
End Sub
The oSh.Fill.ForeColor.RGB = RGB(0, 0, 0) part is just there to see what happens. And this is the result:
Alright.. So everything is converted properly, except for the big pink ball. So i thought i'd try some other Else ifs. My new Else If statement:
If oSh.Type = 1 Then
ConvertShapeToPic oSh
ElseIf oSh.Type = 14 Then
ConvertShapeToPic oSh
Else
End If
Resulting in this:
Notice how the code now doesnt convert the green bar at the top? It does that when i add or remove IfElse parts...
I don't know why it does this, could someone tell me what i'm doing wrong?
try this
Option Explicit
Sub nieuwemacro()
Dim oSl As Slide
Dim oSh As Shape
Dim oShs() As Shape
Dim nShps As Long, iShp As Long
For Each oSl In ActivePresentation.Slides
ReDim oShs(1 To oSl.Shapes.Count) As Shape
For Each oSh In oSl.Shapes
' MsgBox (oSh.Type)
' modify the following depending on what you want to
' convert
If oSh.Type = 1 Then
nShps = nShps + 1
Set oShs(nShps) = oSh
End If
Next
If nShps > 0 Then
For iShp = 1 To nShps
ConvertShapeToPic oShs(iShp)
Next iShp
End If
Next
End Sub
Sub ConvertShapeToPic(ByRef oSh As Shape)
Dim oNewSh As Shape
Dim oSl As Slide
oSh.Fill.ForeColor.RGB = RGB(0, 0, 0)
Set oSl = oSh.Parent
oSh.Copy
Set oNewSh = oSl.Shapes.PasteSpecial(ppPastePNG)(1)
With oNewSh
.Left = oSh.Left
.Top = oSh.Top
Do
.ZOrder (msoSendBackward)
Loop Until .ZOrderPosition = .ZOrderPosition
End With
oSh.Delete
End Sub
You may also want to consider the following refactoring:
Option Explicit
Sub nieuwemacro()
Dim oSl As Slide
Dim oShs() As Shape
For Each oSl In ActivePresentation.Slides
oShs = GetShapes(oSl, msoAutoShape) '<--| gather shapes of given type and...
ConvertShapesToPics oShs '<--| ...convert them
Next
End Sub
Function GetShapes(oSl As Slide, shType As MsoShapeType) As Shape()
Dim oSh As Shape
Dim nShps As Long
With oSl.Shapes '<--| reference passed slide Shapes collection
ReDim oShs(1 To .Count) As Shape '<--| resize shapes array to referenced slide shapes number (i.e. to maximum possible)
For Each oSh In .Range '<--| loop through referenced slide shapes
If oSh.Type = shType Then '<--| if its type matches the passed one
nShps = nShps + 1 '<--| update gathered shapes counter
Set oShs(nShps) = oSh '<--| fill gathered shapes array
End If
Next
End With
If nShps > 0 Then '<--| if any shape has been gathered
ReDim Preserve oShs(1 To nShps) As Shape '<--| resize array properly ...
GetShapes = oShs '<--| ... and return it
End If
End Function
Sub ConvertShapesToPics(oShs() As Shape)
Dim iShp As Long
If IsArray(oShs) Then '<--| if array has been initialized ...
For iShp = 1 To UBound(oShs) '<--|... then loop through its elements (shapes)
ConvertShapeToPic oShs(iShp) '<--| convert current shape
Next iShp
End If
End Sub
Sub ConvertShapeToPic(ByRef oSh As Shape)
With oSh '<--| reference passed shape
.Fill.ForeColor.RGB = RGB(0, 0, 0) '<--| change its forecolor
.Copy '<--| copy it
With .Parent.Shapes.PasteSpecial(ppPastePNG)(1) '<--| reference pasted shape
.Left = oSh.Left '<--| adjust its Left position
.Top = oSh.Top '<--| adjust its Top position
Do
.ZOrder (msoSendBackward)
Loop Until .ZOrderPosition = .ZOrderPosition
End With
.Delete '<--| delete referenced passed shape
End With
End Sub
Finally, you may want to shorten down "main" sub by two lines more like follwos
Sub nieuwemacro()
Dim oSl As Slide
For Each oSl In ActivePresentation.Slides
ConvertShapesToPics GetShapes(oSl, msoAutoShape) '<--| convert shapes of given type
Next
End Sub
where GetShapes(), ConvertShapesToPics() and ConvertShapeToPic() stays the same.
Good day,
I have got this code to modify the size and position of every shape on all slides, but would like the procedure to start ONLY from slide 2.
Sub SlideLoop()
Dim osld As Slide
Dim oSh As Shape
For Each osld In ActivePresentation.Slides
' check each shape on the slide
' is it an image or whatever you're looking for?
For Each oSh In osld.Shapes
With oSh
If .Type = msoLinkedPicture _
Or .Type = msoPicture Then
' position it to taste
.Left = 30
.Top = 100
.Height = 750
.Width = 680
' centering/resizing gets trickier
' but is still possible.
' Exercise for the reader?
' Hint:
' ActivePresentation.PageSetup.SlideWidth and .SlideHeight
' tells you the width and height of the slide
'
' All values are in Points (72 to the inch)
End If
End With
Next ' Shape
Next osld ' Slide
End Sub}
What do I need to change?
Check the SlideIndex property of the slides - if it is 1, you skip to the next slide.
Just inside the For Each osld In ActivePresentation.Slides loop, add an if statement:
If osld.SlideIndex > 1 Then
'Your code...
For Each oSh In osld.Shapes
...
Next ' Shape
End If
Olle's correct. Or another approach, my changes in BOLD:
Sub SlideLoop()
Dim osld As Slide
Dim oSh As Shape
Dim x as Long
'For Each osld In ActivePresentation.Slides
For x = 2 to ActivePresentation.Slides.Count
Set oSld = ActivePresentation.Slides(x)
' check each shape on the slide
' is it an image or whatever you're looking for?
For Each oSh In osld.Shapes
With oSh
If .Type = msoLinkedPicture _
Or .Type = msoPicture Then
' position it to taste
.Left = 30
.Top = 100
.Height = 750
.Width = 680
' centering/resizing gets trickier
' but is still possible.
' Exercise for the reader?
' Hint:
' ActivePresentation.PageSetup.SlideWidth and .SlideHeight
' tells you the width and height of the slide
'
' All values are in Points (72 to the inch)
End If
End With
Next ' Shape
Next osld ' Slide
End Sub
So I have written the following code to make the textboxes in my presentation visisible and then bring them to the front (they are made invisible by a separate macro):
Dim oSld As Slide
Dim oShp As Shape
Dim oPPT As Presentation
For Each oSld In ActivePresentation.Slides
For Each oShp In oSld.Shapes
If oShp.Type = msoTextBox Then
oShp.Visible = True
oShp.ZOrder msoBringToFront
End If
Next oShp
Next oSld
It worked perfectly before I added the bring to front command! Now only around half of the shapes are made visible when the code is run. I've been reading around online and it appears that ZOrder changes the number of shapes and that is why only some are made visible.... but cannot work out a way around it! Would really appreciate some help!
You've put your finger on the cause. The For Each/Next loop appears to take a snapshot of the shape order at the time it starts. If you change the shape order or delete shapes in the body of the loop it throws things off. Instead, try something like the (untested)(air)code below to build an array of references to the shapes and then process them one at a time from the array:
Dim aShapeArray() as Shape
Dim x as Long
ReDim aShapeArray(1 to oSld.Shapes.Count) as Shape
' Build an array of shapes
For Each oShp In oSld.Shapes
Set aShapeArray(x) = oShp
x = x+1
Next
' Then do what you need to do with each shape in the array
For x = 1 to Ubound(aShapeArray)
Set oShp = aShapeArray(x)
If oShp.Type = msoTextBox Then
oShp.Visible = True
oShp.ZOrder msoBringToFront
End If
Next
Thanks for all your help #SteveRindsberg, a couple a tweaks to your code and i cracked it :)
Dim oSld As Slide
Dim aShapeArray()
Dim x As Long
For Each oSld In ActivePresentation.Slides
x = 1
If oSld.Shapes.Count > 0 Then
ReDim aShapeArray(1 To oSld.Shapes.Count)
' Build an array of shapes
For Each oShp In oSld.Shapes
Set aShapeArray(x) = oShp
x = x + 1
Next
' Then do what you need to do with each shape in the array
For x = 1 To UBound(aShapeArray)
Set oShp = aShapeArray(x)
If oShp.Type = msoTextBox Then
oShp.Visible = True
oShp.ZOrder msoBringToFront
End If
Next
End If
Next