I have several PowerPoint slides with objects (arrows and rectangles) I like to display and hide. At the moment I just use
ActivePresentation.Slides("Slide100").Shapes("Rectangle 99").Visible = False or True
ActivePresentation.Slides("Slide100").Shapes("Straight Arrow Connector 118").Visible = False or True
Now it can be that one rectangle or arrow has to be deleted in that template. This leads to VBA errors when you run the macro because the rectangle or arrow couldn't be found. Is there any way to write a macro to check all the used rectangles and arrows and then hides or displays them all instead of using single variables?
I found something like this:
For Each sObject In ActivePresentation.Slides(2).Shapes
sObject.Visible = False
Next
But I just need to hide rectangles and arrows, nothing more.
Best regards
Peter
Take that loop as a starting point and apply some logic within it. There are two properties of the shape that could be useful, autoshapetype and name
Two examples below:
For Each shp In ActivePresentation.Slides(x).Shapes
If InStr(1, shp.Name, "Rectangle") > 0 Then
shp.Visible = False
End If
Next shp
or
For Each shp In ActivePresentation.Slides(x).Shapes
If shp.AutoShapeType = msoShapeRectangle Then
shp.Visible = False
End If
Next shp
This will hide all rectangle types and a subset of arrow types across all slides in the active presentation:
' PowerPoint VBA Macro
' Purpose : hide rectangles and shapes across slides
' Written by : Jamie Garroch of YOUpresent Ltd. http://youpresent.co.uk.
Sub HideRectanglesAndArrows()
Dim oSld As Slide
Dim oShp As Shape
For Each oSld In ActivePresentation.Slides
For Each oShp In oSld.Shapes
If oShp.Type = msoAutoShape Then
Select Case oShp.AutoShapeType
' Basic Arrows (4)
Case msoShapeUpArrow, msoShapeDownArrow, msoShapeLeftArrow, msoShapeRightArrow
oShp.Visible = msoFalse
' Double Arrows (2)
Case msoShapeUpDownArrow, msoShapeLeftRightArrow
oShp.Visible = msoFalse
' Add other arrow types as required
'
' Basic Rectangles (1)
Case msoShapeRectangle
oShp.Visible = msoFalse
' Rounded Rectangles (4)
Case msoShapeRound1Rectangle, msoShapeRound2DiagRectangle, msoShapeRound2SameRectangle, msoShapeRoundedRectangle
oShp.Visible = msoFalse
' Snipped Rectangles (4)
Case msoShapeSnip1Rectangle, msoShapeSnip2DiagRectangle, msoShapeSnip2SameRectangle, msoShapeSnipRoundRectangle
oShp.Visible = msoFalse
End Select
End If
Next
Next
End Sub
You can then add logic to delete specific shapes using the .Name property or position properties (.Left, .Top) or size properties (.Width, .Height). If you want o be more elaborate (users can change the names of shapes) then you could add Tags to shapes to identify them in a way that the user cannot change and then write a procedure to check the .Tags property in your logic.
Related
I would like to set font type (calibri)of text( where ever there is an alphabet in presentation, it should be "calibri") in every slide by running the single macro using VBA. The problem is, it is unable to change the font present in 'chart', 'flow chart diagram' where it has boxes like rectangle, round cornered rectangles etc.How to manipulate that text as well? Please help!
As shown in the image the font of climate in rectangle is not changing.Different font type in rectangle
The solution to this problem is pretty tedious as there are so many different types of shapes and textranges to account for. I can't post my entire solution as I don't own the intellectual property, but this should get you on the right track:
Sub MakeFontsThemeFonts()
Dim oSld As Slide
Dim oShp As Shape
Dim oShp2 As Shape
Dim oTxtRange As TextRange
' Set majorFont and minorFont to Calibri
ActivePresentation.SlideMaster.Theme.ThemeFontScheme.majorFont.Item(1) = "Calibri"
ActivePresentation.SlideMaster.Theme.ThemeFontScheme.minorFont.Item(1) = "Calibri"
For Each oSld in ActivePresentation.Slides
For Each oShp in oSld.Shapes
If oShp.HasChart Then
' Call your chart handler
ElseIf oShp.HasTable Then
' Call your table handler
ElseIf oShp.HasSmartArt Then
' Call your SmartArt handler
ElseIf oShp.HasTextFrame Then
If oShp.HasText Then
Set oTxtRange = oShp.TextFrame.TextRange
Call RefontTextRange (oTxtRange)
End If
ElseIf oShp.Type = msoGroup Then
For Each oShp2 in oShp.GroupItems
If oShp2.Type = ... Then
' And so on, you wind up having to check for
' everything that's grouped all over again
End If
Next
End If
Next
Next
End Sub
Sub RefontTextRange (oTxtRange As TextRange)
With oTxtRange.Font
' Sets the textrange to the body font. If you want to make some stuff the heading font and some stuff the body font, you need to do more checking before sending here
.Name = "+mn-lt"
End With
End Sub
So that's the start of the solution, but this will get maddening for a few reasons. For tables, you'll have to parse the TextRange of every cell individually and pass those TextRanges on to your Refont sub. For charts, you may have to check for every imaginable chart element before setting your TextRange and refonting (my case was more complex than just setting the font to be the theme font, and I didn't have success trying to format the ChartArea all at once).
Are you having the issue with "floating" shapes inside of a chart? When you say "flow chart," is that an embedded Visio diagram or native SmartArt? There are many ways to skin this cat, but the solution will require you to identify every possible type of text container that can be accessed using VBA.
Here's one more tip that might help you get at those floating shapes within charts:
oShp.Chart.Shapes(1).TextFrame.TextRange.Font.Name = "+mn-lt"
But of course first you need to make sure you've got a chart, that it's got shapes in it, that those shapes have a textframe...
If you leverage the features already built in to PowerPoint, you won't need any code at all. The font theme is built to handle these situations. Format all text with font choices that include the (body) or (headings) tag in the name. Then when you switch the font theme from Arial to Calibri, all text, including charts and SmartArt, will be updated.
For a presentation that is already formatted with local formatting instead of using a font theme, unzipping the file to XML and using a good text editor's Find and Replace functions, you can quickly replace all instances of a font without programming.
Find 'typeface="Arial"'
Replace 'typeface="Calibri"'
Then rezip the files and restore the file ending.
It seems you only need to change the master slides (including notesmaster, slidemaster), instead of working on each slide. Here are my codes
Sub ChangeFont()
' https://stackoverflow.com/a/57212464/2292993
' affect SmartArt font
ActivePresentation.SlideMaster.Theme.ThemeFontScheme.majorFont.Item(1) = "Garamond"
ActivePresentation.SlideMaster.Theme.ThemeFontScheme.minorFont.Item(1) = "Garamond"
For i = 1 To Application.ActivePresentation.NotesMaster.Shapes.Count
With Application.ActivePresentation.NotesMaster.Shapes(i).TextFrame.TextRange.Font
.Name = "Garamond"
If Application.ActivePresentation.NotesMaster.Shapes(i).Name Like "Notes*" Then
.Bold = msoFalse
.Size = 16
End If
End With
Next i
' http://skp.mvps.org/2007/ppt003.htm
' Each design contained a slide master and possibly a title master. Several designs could be stored within a presentation.
' The slide master can contain several custom layouts which can be fully customized.
For Each oDesign In ActivePresentation.Designs
' slide master
Set sm = oDesign.SlideMaster
For j = 1 To sm.Shapes.Count
If sm.Shapes(j).HasTextFrame Then
With sm.Shapes(j).TextFrame.TextRange.Font
.Name = "Garamond"
End With
End If
Next j
' custom layouts
lngLayoutCount = oDesign.SlideMaster.CustomLayouts.Count
For I = 1 To lngLayoutCount
Set oCL = oDesign.SlideMaster.CustomLayouts(I)
For j = 1 To oCL.Shapes.Count
If oCL.Shapes(j).HasTextFrame Then
With oCL.Shapes(j).TextFrame.TextRange.Font
.Name = "Garamond"
End With
End If
Next j
Next I
Next
End Sub
I'm just poking around in VBA with PowerPoint and know that what I want to do can be done. I just don't know the write calls/sytanx to use!
I want a macro that will run through all the slides in a presentation and move the video object to specific spot on the slide. The spot will be the same on all slides.
It would be very helpful if someone could show me how to do this! Or at least point me in the right direction. Thanks!
Here's what I found for doing something on every slide
Sub EveryTextBoxOnSlide()
' Performs some operation on every shape that contains text on every slide
' (doesn't affect charts, tables, etc)
Dim oSh As Shape
Dim oSl As Slide
On Error GoTo ErrorHandler
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
With oSh
If .HasTextFrame Then
If .TextFrame.HasText Then
' If font size is mixed, don't touch the font size
If .TextFrame.TextRange.Font.Size > 0 Then
.TextFrame.TextRange.Font.Size = .TextFrame.TextRange.Font.Size + 2
End If
End If
End If
End With
Next ' shape
Next ' slide
NormalExit:
Exit Sub
ErrorHandler:
Resume Next
End Sub
And this is something I found to move the object to desired location (here's where I don't know what to call the video object)
With ActiveWindow.Selection.ShapeRange
.Left = 640 'change the number for desired x position
.Top = 75 'change the number for desired y position
End With
End Sub
Sub ll()
End Sub
So basically, I want to run the last piece as a function of the first one instead of shapes with text. Does that make sense?
I've done some programming in the past, mainly with actionscript and Flash. I could probably write out some basic functions, just not sure how to run it in VBA without learning a whole new language. Which I don't want to do, since I'm an instructional designer and don't have the free time to learn it! :)
Here's a little function that'll return True if the shape you pass to it is a video, and a bit of example code to test it with:
Function IsVideo(oSh As Shape) As Boolean
If oSh.Type = msoMedia Then
If oSh.MediaType = ppMediaTypeMovie Then
IsVideo = True
Exit Function
End If
End If
' Things get a little trickier if the movie is in a placeholder
' Is it a placeholder? and is it a media object?
If oSh.Type = msoPlaceholder Then
If oSh.PlaceholderFormat.ContainedType = msoMedia Then
' it's a media object, but we don't know if it's
' a movie or sound or what, so we duplicate it
' then look at the duplicate (which is now a copy
' of the placeholder content but is not a placeholder itself)
With oSh.Duplicate
If .Type = msoMedia Then
If .MediaType = ppMediaTypeMovie Then
IsVideo = True
End If
End If
' and delete the duplicate
.Delete
End With
End If
End If
End Function
Sub thing()
Dim oSl As Slide
Dim oSh As Shape
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
If IsVideo(oSh) Then
oSh.Left = 0
End If
Next
Next
End Sub
Now you're getting somewhere!
I don't know what kind of shape holds your video, so this modification should help you identify it.
Sub EveryTextBoxOnSlide()
Dim oSh As Shape
Dim oSl As Slide
On Error GoTo ErrorHandler
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
With oSh
.Select
End With
Next
Next
NormalExit:
Exit Sub
ErrorHandler:
Resume Next
End Sub
While there is no need whatsoever to use the .Select in your final code, this is only here to help you identify which shape actually holds the video. Put a breakpoint (F9) on that line and run your code (F5), then debug through it with F8 to execute one line at a time and run through your loop looking at each shape until you see that your video has been selected.
Once your video has been selected look at the various properties (using the Immediate Window of the IDE) of oSh until you find the uniqueness that identifies this is your video. (There may be some property about the content type of the shape, or a link on where to find the contents that contains the text string ".avi", ".mpg", ".flv", etc - there will be some sort of identifier you can find.)
Once you've identified what makes the shape the holder of a video, replace
.Select
with
If {my video containing shape criteria is true} Then
With .Selection.ShapeRange
.Left = 640 'change the number for desired x position
.Top = 75 'change the number for desired y position
End With
End If
Changing the values (as commented) to whatever it is that you need.
Important Note: It is very good that your sample code has some error handling built in, but all this error handler is doing is sweeping any errors under the rug. This particular handler is the very long form version of On Error Resume Next which does have its uses, but in very, very limited situations.
As you get your code working, you'll actually want to put something useful in the ErrorHandler: section, but that's the topic for a whole new question.
Ok, here is how I modified the code supplied above to do this in my case:
Sub EveryTextBoxOnSlide() ' Performs some operation on every shape that contains text on every slide ' (doesn't affect charts, tables, etc) Dim oSh As Shape Dim oSl As Slide On Error GoTo ErrorHandler
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
With oSh
If .Type = msoMedia Then
If .MediaType = ppMediaTypeMovie Then
.PictureFormat.Crop.PictureHeight = 236
.PictureFormat.Crop.PictureWidth = 314.2115
.PictureFormat.Crop.PictureOffsetX = 8.737323
.PictureFormat.Crop.PictureOffsetY = 0
.PictureFormat.Crop.ShapeHeight = 236.3478
.PictureFormat.Crop.ShapeWidth = 163
.PictureFormat.Crop.ShapeLeft = 796.6956
.PictureFormat.Crop.ShapeTop = 0
End If
End If
End With
Next ' shape Next ' slide
NormalExit: Exit Sub
ErrorHandler: Resume Next
End Sub
I think it's a simple question for anybody with some VBA skills oder PowerPoint-pro's:
I have a presentation like a quiz, and I like to offer three jokers like in WWTBAM.
So I created three buttons and i made the 50:50 button, that on click an animation starts so, that to wrong answers are hidden. So I now just want to, that if you clicked the joker-button on one slide, it have to be removed / disabled / crossed on ALL other following slides.
Is there anybody who can show me a simple snippet which will do that?
That would be really great.
Thanks!
This should get you going in the right direction:
Option Explicit
' The name of the shape(s) to search for
' (name shapes in the Selection Pane : Alt+F10 for PowerPoint 2010 and later)
Public Const ShapeName = "50/50"
' Purpose: Macro to HIDE all shapes on all slides that match the specified name
' Usage: Assign to any shape(s) on a slide via the Insert Tab / Action / Mouse Click / Run Macro
' Author: Jamie Garroch of YOUpresent Ltd. (http://youpresent.co.uk/)
Public Sub HideAll()
Dim oSld As Slide
Dim oShp As Shape
For Each oSld In ActivePresentation.Slides
For Each oShp In oSld.Shapes
If oShp.Name = ShapeName Then oShp.Visible = msoFalse
Next
Next
End Sub
' Purpose: Macro to SHOW all shapes on all slides that match the specified name
' Usage: Assign to any shape(s) on a slide via the Insert Tab / Action / Mouse Click / Run Macro
' Author: Jamie Garroch of YOUpresent Ltd. (http://youpresent.co.uk/)
Public Sub ShowAll()
Dim oSld As Slide
Dim oShp As Shape
For Each oSld In ActivePresentation.Slides
For Each oShp In oSld.Shapes
If oShp.Name = ShapeName Then oShp.Visible = msoTrue
Next
Next
End Sub
I am searching for a way to perform the following operation on two shapes that are selected in powerpoint.
Take the shape in the foreground (i.e. the shape that is more in the front) of the two shapes and left and bottom align it with the one that is in the background.
2. Delete the shape in the background.
What I have got so far is the operation for the bottom and left align which looks as follows:
Sub LeftandBottom_Align()
ActiveWindow.Selection.ShapeRange.Align msoAlignLefts, False
ActiveWindow.Selection.ShapeRange.Align msoAlignBottoms, False
End Sub
How do i get the delete-part done?
A little bit of basic explanation would be great
You can delete the rearmost shape like so:
Dim oBackShape As Shape
With ActiveWindow.Selection
' Get a reference to the rearmost of the two selected shapes
' so you can use it later to delete the shape
If .ShapeRange(1).ZOrderPosition > .ShapeRange(2).ZOrderPosition Then
Set oBackShape = .ShapeRange(2)
Else
Set oBackShape = .ShapeRange(1)
End If
' Align the shapes
' .Align may not always work the way you'd expect it to
' so if not, ask
.ShapeRange.Align msoAlignLefts, False
.ShapeRange.Align msoAlignBottoms, False
End With
' Delete the rearmost shape
oBackShape.Delete
You can use Shapes ZOrderPosition Property to determine which shape is in the background
Sub LeftandBottom_Align()
ActiveWindow.Selection.ShapeRange.Align msoAlignLefts, False
ActiveWindow.Selection.ShapeRange.Align msoAlignBottoms, False
Dim i As Integer
i = 2 'Assuming two shapes
While i >= 1
With ActiveWindow.Selection.ShapeRange(i)
If (.ZOrderPosition = 1) Then
.Delete
Exit Sub
End If
i = i - 1
End With
Wend
End Sub
I am trying to remove all the shadow effects from all the textframes in the any slides of the presentation via a macro .
The below macro is running well with powerpoint 2007 but not working with 2010.
Sub NoTextShadows()
Dim oSld As Slide
Dim oShp As Shape
For Each oSld In ActivePresentation.Slides
For Each oShp In oSld.Shapes
If oShp.HasTextFrame Then
If oShp.TextFrame.HasText Then
oShp.TextFrame.TextRange.Font.Shadow = msoFalse
oShp.Shadow.Visible = msoFalse
End If
End If
Next oShp
Next oSld
End Sub
Please suggest any idea to workaround this. Thanks.
I made some tests and I found out that shadows in PowerPoint 2010 can appear for Text (for specific) and for shapes in general. It's strange that two shadows can be applied to the shape independently, but only one of them could be removed by Macro. Here is what I did to remove one layer of shadow :
oShp.Shadow.Size = 0
OShp.Shadow.Blur = 0
oShp.Shadow.Visible = msoFalse
Try adding these lines inside your main For Loop and see
For more information, Working with Properties of the ShadowFormat Class in Office 2010