none
Sending a command to Word 2010 from within PowerPoint 2010 RRS feed

  • Question

  • Hi--I'm trying to paste the contents of each PowerPoint slide into a Word document so that I can use "Track Changes"--a feature sadly missing in PP. Anyway, so far I have this code:

    Sub tryit2()
    Dim myWd As Word.Application
    Set myWd = New Word.Application


    With myWd
    .Visible = True
    .Documents.Add


    For j = 1 To 3
    Presentations(1).Slides(j).Shapes.Range.Copy

    With .Documents(1)
    .Range.Paste
    End With
    Next j

    .Quit
    End With


    End Sub

    This does paste all of the material on slides 1 to 3 into Word, but each set of shapes is pasted onto the single page of the document; I want each slide's shapes to appear on separate pages. I've tried a variety of ways to send a page break command to Word within this macro, but no luck. Can anyone help? Thanks!
    Monday, December 12, 2016 11:44 PM

All replies

  • Manipulation the Word object from PowerPoint (or any of the office apps) with VBA  is essentially the same. Try the following:

    Option Explicit
    
    Sub tryit3()
    'Graham Mayor - http://www.gmayor.com - Last updated - 13/12/2016'
    Dim myWd As Object
    Dim oRng As Object
    Dim oDoc As Object
    Dim j As Long
    
        On Error Resume Next
        Set myWd = GetObject(, "Word.Application")
        If Err Then
            Set myWd = CreateObject("Word.Application")
        End If
    
        With myWd
            .Visible = True
            Set oDoc = .Documents.Add
            oDoc.PageSetup.Orientation = 1
        End With
    
        For j = 1 To 3
            Presentations(1).Slides(j).Shapes.Range.Copy
            If j > 1 Then
                Set oRng = oDoc.Range
                oRng.collapse 0
                oRng.insertbreak 7
            End If
            Set oRng = oDoc.Range
            oRng.collapse 0
            oRng.Paste
        Next j
    lbl_Exit:
        Set myWd = Nothing
        Set oDoc = Nothing
        Set oRng = Nothing
        Exit Sub
    End Sub
    


    Graham Mayor - Word MVP
    www.gmayor.com

    Tuesday, December 13, 2016 11:13 AM
  • Hi Damon,

    Here are my 3 answers to your question.

    #1 - if what you really want is to "Track Change" PowerPoint, have you tried the "Compare" function, which is on the Review tab of PowerPoint. It provides, slide by slide, the changes made between saved versions of the PowerPoint deck.

    #2 - you might checkout one of my already available products, which is called "George for PowerPoint." It is an add-in to PowerPoint and one of its features is to extract PowerPoint slide content and place it into a Word document. The add-in does have fee, but at $39.00 U.S. I'm sure you'll spend a lot more than that trying to write your own code. Here is a screenshot of the extract feature.

    #3- If you really want to write your own VBA code and get at the text contained in all of the various shapes a PowerPoint slide contains... you will need a core routine that looks something like the following:

    Private Sub InsertText(ByVal sld As PowerPoint.Slide)
        Dim shp As PowerPoint.Shape
        Dim textRange As String
        Dim gi As PowerPoint.GroupShapes
        Dim r As Integer, c As Integer
        
        On Error GoTo errHandler
        Me.MsgText.Caption = frmExtText3 & " " & sld.SlideNumber
        rng.InsertParagraphBefore
        rng.Collapse (Word.WdCollapseDirection.wdCollapseEnd)
        With rng
            .Text = frmExtText3 & " " & sld.SlideNumber & ":"
            .Font.Underline = Word.WdUnderline.wdUnderlineSingle
        End With
        rng.Collapse (Word.WdCollapseDirection.wdCollapseEnd)
        
        For Each shp In sld.Shapes
            If InStr(1, shp.Name, "Date Placeholder") Or InStr(1, shp.Name, "Slide Number Placeholder") Then
                GoTo NextShape
            End If
            If shp.HasTextFrame = Office.MsoTriState.msoTrue Then
                If shp.TextFrame.HasText = Office.MsoTriState.msoTrue Then
                    textRange = shp.TextFrame.textRange.Text
                    rng.InsertParagraphBefore
                    rng.InsertAfter (textRange)
                    rng.Collapse (Word.WdCollapseDirection.wdCollapseEnd)
                End If
            ElseIf shp.type = Office.MsoShapeType.msoPlaceholder Then
                If shp.PlaceholderFormat.ContainedType = Office.MsoShapeType.msoSmartArt Then
                    On Error Resume Next
                    Set gi = shp.GroupItems
                    If gi.Count > 0 Then
                        For r = 1 To gi.Count
                            If gi(r).TextFrame.HasText Then
                                textRange = gi(r).TextFrame.textRange.Text
                                rng.InsertParagraphBefore
                                rng.InsertAfter (textRange)
                                rng.Collapse (Word.WdCollapseDirection.wdCollapseEnd)
                                textRange = ""
                            End If
                        Next
                    End If
                End If
                On Error GoTo errHandler
                If shp.PlaceholderFormat.ContainedType = Office.MsoShapeType.msoTable Then
                    For r = 1 To shp.Table.Rows.Count
                        For c = 1 To shp.Table.Columns.Count
                            If shp.Table.Cell(r, c).Shape.TextFrame.HasText Then
                                textRange = shp.Table.Cell(r, c).Shape.TextFrame.textRange.Text
                                rng.InsertParagraphBefore
                                rng.InsertAfter (textRange)
                                rng.Collapse (Word.WdCollapseDirection.wdCollapseEnd)
                            End If
                        Next
                    Next
                End If
            ElseIf shp.type = Office.MsoShapeType.msoTable Or shp.HasTable = Office.MsoTriState.msoTrue Then
                For r = 1 To shp.Table.Rows.Count
                    For c = 1 To shp.Table.Columns.Count
                        If shp.Table.Cell(r, c).Shape.TextFrame.HasText Then
                            textRange = shp.Table.Cell(r, c).Shape.TextFrame.textRange.Text
                            rng.InsertParagraphBefore
                            rng.InsertAfter (textRange)
                            rng.Collapse (Word.WdCollapseDirection.wdCollapseEnd)
                        End If
                    Next
                Next
            ElseIf shp.type = Office.MsoShapeType.msoSmartArt Then
                On Error Resume Next 'required this because of error while testing
                Set gi = shp.GroupItems
                If gi.Count > 0 Then
                    For r = 1 To gi.Count
                        If gi(r).TextFrame.HasText Then
                            textRange = gi(r).TextFrame.textRange.Text
                            rng.InsertParagraphBefore
                            rng.InsertAfter (textRange)
                            rng.Collapse (Word.WdCollapseDirection.wdCollapseEnd)
                            textRange = "" 'added due to error while testing. This results in an empty paragraph versus inserting same word twice because of an error
                            'I don't know why this error occurred on the test file
                        End If
                    Next
                End If
                On Error GoTo errHandler
            ElseIf shp.type = Office.MsoShapeType.msoComment Or shp.type = Office.MsoShapeType.msoCallout Then
                MsgBox ("Comment")
                Set gi = shp.GroupItems
                If gi.Count > 0 Then
                    For r = 1 To gi.Count
                        If gi(r).TextFrame.HasText Then
                            textRange = gi(r).TextFrame.textRange.Text
                            rng.InsertParagraphBefore
                            rng.InsertAfter textRange
                            rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
                        End If
                    Next
                End If
            End If
    
    NextShape:
        Next
        
        rng.InsertParagraphAfter
        rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
        Exit Sub
    
    errHandler:
        MsgBox Err.Description, vbCritical, frmExtText4
        Err.Clear
        rng.InsertParagraphAfter
        rng.MoveStart Word.WdUnits.wdParagraph, Count:=1
    End Sub
    
    I hope one of these responses help you.


    Kind Regards, Rich ... http://greatcirclelearning.com

    Wednesday, December 14, 2016 11:38 AM