Will be great to get help,
i've been trying to figure out a way to change height of a plot inside chart in PowerPoint slide, i got a code by which we can change the dimensions of chart, but not plot size.
Can anyone help ..!!
Sub AllChartsResize()
Dim sld As Slide
Dim shp As Shape
Dim sr As Series
Dim chrt As Chart
'r converts cm to points
r = 28.3464567
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.HasChart Then
shp.Height = 15 * r
shp.Width = 26 * r
shp.Left = 7 * r
shp.Top = 2 * r
End If
Next shp
Next sld
End Sub
This is called the PlotArea and can be accessed:
If shp.HasChart Then
Dim pa as PlotArea: set pa = shp.Chart.PlotArea
pa.Height etc.
Now you can change its dimensions as you did with the Shape..
Related
I need help for this case and could not find an answer anywhere on the internet.
Basically, I have a powerpoint slide with hundreds of slides, each containing a picture. I would like this picture to be resized and moved to a specific location.
The code i made resized every picture on each slide.
'''
Sub resizeImage()
Dim sld As Slide
Dim shp As Shape
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
With shp
.Height = 400
.Width = 300
.Left = 45
.Top = 45
End With
Next sld
Next shp
End Sub
'''
I thought that by specifying the image name to resize, i could esssentially resize only that picture since all of them have the name "Content Placeholder 2" and ended up with this code:
'''
Sub resizeImage()
Dim sld As Slide
Dim shp As Shape
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Name = ("Content Placeholder 2") Then
With shp
.Height = 400
.Width = 300
.Left = 45
.Top = 45
End With
End If
Next sld
Next shp
End Sub
'''
I'm guessing the code doesnt run because 'Content Placeholder 2' doesn't exist on the first few slides. But when i add On Error Resume Next, everything is resized. Thank you for any help or advice, greatly appreciated.
"when i add On Error Resume Next, everything is resized" Are you telling use this solves the problem with the photo, or do you mean that all objects are resized, not just the photo? If the latter, you'll need some other identifier for the shape to be resized, just as its starting position. This code checks that the shape top is between 100 and 400, then resizes the shape if it meets those conditions:
Sub resizeImage()
Dim sld As Slide
Dim shp As Shape
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Top > 100 And shp.Top < 400 Then
With shp
.Height = 400
.Width = 300
.Left = 45
.Top = 45
End With
End If
Next sld
Next shp
End Sub
Or, if each slide only has 1 content placeholder, this checks that the first part of the name is correct, then resizes:
Sub resizeImage()
Dim sld As Slide
Dim shp As Shape
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If Left(shp.Name, 19) = "Content Placeholder" Then
With shp
.Height = 400
.Width = 300
.Left = 45
.Top = 45
End With
End If
Next sld
Next shp
End Sub
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
I've just inherited an Excel app that draws an org chart. Each shape is connected by a Line
However, I need to remove the shadow that is drawn when each line is added. How do I get a collection of Lines so that I can do something like
Line.Shadow.Transparency = 1.0
I'm a bit of a vba newbie :-)
This should do the trick - it loops through all shapes, checks if they're a line, then removes the shadow.
Sub test()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim shapeObj
For Each shapeObj In ActiveSheet.Shapes
If shapeObj.Type = 9 Then
Dim objName$
objName = shapeObj.Name
ws.Shapes.Range(Array(objName)).Shadow.Visible = msoFalse
End If
Next shapeObj
End Sub
Edit: Turns out, per OP, the shapes are grouped, so he used this to get it:
Sub RemoveLineShadows()
For Each Shp In ORG.Shapes
If Shp.Type = msoGroup Then
For X = 1 To Shp.GroupItems.Count
If Shp.GroupItems(X).Type = msoLine Then
Shp.GroupItems(X).Shadow.Transparency = 1
End If
Next X
End If
Next Shp
End Sub
Sub qqq()
Dim x As Shape
For Each x In ActiveSheet.Shapes
x.Shadow.Visible = msoFalse
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