Consulting

Results 1 to 7 of 7

Thread: PowerPoint Object Export. Please Help!

  1. #1
    VBAX Regular
    Joined
    Apr 2018
    Posts
    7
    Location

    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:

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

    qq.jpg

    Any help would be awesome! Thanks so much!

  2. #2
    VBAX Master
    Joined
    Feb 2007
    Posts
    2,093
    Location
    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
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  3. #3
    VBAX Regular
    Joined
    Apr 2018
    Posts
    7
    Location
    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.

  4. #4
    VBAX Regular
    Joined
    Apr 2018
    Posts
    7
    Location
    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

  5. #5
    VBAX Master
    Joined
    Feb 2007
    Posts
    2,093
    Location
    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
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  6. #6
    VBAX Regular
    Joined
    Apr 2018
    Posts
    7
    Location
    Quote Originally Posted by John Wilson View Post
    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

  7. #7
    VBAX Regular
    Joined
    Apr 2018
    Posts
    7
    Location

    Final working code.. but question...

    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
    Last edited by twz2004; 04-16-2018 at 05:24 PM.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •