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
Related
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
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.
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
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
I have a folder with over 200 Powerpoint files and I have been have been struggling with a Macro that opens each of these files, edits them, saves them and closes them in a loop.
I have managed to create code for the editing part, however I can't manage to create a code that picks each of the files in the folder. Using "*.pptx" doesn't seem to work and writing code with a specific filename for each of these files is very inefficient.
Does anyone have a solution to this?
Sub SaveNotesText()
Dim oPres As Presentation
Dim oSlides As Slides
Dim oSlide As Slide
Dim oShapes As Shapes
Dim oSh As Shape
Dim NotesText As String
Dim FileNum As Integer
Dim PathSep As String
#If Mac Then
PathSep = ":"
#Else
PathSep = "\"
#End If
Set oPres = ActivePresentation
Set oSlides = oPres.Slides
For Each oSlide In oSlides
NotesText = NotesText & "Slide " & oSlide.SlideIndex & vbCrLf
Set oShapes = oSlide.NotesPage.Shapes
For Each oSh In oShapes
If oSh.HasTextFrame Then
If oSh.TextFrame.HasText Then
NotesText = NotesText & oSh.TextFrame.TextRange.Text
End If
End If
Next oSh
NotesText = NotesText & vbCrLf
Next oSlide
FileNum = FreeFile
Open oPres.Path & PathSep & "NotesText.TXT" For Output As FileNum
Print #FileNum, NotesText
Close FileNum
End Sub
http://www.pptfaq.com/FAQ00274.htm
You can use Dir to loop through all the "#.ppt#" files in a folder, ie
Public Sub DoFiles()
Dim strFileName As String
Dim strFolderName As String
Dim PP As Presentation
'set default directory here if needed
strFolderName = "C:\temp"
strFileName = Dir(strFolderName & "\*.ppt*")
Do While Len(strFileName) > 0
Set PP = Presentations.Open(strFolderName & "\" & strFileName)
'your code
PP.Close
strFileName = Dir
Loop
End Sub