I have a large PPT file that I need to format to certain specifications. I need all font to be Arial 14 unless the text is underlined. If the text is underlined I need the font to be 32. Here's my attempt at it so far, I have the Arial 14 part working, but I can't figure out how to select just the underlined text. If anyone has any thoughts it would be appreciated. I also have zero experience with VBA outside of this project, though I am familiar with c++
Sub use()
Dim s As Slide
Dim shp As Shape
For Each s In ActivePresentation.Slides
For Each shp In s.Shapes
If shp.HasTextFrame Then
With shp
.TextFrame.TextRange.Font.Name = "Arial"
.TextFrame.TextRange.Font.Size = 14
If .TextFrame.TextRange.Font.Underline = True Then
.TextFrame.TextRange.Font.Size = 32
End If
With .TextFrame.TextRange
.ParagraphFormat.SpaceBefore = 0
End With
End With
End If
Next shp
Next s
End Sub
Try this
Sub Sample()
Dim oSl As Slide
Dim oSh As Shape
Dim x As Long
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
If oSh.HasTextFrame Then
If oSh.TextFrame.HasText Then
For x = 1 To Len(oSh.TextFrame.TextRange.Text)
If oSh.TextFrame.TextRange.Characters(x, 1).Font.Underline = True Then
With oSh.TextFrame.TextRange.Characters(x, 1)
.Font.Size = 32
End With
End If
Next
End If
End If
Next
Next
End Sub
Screenshot
Related
I'm trying to change the font of all the text in a PowerPoint Presentation depending on what font a user inputs but when I try it doesn't change anything. Where am I going wrong? Is there a nicer way to implement this... say with a font dropdown box or something? As I want to also implement the font size/bold/italic etc too. Thanks!
Sub ChangeFont()
Dim bpFontName As String
bpFontName = InputBox("What font would you like to change EVERYTHING to?")
With ActivePresentation
For Each Slide In .Slides
For Each Shape In Slide.Shapes
With Shape
If .HasTextFrame Then
If .TextFrame.HasText Then
.TextFrame.TextRange.Font.Name = bpFontName
'Set font size below
.TextFrame.TextRange.Font.Size = 30
'Set if you want the font bold below - msoFalse = no
.TextFrame.TextRange.Font.Bold = msoTrue
'Set if you want the font bold below - msoFalse = no
.TextFrame.TextRange.Font.Italic = msoTrue
End If
End If
End With
Next
Next
End With
End Sub
For starters, you didn't dim some of your variables, and it's bad practice to use reserved words (Slide, Shape) as variable names. I've fixed it like so:
Sub ChangeFont()
Dim bpFontName As String
Dim oSld as Slide
Dim oSh as Shape
bpFontName = InputBox("What font would you like to change EVERYTHING to?")
With ActivePresentation
For Each oSld In .Slides
For Each oSh In oSld.Shapes
With oSh
If .HasTextFrame Then
If .TextFrame.HasText Then
.TextFrame.TextRange.Font.Name = bpFontName
'Set font size below
.TextFrame.TextRange.Font.Size = 30
'Set if you want the font bold below - msoFalse = no
.TextFrame.TextRange.Font.Bold = msoTrue
'Set if you want the font bold below - msoFalse = no
.TextFrame.TextRange.Font.Italic = msoTrue
End If
End If
End With
Next
Next
End With
End Sub
I'm a new stackoverflow user so I'm not sure if I'm doing this right, but I'm trying to post a question on a previously given solution by Steve Rindsberg. I don't have enough reputation to comment, and there doesn't appear to be a way to message another user directly, so I'm posting a new question here.
I can't seem to get the code below to work. I'm using PowerPoint O365 Version 1901 and I have two type of shapes I'm trying to convert, msoChart and msoLinkedOLEObject (some Excel worksheets). I originally changed ppPasteEnhancedMetafile to ppPastePNG because I want PNG's, but it fails with either.
Here is the code:
Sub ConvertAllShapesToPic()
Dim oSl As Slide
Dim oSh As Shape
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
' modify the following depending on what you want to
' convert
Select Case oSh.Type
Case msoChart, msoEmbeddedOLEObject, msoLinkedOLEObject
ConvertShapeToPic oSh
Case msoPlaceholder
If oSh.PlaceholderFormat.ContainedType = msoEmbeddedOLEObject _
Or oSh.PlaceholderFormat.ContainedType = msoLinkedOLEObject _
Or oSh.PlaceholderFormat.ContainedType = msoChart _
Then
ConvertShapeToPic oSh
End If
Case Else
End Select
Next
Next
End Sub
Sub ConvertShapeToPic(ByRef oSh As Shape)
Dim oNewSh As Shape
Dim oSl As Slide
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 < oSh.ZOrderPosition
End With
oSh.Delete
End Sub
I noticed if I run ConvertAllShapesToPic from an link/action in Slide Show mode, it doesn't complete and fails silently. If I add a Command Button (ActiveX control) and run it from there I get the following:
Run-time error '-2147188160 (80048240)':
Shapes (unknown member): Invalid request. The specified data type is unavailable.
It's failing on Set oNewSh = sld.Shapes.PasteSpecial(ppPastePNG)(1). After the error, if I go back to the slide and Ctrl-V I get the image, so I know it's working up to that point.
I've tried various solutions I found online for this such as adding DoEvents or ActiveWindow.Panes(1).Activate after the copy, but it doesn't seem to make a difference. Any suggestions?
Thanks
I found some other code to convert the charts and then I break links on the worksheets which automatically turns them in to images.
One thing I figured out was you must be out of slide show mode to break msoLinkedOLEObject links. I'm not 100% sure why... but this is the code that works for me:
Sub DoStuff()
Call LinkedGraphsToPictures
ActivePresentation.SlideShowWindow.View.Exit
Call BreakAllLinks
End Sub
Sub LinkedGraphsToPictures()
Dim shp As Shape
Dim sld As Slide
Dim pic As Shape
Dim shp_left As Double
Dim shp_top As Double
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Type = msoChart Then
'Retrieve current positioning
shp_left = shp.Left
shp_top = shp.Top
'Copy/Paste as Picture
shp.Copy
DoEvents
sld.Shapes.PasteSpecial DataType:=ppPastePNG
Set pic = sld.Shapes(sld.Shapes.Count)
'Delete Linked Shape
shp.Delete
'Reposition newly pasted picture
pic.Left = shp_left
pic.Top = shp_top
End If
Next shp
Next sld
End Sub
Sub BreakAllLinks()
Dim shp As Shape
Dim sld As Slide
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Type = msoLinkedOLEObject Then
shp.LinkFormat.BreakLink
End If
Next shp
Next sld
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
I have a powerpoint presentation with subtitles in white and yellow text in 1 textbox per slide (white is up, yellow follows). I would like to replace white text with a white dot ("."). Do I need to make a variable and make it count white characters and delete from front?
This is my script so far:
Sub RemoveWhiteText()
Dim oSl As Slide
Dim oSh As Shape
With ActivePresentation
For Each oSl In .Slides
For Each oSh In oSl.Shapes
With oSh
If .HasTextFrame Then
If .TextFrame.HasText Then
If TextRange.Font.Color = vbWhite Then
oSh.TextFrame.Text
End If
End If
End If
End With
Next
Next
End With
End Sub
Please, read my comment to the question. I suggested there to loop through the collection of chars till the color of font is white.
Try this:
Sub RemoveWhiteText()
Dim oSl As Slide, oSh As Shape, oTr As TextRange, i As Long
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
If oSh.HasTextFrame Then
If oSh.TextFrame.HasText Then
Set oTr = oSh.TextFrame.TextRange
i = 1
Do While oTr.Characters(1, i).Font.Color = vbWhite
i = i + 1
Loop
'MsgBox oTr.Characters(1, i - 1).Text
If i > 1 Then oTr.Characters(1, i - 1).Text = "."
Set oTr = Nothing
End If
End If
Next
Next
End Sub
Each text block of distinct formatting is a Run. In your case, the first run has font color white. You can use that info to run a loop as follows:
Sub StripLeadingWhiteText()
Dim sld As Slide
Dim shp As Shape
Dim rn As TextRange2
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.HasTextFrame Then
If shp.TextFrame2.HasText Then
Set rn = shp.TextFrame2.TextRange.Runs(1)
If rn.Font.Fill.ForeColor.RGB = vbWhite Then
rn.Text = "."
End If
End If
End If
Next
Next
End Sub`