PowerPoint Object Export. Please Help!

[twz2004]

Hey all,

So far, i've gathered the following working code via the forums to export x3 objects I select on a slide in PowerPoint:



Sub test()

Dim i As Integer
Dim fn As String


For i = 1 To 3


fn = "fn-" & i & ".png"


Call ActiveWindow.Selection.ShapeRange(i).Export("e:\dropbox\" & fn, ppShapeFormatPNG)


Next i


End Sub


My end-goal for the code here is:



cycle through each slide (there is 30 slides)
select-all objects on the each slide
export each object as a separate PNG file


Currently, with the code above, I have to manually select the objects I want exported and run the script. I need these objects exported so I can import them into OmniGraffle (VISIO for Mac).

22016

Any help would be awesome! Thanks so much!

[John Wilson]

This (top of head code) should get you close


Sub exOBJ()
Dim oshp As Shape
Dim osld As Slide
Dim fn As String
Dim i As Long
For Each osld In ActiveWindow.Selection.SlideRange
For Each oshp In osld.Shapes
i = i + 1
fn = CStr(i) &"_"
Call oshp.Export("e:\dropbox\" & fn, ppShapeFormatPNG)
Next
Next
End Sub

[twz2004]

Thank you! I'll give that a shot. Any idea how to make the code work on a Mac? I changed the path '/User/username/Download' and it wont create any files.

[twz2004]

Thanks again for your help!

The below code is working great under Windows. Aside from BOLD sections. I was trying to add a condition where it skipped text and only exports objects.



Sub exOBJ()


Dim oshp As shape
Dim osld As Slide
Dim fn As String
Dim i As Long
Dim slidenum As Integer


For slidenum = 1 To 3


ActiveWindow.View.GotoSlide (slidenum)


On Error Resume Next


MkDir "E:\Dropbox\projects\construct\Extract\Slide-" & slidenum


For Each osld In ActiveWindow.Selection.SlideRange

For Each oshp In osld.Shapes


i = i + 1


If oshp.TextFrame.TextRange.Paragraphs > 1 Then GoTo q

fn = "Slide-" & slidenum & "\" & CStr(i) & "_.png"


Call oshp.Export("E:\Dropbox\projects\construct\Extract\" & fn, ppShapeFormatPNG)


q:


Next oshp
Next osld

Next slidenum


End Sub

[John Wilson]

Maybe


For Each oshp In osld.Shapes
If Not oshp.HasTextFrame Then
i = i + 1
fn = "Slide-" & slidenum & "\" & CStr(i) & "_.png"
Call oshp.Export("E:\Dropbox\projects\construct\Extract\" & fn, ppShapeFormatPNG)
End If
Next oshp

[twz2004]

Maybe


For Each oshp In osld.Shapes
If Not oshp.HasTextFrame Then
i = i + 1
fn = "Slide-" & slidenum & "\" & CStr(i) & "_.png"
Call oshp.Export("E:\Dropbox\projects\construct\Extract\" & fn, ppShapeFormatPNG)
End If
Next oshp

Thanks, John! So I discovered this code that works well for extracting text from slides. I would like to see about incorporating my previous code so it uses the same parsing method to extract objects.



Sub ExportText()


Dim oPres As Presentation
Dim oSlides As Slides
Dim osld As Slide 'Slide Object
Dim oshp As Shape 'Shape Object
Dim iFile As Integer 'File handle for output
iFile = FreeFile 'Get a free file number
Dim PathSep As String
Dim FileNum As Integer


#If Mac Then
PathSep = ":"
#Else
PathSep = "\"
#End If


Set oPres = ActivePresentation
Set oSlides = oPres.Slides


FileNum = FreeFile


'Open output file
' NOTE: errors here if file hasn't been saved
Open oPres.Path & PathSep & "AllText.TXT" For Output As FileNum


For Each osld In oSlides 'Loop thru each slide


Print #iFile, ""
Print #iFile, "Slide Number-" & osld.SlideNumber
Print #iFile, ""

For Each oshp In osld.Shapes 'Loop thru each shape on slide


'Check to see if shape has a text frame and text
If oshp.HasTextFrame And oshp.TextFrame.HasText Then
If oshp.Type = msoPlaceholder Then
Select Case oshp.PlaceholderFormat.Type
Case Is = ppPlaceholderTitle, ppPlaceholderCenterTitle
Print #iFile, "Title:" & vbTab & oshp.TextFrame.TextRange
Case Is = ppPlaceholderBody
Print #iFile, "Body:" & vbTab & oshp.TextFrame.TextRange
Case Is = ppPlaceholderSubtitle
Print #iFile, "SubTitle:" & vbTab & oshp.TextFrame.TextRange
Case Else
Print #iFile, "Other Placeholder:" & vbTab & oshp.TextFrame.TextRange
End Select
Else
Print #iFile, vbTab & oshp.TextFrame.TextRange
End If ' msoPlaceholder
End If ' Has text frame/Has text


Next oshp
Next osld


'Close output file
Close #iFile


End Sub

[twz2004]

Not sure how to delete a post, I don't see the option, I was going to do some cleanup on this thread. I've made good progress on the script. However, the only thing that seems to be working on the Mac platform is the Text export. Images are not exporting like they are on the PC. When I run this final code on a PC everything seems to work great.



Option Explicit
Public core_path, pathsep As String


Public Sub Core_Module()


core_path = GetSetting("FPPT", "Export", "Default Path")


#If Mac Then


'sFile = sSubID & "-" & sSubSession & "-synced.txt"
On Error Resume Next
pathsep = ":"
core_path = MacScript("return (path to desktop folder) as String")
core_path = MacScript("(choose folder with prompt ""Select the folder""" & _
"default location alias """ & core_path & """) as string")

#Else


On Error Resume Next
pathsep = "\"
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = core_path
.AllowMultiSelect = False
.Title = "Select destination folder"
.Show
If .SelectedItems.Count = 1 Then
core_path = .SelectedItems(1)
Else
MsgBox "Nothing was saved"
End If
End With


core_path = core_path + pathsep


#End If


If core_path <> "" Then
'Open path For Output As #n
SaveSetting "FPPT", "Export", "Default Path", core_path
End If

'TextFormatChange
ExportText
ObjectsExport
ExportSpeakerNotes
MsgBox ("Done")

End Sub




Sub TextFormatChange()

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 = "Times New Roman"
.Size = 16
.Color.RGB = RGB(255, 255, 255)
.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
'Body text change values as required

If oshp.HasTextFrame Then
If oshp.TextFrame.HasText Then
With oshp.TextFrame.TextRange.Font
.Name = "Times New Roman (Body)"
.Size = 16
.Color.RGB = RGB(255, 255, 255)
.Bold = msoFalse
.Italic = msoFalse
.Shadow = False
End With
End If
End If

End If
End If
Next oshp
Next osld

End Sub


Sub ObjectsExport()


Dim oshp As Shape
Dim osld As Slide
Dim fn As String
Dim fn2 As String
Dim i As Long
Dim slidenum As Integer


For slidenum = 1 To ActivePresentation.Slides.Count


ActiveWindow.View.GotoSlide (slidenum)


On Error Resume Next


MkDir core_path & "Slides" & pathsep
MkDir core_path & "_Flatfolder" & pathsep
MkDir core_path & "Slides" & pathsep & "Slide-" & slidenum
MkDir core_path & "Slides" & pathsep & "Slide-" & slidenum & pathsep & "Text" & pathsep


For Each osld In ActiveWindow.Selection.SlideRange

For Each oshp In osld.Shapes


i = i + 1


fn = "slide-" & slidenum & "_object-" & CStr(i) & ".png"
fn2 = "slide-" & slidenum & "_object-" & CStr(i) & ".png"


If oshp.TextFrame.HasText Then
'skip
Else
Call oshp.Export(core_path & "Slides" & pathsep & "Slide-" & slidenum & pathsep & fn, ppShapeFormatPNG)
Call oshp.Export(core_path & "_Flatfolder" & pathsep & fn2, ppShapeFormatPNG)
End If


Next oshp

Next osld

Next slidenum


End Sub


Sub ExportText()


Dim oPres As Presentation
Dim oSlides As Slides
Dim osld As Slide 'Slide Object
Dim oshp As Shape 'Shape Object
Dim iFile As Integer 'File handle for output
iFile = FreeFile 'Get a free file number
Dim FileNum As Integer
Dim i As Integer


Set oPres = ActivePresentation
Set oSlides = oPres.Slides


On Error Resume Next


MkDir core_path & "Slides" & pathsep
MkDir core_path & "_Flatfolder" & pathsep


FileNum = FreeFile


'Open output file
' NOTE: errors here if file hasn't been saved
For Each osld In oSlides 'Loop thru each slide


i = i + 1


MkDir core_path & "Slides" & pathsep & "Slide-" & i
MkDir core_path & "Slides" & pathsep & "Slide-" & i & pathsep & "Text" & pathsep


Open core_path & "Slides" & pathsep & "Slide-" & i & pathsep & "Text" & pathsep & "Slide-" & i & "-Text.TXT" For Output As FileNum

For Each oshp In osld.Shapes 'Loop thru each shape on slide


'Check to see if shape has a text frame and text
If oshp.HasTextFrame And oshp.TextFrame.HasText Then
If oshp.Type = msoPlaceholder Then
Select Case oshp.PlaceholderFormat.Type
Case Is = ppPlaceholderTitle, ppPlaceholderCenterTitle
Print #iFile, "Title:" & vbTab & oshp.TextFrame.TextRange
Case Is = ppPlaceholderBody
Print #iFile, "Body:" & vbTab & oshp.TextFrame.TextRange
Case Is = ppPlaceholderSubtitle
Print #iFile, "SubTitle:" & vbTab & oshp.TextFrame.TextRange
Case Else
Print #iFile, "Other Placeholder:" & vbTab & oshp.TextFrame.TextRange
End Select
Else
Print #iFile, vbTab & oshp.TextFrame.TextRange
End If
End If


Next oshp

Close #iFile


Next osld


End Sub


Sub ExportSpeakerNotes()


Dim osldides As Slides
Dim osld As Slide
Dim oshp As Shape
Dim strNotesText As String
Dim strFileName As String
Dim iFile As Integer
Dim lngReturn As Long
Dim i As Integer


iFile = FreeFile()

On Error Resume Next


Set osldides = ActivePresentation.Slides

For Each osld In osldides

i = i + 1

For Each oshp In osld.NotesPage.Shapes
If oshp.PlaceholderFormat.Type = ppPlaceholderBody Then
If oshp.HasTextFrame Then
If oshp.TextFrame.HasText Then
strNotesText = strNotesText & "Slide: " & CStr(osld.SlideIndex) & vbCrLf _
& oshp.TextFrame.TextRange.Text & vbCrLf & vbCrLf
End If
End If
End If
Next oshp

Open core_path & "Slides" & pathsep & "Slide-" & i & pathsep & "Text" & pathsep & "Slide-" & i & "-Text.TXT" For Append As iFile
Print #iFile, ""
Print #iFile, "Speaker Notes:"
Print #iFile, strNotesText
Close #iFile

strNotesText = ""

Next osld


End Sub