Extract titles from powerpoint textboxes (not placeholders)? - vba

I've a PDF file which was originally created from a PPT (which I don't have access to). I need to extract the titles/headings from each page of the PDF into a single document (format irrelevant; Excel, Notepad, Word, anything will do). The file is big therefore, cant be done manually and I will have to do it for similar files again.
I concluded that converting the PDF back into PPT format would help and I am trying to write a Subroutine in PowerPoint VBA. Please take a look at the code below and suggest what I can change to accomplish this? Alternate ideas also welcome.
Heads up: Once converted back into PPT, the titles in each slide are no longer in the 'Title' placeholder, in PowerPoint. They are just normal textboxes. I'm new to VBA, I've compiled the code by Googling.
Output: This prints out a notepad file with list of slide numbers. For each slide it prints that respective slide number as many times as there are textboxes in the slide. For example: Slide 1 has 3 textboxes therefore, the notepad reads:
"Slide: 1
Slide: 1
Slide: 1
Slide: 2
Slide: 2
Slide: 2
Slide: 2
Slide: 2
Slide: 2
Slide: 2"
Problem: It is not printing the text from the textboxes. Actually, I need the text from only the top textbox (which is first or topmost placed on the slide).
Code:
Sub GatherTitles()
On Error GoTo ErrorHandler
Dim oSlide As Slide
Dim strTitles As String
Dim strFilename As String
Dim intFileNum As Integer
Dim PathSep As String
Dim Shp As Shape
If ActivePresentation.Path = "" Then
MsgBox "Please save the presentation then try again"
Exit Sub
End If
#If Mac Then
PathSep = ":"
#Else
PathSep = "\"
#End If
On Error Resume Next ' in case there's no title placeholder on the slide
For Each oSlide In ActiveWindow.Presentation.Slides
For Each Shp In oSlide.Shapes
Select Case Shp.Type
Case MsoShapeType.msoTextBox
strTitles = strTitles _
& "Slide: " _
& CStr(oSlide.SlideIndex) & vbCrLf _
& oSlide.Shapes(1).TextFrame.TextRange.Text _
& vbCrLf & vbCrLf
Case Else
Debug.Print Sld.Name, Shp.Name, "This is not a text box"
End Select
Next Shp
Next oSlide
On Error GoTo ErrorHandler
intFileNum = FreeFile
' PC-Centricity Alert!
' This assumes that the file has a .PPT extension and strips it off to make the text file name.
strFilename = ActivePresentation.Path _
& PathSep _
& Mid$(ActivePresentation.Name, 1, Len(ActivePresentation.Name) - 4) _
& "_Titles.TXT"
Open strFilename For Output As intFileNum
Print #intFileNum, strTitles
NormalExit:
Close intFileNum
Exit Sub
ErrorHandler:
MsgBox Err.Description
Resume NormalExit
End Sub

You really aren't doing anything with the variable Shp beyond checking if it is a text box. I don't have enough to go on to test the solution, but before the line
& vbCrLf & vbCrLf
try inserting the line
& ": " & Shp.TextFrame.TextRange.Text _

If the text boxes aren't placeholders, the only way to do it is to check the position of each shape on the slide. Set X and Y accordingly below.
Sub GetTitles()
Dim oSld as Slide
Dim oShp as Shape
Dim myText as String
For Each oSld in ActivePresentation.Slides
For Each oShp in oSld.Shapes
If oShp.Left=X and oShp.Top=Y Then
my Text=oShp.TextFrame.TextRange.Text
Debug.Print myText
End If
Next
Next
End Sub

(Posted of behalf of the OP.)
The problem has been solved. Final code for reference just in case someone else starts VBA PowerPoint:
Sub GatherTitles()
On Error GoTo ErrorHandler
Dim oSlide As Slide
Dim strTitles As String
Dim strFilename As String
Dim intFileNum As Integer
Dim PathSep As String
Dim Shp As Shape
Dim Count As Integer
Dim Mn As Double
If ActivePresentation.Path = "" Then
MsgBox "Please save the presentation then try again"
Exit Sub
End If
#If Mac Then
PathSep = ":"
#Else
PathSep = "\"
#End If
On Error Resume Next ' in case there's no title placeholder on the slide
For Each oSlide In ActiveWindow.Presentation.Slides
Count = 0
For Each Shp In oSlide.Shapes
Select Case Shp.Type
Case MsoShapeType.msoTextBox
Count = Count + 1
Case Else
Debug.Print Sld.Name, Shp.Name, "This is not a text box"
End Select
Next Shp
Count = Count - 1
Dim distmat() As Double
ReDim distmat(0 To Count)
Dim i As Integer
i = 0
For Each Shp In oSlide.Shapes
Select Case Shp.Type
Case MsoShapeType.msoTextBox
distmat(i) = Shp.Top
i = i + 1
Case Else
Debug.Print Sld.Name, Shp.Name, "This is not a text box"
End Select
Next Shp
Mn = distmat(0)
i = i - 1
For j = 1 To i
If distmat(j) < Mn Then
Mn = distmat(j)
End If
Next j
'Next oSlide
'For Each oSlide In ActiveWindow.Presentation.Slides
For Each Shp In oSlide.Shapes
Select Case Shp.Type
Case MsoShapeType.msoTextBox
If Shp.Top = Mn Then
strTitles = strTitles _
& "Slide: " _
& CStr(oSlide.SlideIndex) & vbCrLf _
& oSlide.Shapes(1).TextFrame.TextRange.Text _
& Shp.TextFrame.TextRange.Text & vbCrLf _
& vbCrLf & vbCrLf
Else
Debug.Print Sld.Name, Shp.Name, "This is not the topmost textbox"
End If
Case Else
Debug.Print Sld.Name, Shp.Name, "This is not a text box"
End Select
Next Shp
Next oSlide
On Error GoTo ErrorHandler
intFileNum = FreeFile
' PC-Centricity Alert!
' This assumes that the file has a .PPT extension and strips it off to make the text file name.
strFilename = ActivePresentation.Path _
& PathSep _
& Mid$(ActivePresentation.Name, 1, Len(ActivePresentation.Name) - 4) _
& "_Titles.TXT"
Open strFilename For Output As intFileNum
Print #intFileNum, strTitles
NormalExit:
Close intFileNum
Exit Sub
ErrorHandler:
MsgBox Err.Description
Resume NormalExit
End Sub

Related

Save current slide, no fonts

This is a piece of code I wrote to save the current slide with no embedded fonts into a single
I think something with the path is wrong because it seems to mix-up a Onedrive path with the rest of the path and filename I add. And though it confirms the file has been saved, I can't find it.
Thanks in advance for your help!
Option Explicit
Sub SaveCurrentSlide()
Dim CurrentSlide As String
Dim tPath As String
Dim tFilename As String
CurrentSlide = ActiveWindow.View.Slide.SlideIndex
On Error GoTo errorhandler
If ActiveWindow.ViewType = ppViewNormal Then ActiveWindow.Panes(1).Activate
With ActivePresentation
' Build a unique filename and save a coy of the now single-slide presentation
tPath = .Path
tFilename = tPath & "\" & Left(.Name, InStrRev(.Name, ".") - 1) & " [slide " & CurrentSlide & "].pptx"
ActivePresentation.SaveAs FileName:=tFilename, _
FileFormat:=ppSaveAsPresentation, EmbedTrueTypeFonts:=msoFalse
End With
' Give feedback to the user
MsgBox "Current slide exported to:" & vbNewLine & tFilename, vbOKOnly, "Export Current Slide - Export Complete"
On Error GoTo 0
Exit Sub
errorhandler:
Debug.Print Err, Err.Description
Resume Next
End Sub

Open method not working to open ppts from a ppt

I'm having a bit of trouble here. My code stops with a Run-time error -2147467259 (80004005) Mehod 'Open' of object 'Presentations: failed.
This code presents a warning, prompts for source and target folder and loops through all files in the source folder, opening each file and exporting each slide as an individual file, and again until the last file in the folder.
I put a couple of msgboxes to see if it was a problem with the names, re-wrote the open file segment based on some code from MVP Andy Pope, yet nothing.
Any help is deeply appreciated.
Sub ExportIndividualSlides()
''Application.DisplayAlerts = False
Dim ObjPPAPP As New PowerPoint.Application
Dim objPPPres As PowerPoint.Presentation
Dim objPPSlide As PowerPoint.Slide
'Initial directory path.
Dim SourceFolder As String
Dim TargetFolder As String
SourceFolder = "c:\source"
TargetFolder = "c:\target"
Dim Slide As Long
Dim SourcePresentation As Presentation
Dim SourcePresentationName As String
Dim TargetFileName As String
Dim SourceNamePath
Debug.Print "-- Start --------------------------------"
ActiveWindow.ViewType = ppViewNormal
'Loop through ppt* files only in source folder
SourcePresentationName = Dir(SourceFolder & "\*.ppt*")
MsgBox "SPN:" & SourcePresentationName
While (SourcePresentationName <> "")
SourceNamePath = SourceFolder & "\" & SourcePresentationName
Debug.Print " SourceNamePath"
MsgBox SourceNamePath
Set ObjPPAPP = New PowerPoint.Application
ObjPPAPP.Visible = True
Set objPPPres = ObjPPAPP.Presentations.Open(SourceNamePath)
' On Error GoTo errorhandler
' Open source files
Set SourcePresentation = Presentations.Open(FileName:=SourcePresentationName, WithWindow:=False)
Debug.Print " SourcePresentation: " & SourcePresentation.Name
' Loop through slides
For Slide = 1 To SourcePresentation.Slides.Count
Debug.Print " Slide: " & Slide
' Create a unique filename and save a copy of each slide
TargetFileName = Left(SourcePresentation.Name, InStrRev(SourcePresentation.Name, ".") - 1) & " [" & Slide & "].pptx"
TargetNamePath = TargetFolder & "\" & TargetFileName
Debug.Print " TargetNamePath: " & TargetNamePath
SourcePresentation.Slides(Slide).Export TargetNamePath, "PPTX"
Next Slide
objPPPres = Nothing
SourcePresentation.Close
SourcePresentationName = Dir
Wend
On Error GoTo 0
Exit Sub
errorhandler:
Debug.Print Err, Err.Description
Resume Next
End Sub
This worked for me:
Sub ExportIndividualSlides()
'use const for fixed values
Const SOURCE_FOLDER As String = "c:\source\" 'include terminal \
Const TARGET_FOLDER As String = "c:\target\"
Dim objPres As PowerPoint.Presentation
Dim Slide As Long
Dim SourcePresentationName As String
Dim TargetFileName As String
Dim TargetNamePath As String
Dim SourceNamePath
Debug.Print "-- Start --------------------------------"
ActiveWindow.ViewType = ppViewNormal
On Error GoTo errorhandler
'Loop through ppt* files only in source folder
SourcePresentationName = Dir(SOURCE_FOLDER & "*.ppt*")
Do While Len(SourcePresentationName) > 0
SourceNamePath = SOURCE_FOLDER & SourcePresentationName
Debug.Print "Opening: " & SourceNamePath
Set objPres = Presentations.Open(SourceNamePath)
' Loop through slides
For Slide = 1 To objPres.Slides.Count
Debug.Print " Slide: " & Slide
' Create a unique filename and save a copy of each slide
TargetFileName = Left(objPres.Name, InStrRev(objPres.Name, ".") - 1) & " [" & Slide & "].pptx"
TargetNamePath = TARGET_FOLDER & TargetFileName
Debug.Print " TargetNamePath: " & TargetNamePath
objPres.Slides(Slide).Export TargetNamePath, "PPTX"
Next Slide
objPres.Close
SourcePresentationName = Dir() 'next file
Loop
Exit Sub
errorhandler:
Debug.Print Err, Err.Description
Resume Next
End Sub

Exporting a PowerPoint slide

I've got a macro in a PowerPoint file that is to export the first slide to a TIF image. It was working before but now has started to give an error. The following is the line of code I use to export the image and it is the line that gives me the error.
Application.ActivePresentation.Slides(1).Export "C:\Users\abc\Desktop\picture.TIF", "TIF"
The error that I get is:
Run-time error '-2147467259 (80004005)':
Slide (unknown member) : Failed.
I've tried searching on Google and can't figure this one out. Any ideas?
Thanks
The command itself is correct, the user has in the meantime sent testfiles. I suspect a general permission problem in writing files which can be checked with this:
Sub CreateFile()
Dim oSld As Slide
Dim oShp As Shape
Dim InfoText As String
Dim iCnt As Integer
Dim sFileName As String
iCnt = FreeFile
For Each oSld In ActivePresentation.Slides
For Each oShp In oSld.Shapes
InfoText = InfoText & "Slide " & oSld.SlideIndex & " Shape " & oShp.Name & vbCrLf & "------------" & vbCrLf
Next ' oShp
Next ' oSld
sFileName = "D:\InfoTestFile.txt"
Open sFileName For Output As iCnt
Print #iCnt, InfoText
Close iCnt
Call Shell("NOTEPAD.EXE " & sFileName, vbNormalFocus)
MsgBox "If this works I have no idea anymore hahaha", vbInformation
End Sub

Exporting notes with formatting

I have the following macro for Microsoft Powerpoint 365 for exporting the notes into a separate .txt file. The problem is it excludes the bullet points from the notes which are in the notes. How can I fix this problem?
Sub ExportNotesText()
Dim oSlides As Slides
Dim oSl As Slide
Dim oSh As Shape
Dim strNotesText As String
Dim strFileName As String
Dim intFileNum As Integer
Dim lngReturn As Long
' Get a filename to store the collected text
strFileName = InputBox("Enter the full path and name of file to extract notes text to", "Output file?", ActivePresentation.Path + "\notes.txt")
' did user cancel?
If strFileName = "" Then
Exit Sub
End If
' is the path valid? crude but effective test: try to create the file.
intFileNum = FreeFile()
On Error Resume Next
Open strFileName For Output As intFileNum
If Err.Number <> 0 Then ' we have a problem
MsgBox "Couldn't create the file: " & strFileName & vbCrLf _
& "Please try again."
Exit Sub
End If
Close #intFileNum ' temporarily
' Get the notes text
Set oSlides = ActivePresentation.Slides
For Each oSl In oSlides
For Each oSh In oSl.NotesPage.Shapes
If oSh.PlaceholderFormat.Type = ppPlaceholderBody Then
If oSh.HasTextFrame Then
If oSh.TextFrame.HasText Then
strNotesText = strNotesText & "Slide: " & CStr(oSl.SlideIndex) & vbCrLf _
& oSh.TextFrame.TextRange.Text & vbCrLf & vbCrLf
End If
End If
End If
Next oSh
Next oSl
' now write the text to file
Open strFileName For Output As intFileNum
Print #intFileNum, strNotesText
Close #intFileNum
' show what we've done
' lngReturn = Shell("NOTEPAD.EXE " & strFileName, vbNormalFocus)
End Sub
Once you have the reference to the notes TextFrame, you can loop through its .TextRange.Paragraphs collection.
This will give you an asterisk & space & and the text of the paragraph or just the text if no bullet:
If .Paragraphs(x).ParagraphFormat.Bullet.Type = ppBulletUnnumbered Then
Debug.Print "* " & .Paragraphs(x).Text
Else
Debug.Print .Paragraphs(x).Text
End if
There may also be numbered or picture bullets. Let's not go there.

How do I export powerpoint slide notes to individual text files?

Through some research, I came across this VBA code on the following site:
http://www.pptfaq.com/FAQ00481_Export_the_notes_text_of_a_presentation.htm
Sub ExportNotesText()
Dim oSlides As Slides
Dim oSl As Slide
Dim oSh As Shape
Dim strNotesText As String
Dim strFileName As String
Dim intFileNum As Integer
Dim lngReturn As Long
' Get a filename to store the collected text
strFileName = InputBox("Enter the full path and name of file to extract notes text to", "Output file?")
' did user cancel?
If strFileName = "" Then
Exit Sub
End If
' is the path valid? crude but effective test: try to create the file.
intFileNum = FreeFile()
On Error Resume Next
Open strFileName For Output As intFileNum
If Err.Number <> 0 Then ' we have a problem
MsgBox "Couldn't create the file: " & strFileName & vbCrLf _
& "Please try again."
Exit Sub
End If
Close #intFileNum ' temporarily
' Get the notes text
Set oSlides = ActivePresentation.Slides
For Each oSl In oSlides
For Each oSh In oSl.NotesPage.Shapes
If oSh.PlaceholderFormat.Type = ppPlaceholderBody Then
If oSh.HasTextFrame Then
If oSh.TextFrame.HasText Then
strNotesText = strNotesText & "Slide: " & CStr(oSl.SlideIndex) & vbCrLf _
& oSh.TextFrame.TextRange.Text & vbCrLf & vbCrLf
End If
End If
End If
Next oSh
Next oSl
' now write the text to file
Open strFileName For Output As intFileNum
Print #intFileNum, strNotesText
Close #intFileNum
' show what we've done
lngReturn = Shell("NOTEPAD.EXE " & strFileName, vbNormalFocus)
End Sub
It essentially exports ALL the slide notes from a Powerpoint file into ONE text file in chronological order of slides.
Is there anyway to alter the code to output the slide notes into multiple text files? What I mean is, if there are 4 slides in the powerpoint document, we would get an export of each slide's notes as follows:
slide1notes.txt
slide2notes.txt
slide3notes.txt
slide4notes.txt
Many thanks.
I didn't have a great deal of time to do more than aircode this, but:
Sub TryThis()
' Write each slide's notes to a text file
' in same directory as presentation itself
' Each file is named NNNN_Notes_Slide_xxx
' where NNNN is the name of the presentation
' xxx is the slide number
Dim oSl As Slide
Dim oSh As Shape
Dim strFileName As String
Dim strNotesText As String
Dim intFileNum As Integer
' Get the notes text
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.NotesPage.Shapes
If oSh.PlaceholderFormat.Type = ppPlaceholderBody Then
If oSh.HasTextFrame Then
If oSh.TextFrame.HasText Then
' now write the text to file
strFileName = ActivePresentation.Path _
& "\" & ActivePresentation.Name & "_Notes_" _
& "Slide_" & CStr(oSl.SlideIndex) _
& ".TXT"
intFileNum = FreeFile()
Open strFileName For Output As intFileNum
Print #intFileNum, oSh.TextFrame.TextRange.Text
Close #intFileNum
End If
End If
End If
Next oSh
Next oSl
End Sub
And since Mac PPT/VBA is bug-infested, here's a new version for Mac. Since I'm doing this on a PC and can't copy/paste to/from the Mac, I haven't run the code on Mac, but it should be ok:
Sub TryThis()
' Write each slide's notes to a text file
' in same directory as presentation itself
' Each file is named NNNN_Notes_Slide_xxx
' where NNNN is the name of the presentation
' xxx is the slide number
Dim oSl As Slide
Dim oSh As Shape
Dim strFileName As String
Dim strNotesText As String
Dim intFileNum As Integer
' Since Mac PPT will toss non-fatal errors, just keep moving along:
On Error Resume Next
' Get the notes text
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.NotesPage.Shapes
' Here's where the error will occur, if any:
If oSh.PlaceholderFormat.Type = ppPlaceholderBody Then
' so deal with it if so:
If Err.Number = 0 Then
If oSh.HasTextFrame Then
If oSh.TextFrame.HasText Then
' now write the text to file
strFileName = ActivePresentation.Path _
& "\" & ActivePresentation.Name & "_Notes_" _
& "Slide_" & CStr(oSl.SlideIndex) _
& ".TXT"
intFileNum = FreeFile()
Open strFileName For Output As intFileNum
Print #intFileNum, oSh.TextFrame.TextRange.Text
Close #intFileNum
End If ' HasText
End If ' HasTextFrame
End If ' Err.Number = 0
End If ' PlaceholderType test
Next oSh
Next oSl
End Sub
If anyone needs the output in one txt-file:
Sub TryThis()
' Write each slide's notes to a text file
' in same directory as presentation itself
' Each file is named NNNN_Notes_Slide_xxx
' where NNNN is the name of the presentation
' xxx is the slide number
Dim oSl As Slide
Dim oSh As Shape
Dim strFileName As String
Dim strNotesText As String
Dim intFileNum As Integer
Dim strLine As String
Dim strData As String
' Since Mac PPT will toss non-fatal errors, just keep moving along:
On Error Resume Next
' Get the notes text
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.NotesPage.Shapes
' Here's where the error will occur, if any:
If oSh.PlaceholderFormat.Type = ppPlaceholderBody Then
' so deal with it if so:
If Err.Number = 0 Then
If oSh.HasTextFrame Then
If oSh.TextFrame.HasText Then
strData = strData + "Folie " & oSl.SlideIndex & vbCrLf & oSh.TextFrame.TextRange.Text & vbCrLf & vbCrLf
Close #intFileNum
End If ' HasText
End If ' HasTextFrame
End If ' Err.Number = 0
End If ' PlaceholderType test
Next oSh
Next oSl
' now write the text to file
strFileName = ActivePresentation.Path _
& "\" & ActivePresentation.Name & "_Notes" _
& ".txt"
intFileNum = FreeFile()
Open strFileName For Output As intFileNum
Print #intFileNum, strData
Close #intFileNum
End Sub