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
Related
I am making a PowerPoint Presentation with a lot of math equations.
I would like to ask if there are any way to change the color of those equations automatically.
I found a solution but it is for Word documents there:
https://www.codeproject.com/Tips/1378034/Macro-to-Change-the-Color-of-all-Equations-in-a-Wo
Sub Change_Equation_Color()
'Macro to Change the Font Color of all Equations in a Word Document
Dim Eq As OMath
For Each Eq In ActiveDocument.OMaths
Eq.Range.Select
Selection.Font.ColorIndex = wdDarkBlue 'Choose Color here, e.g. wdBlack
'Selection.Font.TextColor.RGB = RGB(255, 0, 255) 'To use RGB color, uncomment this line and comment the one above
Next
End Sub
This macro unfortunately does not work in PowerPoint. Could you please provide any solutions for this?
Thank you!
Here's the PowerPoint equivalent:
Sub ColorEquation()
Dim oSlide As Slide
Dim oShape As Shape
For Each oSlide In ActivePresentation.Slides
For Each oShape In oSlide.Shapes
If oShape.HasTextFrame Then
If oShape.TextFrame2.HasText Then
If oShape.TextFrame2.TextRange.MathZones.Length > 0 Then
oShape.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 0, 255)
End If
End If
End If
Next oShape
Next oSlide
End Sub
Use Count instead of Length at line 8.
Sub ColorEquation()
Dim oSlide As Slide
Dim oShape As Shape
For Each oSlide In ActivePresentation.Slides
For Each oShape In oSlide.Shapes
If oShape.HasTextFrame Then
If oShape.TextFrame2.HasText Then
If oShape.TextFrame2.TextRange.MathZones.Count > 0 Then
oShape.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 0, 255)
End If
End If
End If
Next oShape
Next oSlide
End Sub
I have a lot of slides in Powerpoint. All have MS Object Connections to Excel tables. I am looking for a code, to changes the size and position of all this objects. I have some code already. But the problem is its also changes the size and position of texts. Do someone know how to changes it?
Sub ResizeAll()
For Each tSlide In ActiveWindow.Presentation.Slides
tSlide.Select
With tSlide.Shapes.Item(1)
'assume a blank slide with one image added only
.Select
.Height = 72 * 1000.39
.Width = 72 * 10.67
'algin middle (Horizontal Center)
.Left = 100
.Top = ActivePresentation.PageSetup.SlideHeight / 5
End With
Next
End Sub
I'd stay away from using the Selection object. This code checks that the shape is an OLE object, then resizes only that shape. If this doesn't answer your question, please clarify "also changes the size and position of texts".
Sub EnlargeExcelTables()
Dim oSlide As Slide
Dim oShape As Shape
For Each oSlide In ActivePresentation.Slides
For Each oShape In oSlide.Shapes
If oShape.Type = msoLinkedOLEObject Then
With oShape
'Insert Size process here.
End With
End If
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
I have number of slide sets with Excel charts that need to be formatted to be better displayed in PPT (increase font size).
I figured out the code below but can't a way to insert loop so this code is only applied to slides 36 to 45.
I've tried the following code below but doesn't work, I think it's because it references ActivePresentation whilst my formatting code references ActiveWindow but I don't have enought PPT VBA knowledge to fix that.
Dim oPresentation As Presentation
Set oPresentation = ActivePresentation
Dim oSlide As Slide
Dim oSlides As SlideRange
Dim oShape As Shape
Dim slideNumber As Integer
For slideNumber = 36 To 45
>>>REST OF MY CODE INSERTED HERE<<<
Next slideNumber
Sub FormatChartPPT()
'PURPOSE: Increase font size of chart data labels, legend, axes values and categories
Dim ocht As Chart
Dim i As Integer
Dim shp As Shape
'Auto select chart
For Each shp In ActiveWindow.Selection.SlideRange.Shapes
With shp
If .HasChart Then .Select
End With
Next shp
'Apply to selected chart
Set ocht = ActiveWindow.Selection.ShapeRange(1).Chart
'Format data labels
For i = 1 To ocht.SeriesCollection.Count
If ocht.SeriesCollection(i).HasDataLabels Then
With ocht.SeriesCollection(i).DataLabels.Font
.Size = 14
End With
End If
Next i
'Format legend
If ocht.HasLegend Then
With ocht.Legend.Font
.Size = 14
End With
End If
'Format axis values
With ocht.Axes(xlValue).TickLabels.Font
.Size = 14
End With
'Format axis category
With ocht.Axes(xlCategory).TickLabels.Font
.Size = 14
End With
End Sub
You should create a new method that takes a slide and formats the shapes on it as desired. Say we define it as Sub FormatShapes(sld As Slide) (see code later). This method should then be called in your main loop, e.g.:
For SlideNumber = 36 To 45
FormatShapes ActivePresentation.Slides(SlideNumber)
Next SlideNumber
FormatShapes could look like this:
Sub FormatShapes(sld As Slide)
Dim ocht As Chart
Dim shp As Shape
For Each shp In sld.Shapes
If shp.HasChart Then
Set ocht = shp.Chart
... Do shape chart formatting using ocht ...
End If
Next shp
End Sub
This code creates a string of 10 slides, in which each next slide's 2 shapes (number 1 and number 3) are nudged a bit in relation to similar shapes in the previous slide, while one shape (number 2) remains in the same position throughout.
Each nudge is equal to 2 points (pixels?), but I wonder how could I modify this code so that each nudge would be greater than the previous one by one point. For example, the nudge for creating slide 2 would be 2 points, but the nudge for slide 3 will be 3 points, etc.
Sub MovingFlanks()
Dim oPresentation As Presentation
Set oPresentation = ActivePresentation
Dim oSlide As Slide
Dim oSlides As SlideRange
Dim oShape As Shape
Dim slideNumber As Integer
For slideNumber = 1 To 10
Set oSlide = oPresentation.Slides(oPresentation.Slides.Count)
oSlide.Copy
Set oNewSlides = oPresentation.Slides.Paste()
Set oSlide = oNewSlides(1)
Set oShape = oSlide.Shapes(1)
For Each shapeNum In Array(1, 3)
Set oShape = oSlide.Shapes(shapeNum)
oShape.Left = oShape.Left + 2
Next shapeNum
Next slideNumber
End Sub
Just replace:
oShape.Left = oShape.Left + 2
...with:
oShape.Left = oShape.Left + slideNumber
(although you might want to use slideNumber * 10 to make it noticeable).