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
Related
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
I have a script which attach only selected files in Outlook, but when the file is not saved it gives error no 5.
I want a msg popup "Please save your file" instead of coming error msg, below are my script
Sub SendSDDesignteam()
Dim objActivePresetation As Presentation
Dim objSlide As Slide
Dim n As Long
Dim strName As String
Dim strTempPresetation As String
Dim objTempPresetation As Presentation
Dim objOutlookApp As Object
Dim objMail As Object
Set objActivePresetation = ActivePresentation
For Each objSlide In objActivePresetation.Slides
objSlide.Tags.Delete ("Selected")
Next
'Add a tag "Selected" to the selected slides
For n = 1 To ActiveWindow.Selection.SlideRange.Count
ActiveWindow.Selection.SlideRange(n).Tags.Add "Selected", "YES"
Next n
strName = objActivePresetation.Name
strName = Left(strName, InStrRev(strName, ".") - 1)
strTempPresetation = Environ("TEMP") & "\" & strName & ".pptx"
'Copy the active presentation to a temp presentation
objActivePresetation.SaveCopyAs strTempPresetation
Set objTempPresetation = Presentations.Open(strTempPresetation)
'Remove the untagged slides
For n = objTempPresetation.Slides.Count To 1 Step -1
If objTempPresetation.Slides(n).Tags("Selected") <> "YES" Then
objTempPresetation.Slides(n).Delete
End If
Next n
objTempPresetation.Save
objTempPresetation.Close
'Attach the temp presentation to a new email
Set objOutlookApp = CreateObject("Outlook.Application")
Set objMail = objOutlookApp.CreateItem(olMailItem)
'Change the email details as per your needs
With objMail
.To = "abc#johndoe.com"
.Subject = "Formatting/Designing Help"
.Body = "Hi Team," & vbCr & vbCr & vbTab & "Need this by Date: DD/MM/YYYY, Time : 00:00, Client : XYZ, Comment : NA."
.Attachments.Add strTempPresetation
.Display
End With
End Sub
It will be great help if you can help me in this.
Thanks in advance
Error occurs here.
strName = Left(strName, InStrRev(strName, ".") - 1)
When the file is not saved, strName does not contain ".".
InStrRev(strName, ".") - 1 is equal to -1. This generates an Error.
So you can check if the error occurs and display the message like this.
On Error Resume Next 'Begin ignoring errors.
strName = Left(strName, InStrRev(strName, ".") - 1)
If Err Then
MsgBox "Please save your file", vbCritical, "Error"
Exit Sub
End If
On Error Goto 0 'Stop ignoring errors.
But you'd better check if the file is saved at the beginning of the procedure like this.
Set objActivePresetation = ActivePresentation
'Check if the file is saved.
If objActivePresetation.Saved = False Then
MsgBox "Please save your file", vbCritical, "Error"
Exit Sub
End If
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
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