Change Font
Sub allSlideFontchange()
Dim osld As Slide, oshp As Shape
For Each osld In ActivePresentation.Slides
For Each oshp In osld.Shapes
If oshp.Type = msoPlaceholder Then
'Title text change values as required
If oshp.PlaceholderFormat.Type = 1 Or oshp.PlaceholderFormat.Type = 3 Then
If oshp.HasTextFrame Then
If oshp.TextFrame.HasText Then
With oshp.TextFrame.TextRange.Font
.Name = "Louis George Café"
.Size = 28
.Color.RGB = RGB(255, 0, 0)
.Bold = msoFalse
.Italic = msoFalse
.Shadow = False
End With
End If
End If
End If
If oshp.PlaceholderFormat.Type = 2 Or oshp.PlaceholderFormat.Type = 7 Then
If oshp.HasTextFrame Then
If oshp.TextFrame.HasText Then
'Body text change values as required
With oshp.TextFrame.TextRange.Font
.Name = "Louis George Café"
.Size = 30
.Color.RGB = RGB(0, 0, 0)
.Bold = msoFalse
.Italic = msoFalse
.Shadow = False
End With
End If
End If
End If
End If
Next oshp
Next osld
End Sub
Table of Content
Sub DirectoryWithoutHyperlinks()
'Insert directory without hyperlinks
Agenda (False)
End Sub
Sub DirectoryWithHyperlinks()
'Insert Directory with Hyperlinks
Agenda (True)
End Sub
Sub Agenda(Optional Hyperlinks As Boolean)
Dim i As Integer
Dim o As Integer
Dim strSel As String
Dim strTitel As String
Dim strAgendaTitel As String
Dim slAgenda As Slide
Dim intPos As Integer
Dim SlideFollow() As Integer
' On Error Resume Next <<<<<<<<<<<<<<<<<<<<<<<< VERY VERY VERY BAD to have at start (or any
place usually)
If ActiveWindow.Selection.SlideRange.Count = 0 Then Exit Sub
ReDim SlideFollow(1 To ActiveWindow.Selection.SlideRange.Count)
'Select position for content slides
intPos = InputBox("Which slides should the agenda be inserted before?", "Position of the agenda")
'Cancel if the value is greater than the number of slides
If intPos > ActivePresentation.Slides.Count Then
MsgBox "The selected value is greater than the number of slides in the presentation.“"
Exit Sub
End If
'Enter the title of the content slide
strAgendaTitel = InputBox("What heading do you want for the content slide?", "Enter titles")
'Determining the IDs of selected slides
For i = 1 To ActiveWindow.Selection.SlideRange.Count
SlideFollow(i) = ActiveWindow.Selection.SlideRange(i).SlideIndex
Next
For o = 1 To UBound(SlideFollow)
If ActivePresentation.Slides(SlideFollow(o)).Shapes.HasTitle Then
'Build up the ToC Text
strTitel = ActivePresentation.Slides(SlideFollow(o)).Shapes.Title.TextFrame.TextRange.Text
strSel = strSel & strTitel & vbCrLf
End If
Next
'Insert blank slides where you want, enter titles and headings
Set slAgenda = ActivePresentation.Slides.Add(intPos, ppLayoutText)
slAgenda.Shapes(1).TextFrame.TextRange = strAgendaTitel
slAgenda.Shapes(2).TextFrame.TextRange = strSel
'Insert Hyperlinks
If Hyperlinks Then
For o = 1 To UBound(SlideFollow)
If ActivePresentation.Slides(SlideFollow(o) + 1).Shapes.HasTitle Then
'Build up the ToC Text
strTitel = ActivePresentation.Slides(SlideFollow(o) +
1).Shapes.Title.TextFrame.TextRange.Text
With slAgenda.Shapes(2).TextFrame.TextRange.Paragraphs(o).ActionSettings(ppMouseClick)
.Action = ppActionHyperlink
.Hyperlink.Address = ""
.Hyperlink.SubAddress = ActivePresentation.Slides(SlideFollow(o) + 1).SlideID & "," &
ActivePresentation.Slides(SlideFollow(o) + 1).SlideIndex & "," + strTitel
End With
End If
Next
End If
End Sub
Save as PDF
Sub SavePresentationAsPDF()
Dim pptName As String
Dim PDFName As String
' Save PowerPoint as PDF
pptName = ActivePresentation.FullName
' Replace PowerPoint file extension in the name to PDF
PDFName = Left(pptName, InStr(pptName, ".")) & "pdf"
ActivePresentation.ExportAsFixedFormat PDFName, 2 ' ppFixedFormatTypePDF = 2
End Sub
