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