PowerPoint Object Export. Please Help!

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:

Code:

---

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).

Attachment 22016

Any help would be awesome! Thanks so much!

This (top of head code) should get you close

Code:

---

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

---

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.

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.

Code:

---

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

---

Maybe

Code:

---

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

---

Quote:

---

Originally Posted by John Wilson

Maybe

Code:

---

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.

Code:

---

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

---

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.

Code:

---

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

---