I have code for changing fonts but it's not working as it should :( I want to loop thrue all presentation and change font size and style by InputBox. Anyone can help me with this? Thanks so much!
Sub FormatTextBoxes()
Dim intSlide As Integer
Dim strNotes As String
Dim nts As TextRange
Dim strFont, intSize
intSize = InputBox("Please enter font size", "fontsize", "12")
strFont = InputBox("Please enter font", "font type", "Calibri")
With ActivePresentation
For intSlide = 1 To .Slides.Count
Set nts = ActivePresentation.Slides(intSlide).NotesPage. _
Shapes.Placeholders(2).TextFrame.TextRange
With nts
If intSize = "" Then intSize = 12
.Paragraphs.Font.Size = intSize
.Paragraphs.Font.Name = strFont
End With
Next intSlide
End With
MsgBox ("FormatNotes uitgevoerd")
End Sub
This will change the font size for all slide objects on all slides:
Option Explicit
' *************************************************************
' Purpose : PowerPoint macro to change font size for all shapes
' on all slides across the active presentation
' Author : Jamie Garroch of http://YOUpresent.co.uk/
' Inputs : None
' Outputs : None
' *************************************************************
Sub ChangeFontSizeForSlideShapes()
Dim oSld As Slide
Dim oShp As Shape, oGrpItem As Shape
For Each oSld In ActivePresentation.Slides
For Each oShp In oSld.Shapes
If oShp.Type = msoGroup Then
For Each oGrpItem In oShp.GroupItems
If oGrpItem.HasTextFrame Then
oGrpItem.TextFrame.TextRange.Font.Size = 12
End If
Next ' oGrpItem
Else
If oShp.HasTextFrame Then
oShp.TextFrame.TextRange.Font.Size = 12
End If
End If
Next ' oShp
Next ' oSld
End Sub
Related
Please can any one help in deleting the watermark in all slide in attached code. I am trying but got error.
Sub WaterMarkwide()
Dim intI As Integer
Dim intShp As Integer
Dim strWaterMark As String
strWaterMark = InputBox("Please Enter the text you want to appear as Watermark", _
"Enter Text Here:")
With ActivePresentation.Slides.Item(1)
.Shapes.AddLabel msoTextOrientationHorizontal, _
.Master.Width - 700, .Master.Width - 750, 20, 80
intShp = .Shapes.Count
.Shapes.Item(intShp).TextFrame.TextRange = strWaterMark
.Shapes.Item(intShp).TextEffect.FontName = Arial
.Shapes.Item(intShp).TextEffect.FontSize = 80
.Shapes.Item(intShp).TextEffect.PresetTextEffect = msoTextEffect1
.Shapes.Item(intShp).Rotation = 45
.Shapes.Item(intShp).Copy
End With
For intI = 2 To ActivePresentation.Slides.Count
With ActivePresentation.Slides(intI)
.Shapes.PasteSpecial ppPastePNG
intShp = .Shapes.Count
End With
Next intI
End Sub
The key here is understanding that there is no "watermark" feature in PowerPoint, as there is in MS Word. The code you've used correctly adds a shape to each slide that can be used as a watermark (from this SO answer).
The problem is: how can you detect which shape is the "watermark" shape after it's been added?
For this solution, I modified your original code to add a Tag to each shape that acts as a watermark. Then, when you run the code to delete, it's easy to look for the tag, identify the shape as a watermark, and delete it.
Option Explicit
Const WATERMARK_TAG As String = "WATERMARK"
Const WATERMARK_VALUE As String = "Watermark"
Sub WaterMarkwide()
Dim strWaterMark As String
strWaterMark = InputBox("Please Enter the text you want to appear as Watermark", _
"Enter Text Here:")
Dim intShp As Integer
With ActivePresentation.Slides.Item(1)
.Shapes.AddLabel msoTextOrientationHorizontal, _
.Master.Width - 700, .Master.Width - 750, 20, 80
intShp = .Shapes.Count
End With
With ActivePresentation.Slides.Item(1).Shapes.Item(intShp)
.TextFrame.TextRange = strWaterMark
.TextEffect.FontName = "Arial"
.TextEffect.FontSize = 80
.TextEffect.PresetTextEffect = msoTextEffect1
.Rotation = 45
.Tags.Add WATERMARK_TAG, WATERMARK_VALUE
.Copy
End With
Dim intI As Integer
For intI = 2 To ActivePresentation.Slides.Count
With ActivePresentation.Slides(intI)
Dim shp As Shape
.Shapes.PasteSpecial ppPastePNG
Set shp = .Shapes.Item(.Shapes.Count)
intShp = .Shapes.Count
shp.Tags.Add WATERMARK_TAG, WATERMARK_VALUE
End With
Next intI
End Sub
Sub DeleteWatermark()
Dim sld As Slide
For Each sld In ActivePresentation.Slides
Dim shp As Shape
For Each shp In sld.Shapes
If shp.Tags.Count > 0 Then
Dim value As String
value = shp.Tags.Item(WATERMARK_TAG)
If value = WATERMARK_VALUE Then
shp.Delete
End If
End If
Next shp
Next sld
End Sub
I have put together an e-learning module. I am still very new at vba though. I am trying to make a dynamic main menu which contains multiple text boxes. If the text in a text box matches the title of a slide, that shape should then then be hyperlinked to the corresponding slide. Ideally, the text boxes on the Main Menu would contain the names of Sections and hyperlink to the first slide in the named section, but I couldn't figure that out, so instead I made the title of the first slide in each section match the text. I've searched and searched and gotten as close as I could. I am hoping someone can help me finish it. I have gotten past several errors, and have the text hyperlinked, however all linked take the user to the last slide in the presentation instead of the proper slide. Thank you in advance for any guidance!!
Here is the code:
Sub TestMe()
'Original Source: http://www.steverindsberg.com/pptlive/FAQ00056.htm
Dim aSl As Slide 'active slide
Dim dSl As Slide 'destination slide
Dim Slde As Slide
Dim oSh As Shape
Dim aSl_ID As Integer
Dim aSl_Index As Integer
Dim dSl_ID As Integer
Dim dSl_Index As Integer
Dim sTextToFind As String
Dim hypstart As String
Dim Titl As String
Set aSl = Application.ActiveWindow.View.Slide 'active slide
aSl_Index = Application.ActiveWindow.View.Slide.SlideIndex 'active slide index
' Set ActiveSld_Index =
' Set DestinationSld_ID = oSl.SlideID
' Set DestinationSld_Index = oSl.SlideIndex
For Each oSh In aSl.Shapes
'If IsSafeToTouchText(oSh) = True Then
sTextToFind = oSh.TextFrame.TextRange.Text
'loop through slides looking for a title that matches the text box value
On Error Resume Next
Set dSl = FindSlideByTitle(sTextToFind)
' get the information required for the hyperlink
dSl_ID = CStr(dSl.SlideID)
dSl_Index = CStr(dSl.SlideIndex)
' find the text string in the body
hypstart = InStr(1, sTextToFind, sTextToFind, 1)
'make the text a hyperlink
With oSh.TextFrame.TextRange.Characters(hypstart, Len(sTextToFind)).ActionSettings(ppMouseClick).Hyperlink
.SubAddress = dSl_ID & "," & dSl_Index & "," & sTextToFind
End With
'End If
Next oSh
End Sub
Public Function FindSlideByTitle(sTextToFind As String) As Slide
'Source: http://www.steverindsberg.com/pptlive/FAQ00056.htm
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 Not .TextFrame.TextRange.Text Is Nothing Then
'myPres.Slides(1).Shapes.Title.TextFrame.TextRange
On Error Resume Next
If UCase(.TextFrame.TextRange.Text) = UCase(sTextToFind) Then
'If UCase(.TextRange.Text) = UCase(sTextToFind) Then
Set FindSlideByTitle = oSl
'End If
End If
'End If
End With
Next
Next
End With
End Function
Public Function IsSafeToTouchText(pShape As Shape) As Boolean
'Source: http://www.steverindsberg.com/pptlive/FAQ00056.htm
On Error GoTo ErrorHandler
If pShape.HasTextFrame Then
If pShape.TextFrame.HasText Then
' Errors here if it's a bogus shape:
If Len(pShape.TextFrame.TextRange.Text) > 0 Then
' it's safe to touch it
IsSafeToTouchText = True
Exit Function
End If ' Length > 0
End If ' HasText
End If ' HasTextFrame
Normal_Exit:
IsSafeToTouchText = False
Exit Function
ErrorHandler:
IsSafeToTouchText = False
Exit Function
End Function
Here is the revised code. I have gone in circles and am now stuck. Any suggestions are much appreciated!
After I restored the original function (FindSlideByTitle), I kept getting an error on got an error on .textframe.textrange, making me think that the type of shape I used on my slide (freeform) needed TextFrame2, so I edited that, which fixed the error, but since then I've not been able to make the hyperlink work and have tried instead to use GoTo Slide by including the parent.
I even tried making an array of all freeform shapes on the slide, but I'm still new at this and perhaps I don't fully understand the concepts yet. As it currently stands, I don't get any errors, however, when I click one of the shapes, the shape's appearance changes from the click, but it doesn't go anywhere.
I have also included an image of the actual slide.
Sub TestLinkShapesToSlideTitles()
Dim aSl, dSl, oSl As Slide 'active slide, destination slide
Dim oSh As PowerPoint.Shape
Dim aSl_ID, dSl_ID As Integer
Dim aSl_Index, dSl_Index As Long
Dim dSl_Title, hypstart, Titl As String
Dim sTextToFind As String
Dim numshapes, numFreeformShapes As Long
Dim FreeformShpArray As Variant
Dim ShpRange As Object
Dim oPres As Presentation
Set aSl = Application.ActiveWindow.View.Slide 'active slide
aSl_Index = Application.ActiveWindow.View.Slide.SlideIndex 'active slide index
''''''''''''''''''''''''''''
'In this section I tried to make an array of all the freeform shapes on the slide, thinking that would help.
With aSl.Shapes
numshapes = .Count
'Continues if there are Freeform shapes on the slide
If numshapes > 1 Then
numFreeformShapes = 0
ReDim FreeformShpArray(1 To numshapes)
For i = 1 To numshapes
'Counts the number of Freeform Shapes on the Slide
If .Item(i).Type = msoFreeformShape Then
numFreeformShapes = numFreeformShapes + 1
FreeformShpArray(numFreeformShapes) = .Item(i).Name
End If
Next
'Adds Freeform Shapes to ShapeRange
If numFreeformShapes > 1 Then
ReDim Preserve FreeformShpArray(1 To numFreeformShapes)
Set ShpRange = .Range(FreeformShpArray)
'asRange.Distribute msoDistributeHorizontally, False
End If
End If
End With
''''''''''''''''''''''''''
On Error Resume Next
'Loop through all the shapes on the active slide
For Each oSh In aSl.Shapes
If oSh.Type = msoFreeform Then 'oSh.Type = 5
'If oSh.HasTextFrame Then
If oSh.TextFrame2.HasText Then 'results in -1
With oSh
sTextToFind = .TextFrame2.TextRange.Characters
'sTextToFind results in "Where to Begin"
'.TextFrame2.TextRange.Characters results in "Learn the Lingo", which is the shape after Where to Begin.
End With
End If
'End If
'If IsSafeToTouchText(oSh) = True Then
'With oSh.TextFrame
'sTextToFind = .TextRange.Characters.Text
'loop through slides looking for a title that matches the text box value
'For Each oSl In ActivePresentation.Slides
'If oSl.Shapes.HasTitle Then
'Titl = Slde.Shapes.Title.TextFrame.TextRange <<<<< I kept getting the error here...
On Error Resume Next
Set dSl = FindSlideByTitle_Original(sTextToFind)
' get the information required for the hyperlink
dSl_Title = dSl.Shapes.Title.TextFrame.TextRange
dSl_ID = dSl.SlideID
dSl_Index = dSl.SlideIndex
With oSh
.ActionSettings(ppMouseClick).Parent.Parent.View.GoToSlide dSl_Index, msoFalse 'Go to slide and don't reset animations
End With
' find the text string in the body
'hypstart = InStr(1, sTextToFind, dSl_Title, 1)
'make the text a hyperlink
'With oSh.TextFrame.TextRange.Characters(hypstart, Len(sTextToFind)).ActionSettings(ppMouseClick).Hyperlink
'.SubAddress = dSl_ID & "," & dSl_Index & "," & sTextToFind
'End With
'End With
End If
'End If
Next oSh
End Sub
Public Function FindSlideByTitle_Original(sTextToFind As String) As Slide
'Source: https://stackoverflow.com/questions/25038952/vba-powerpoint-select-a-slide-by-name
Dim oSl As Slide
For Each oSl In ActivePresentation.Slides
With oSl.Shapes.Title.TextFrame
If .HasText Then
If UCase(.TextRange.Text) = UCase(sTextToFind) Then
Set FindSlideByTitle_Original = oSl
End If
End If
End With
Next
End Function
I have the following macro that aligns 1 selected picture at a time in Power Point:
Sub Align()
With ActiveWindow.Selection.ShapeRange
.Left = 50
.Top = 100
End With
End Sub
This code works if I run the macro on a selected picture in a slide.
But how can I run this script for each picture of all slides?
This will do that for you Jose:
' PowerPoint VBA to reposition all pictures in all slides in a deck
' Written by Jamie Garroch of YOUpresent Ltd.
' http://youpresent.co.uk/
Option Explict
Sub RepositionAllPictures()
Dim oSld As Slide
Dim oShp as Shape
For Each oSld in ActivePresentation.Slides
For Each oShp in oSld.Shapes
If oShp.Type = msoPicture Then RepositionShape oShp
If oShp.Type = msoPlaceholder Then
If oShp.PlaceholderFormat.ContainedType = msoPicture Or _
oShp.PlaceholderFormat.ContainedType = msoLinkedPicture Then _
RepositionShape oShp
End If
Next
Next
End Sub
Sub RepositionShape(oShp As Shape)
oShp.Left = 50
oShp.Top = 100
End Sub
I am working on a custom tool that generates customized Instructor notes for a given presentation. I am having a problem where I am processing a presentation where a slide basically has no Title object on it Then I run through the code it is bi-passing my if statements with .
I have reduced the code to the basics to make it as easy as possible.
My test lesson has a normal slide with the text place holder filled out, the next slide is a logo slide with no title text box, just a copyright information and logo, (this is the slide that is having issues) and then another slide where the title place holder is present, but left blank.
How do I check the individual slide to make sure that the title placeholder exists?
Public Sub GetTitle()
Dim pres As Presentation 'PowerPoint presentation
Dim sld As Slide 'Individual slide
Dim shp As Shape 'EIAG Text Shape
Dim ShpType As String 'Shape Type
Dim SldTitle As String 'Slide TITLE
'Go through each slide object
Set pres = ActivePresentation
For Each sld In ActivePresentation.Slides.Range
On Error Resume Next
If sld.Shapes(1).PlaceholderFormat.Type = ppPlaceholderCenterTitle Or sld.Shapes(1).PlaceholderFormat.Type = ppPlaceholderTitle Then
If sld.Shapes.Title.TextFrame.TextRange <> "" Then
SldTitle = sld.Shapes.Title.TextFrame.TextRange
Debug.Print SldTitle & " - Slide: " & CStr(sld.SlideNumber)
Else
Debug.Print "BLANK TITLE - Slide: " & CStr(sld.SlideNumber)
End If
Else
ShpType = sld.Shapes.Item(1).Type
Debug.Print ShpType & "Not Processed There is no Title object"
End If
Next sld
End Sub
You can use the HastTitle method of the Shapes Collection to check if a slide has a title placeholder:
If sld.Shapes.HasTitle then
You should also not rely on the title placeholder being shape 1 and rather loop through all shapes on the slide, checking each one as follows:
Option Explicit
' Function to return an array of title texts from a presentation
' Written by Jamie Garroch at http://youpresent.co.uk
' Inputs : None
' Outputs : Array of title strings
Function GetTitlesArr() As Variant
Dim oSld As Slide
Dim oShp As Shape
Dim iCounter As Integer
Dim arrTitles() As String
For Each oSld In ActivePresentation.Slides
For Each oShp In oSld.Shapes
With oShp
If .Type = msoPlaceholder Then
Select Case .PlaceholderFormat.Type
Case ppPlaceholderCenterTitle, ppPlaceholderTitle
ReDim Preserve arrTitles(iCounter)
arrTitles(iCounter) = oShp.TextFrame.TextRange.Text
iCounter = iCounter + 1
End Select
End If
End With
Next
Next
GetTitlesArr = arrTitles
End Function
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