PowerPoint - alle Textfelder oder Objekte - Text auslesen...

Frage: Aus Excel heraus soll der Text aus allen Textboxen in Powerpoint ausgelesen werden. Dies soll aber auch bei Text in Objekten wie einem Pfeil funktionieren. Die Texte sollen in Excel in Spalte C fortlaufend aufgelistet werden. In Spalte A soll der Name der entsprechenden Folie. In Spalte B der Name der TextBox bzw. des Objektes. Wie geht das?

From Excel, the text is to be read from all TextBoxes in PowerPoint. But this should also work with text in objects like an arrow. The text should be listed consecutively in column C in Excel. In column A is the name of the corresponding slide. In column B is the name of the TextBox or the object. How does it work?

Hier noch eine Beispieldatei / Here's a sample file:
PowerPoint - alle Textfelder oder Objekte - Text auslesen...[ZIP 50 KB]

Option Explicit
Dim objPPApp As Object
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 28.05.2013
' Purpose   : PowerPoint - Alle Texte auslesen...
'--------------------------------------------------------------------------
Public Sub Main()
    ' Variablendeklaration
    Dim varArr1() As Variant
    Dim varArr2() As Variant
    Dim varArr() As Variant
    Dim objPPPres As Object
    Dim objShape As Object
    Dim objPPDoc As Object
    Dim intLeft As Integer
    Dim intTMP As Integer
    Dim lngCount As Long
    Dim lngCalc As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
    With Application
        ' Das Bildschirmaktualisierung wird unterbrochen
        .ScreenUpdating = False
        ' Ereignisroutinen werden deaktiviert
        .EnableEvents = False
        ' Auslesen der momentanen Einstellung für die Berechnung
        lngCalc = .Calculation
        ' Setzen der Berechnung auf "Manuell"
        .Calculation = xlCalculationManual
        '  Eingabeaufforderungen und Warnmeldungen unterdrücken
        .DisplayAlerts = False
    End With
    ' Arrays dimensionieren - größer als die zu erwartende Anzahl
    ' um ein Redim Preserve in der Schleife zu vermeiden
    ReDim varArr1(10000)
    ReDim varArr2(10000)
    ReDim varArr(10000)
    ' PowerPoint starten
    ' Wenn PowerPoint ausgeblendet werden soll, dann so:
    ' http://vbanet.blogspot.de/2010/09/excel-powerpoint.html
    ' Läuft NICHT in allen PowerPoint-Versionen
    Set objPPApp = OffApp("PowerPoint")
    If Not objPPApp Is Nothing Then
        With objPPApp
            ' Vorhandene Präsentation öffnen
            ' Ist in diesem Beispiel im gleichen Ordner
            ' wie die Exceldatei mit dem Code
            Set objPPPres = .Presentations.Open _
                (Filename:=ThisWorkbook.Path & _
                Application.PathSeparator & "Title.ppt")
            ' Schleife über alle Folien
            For intTMP = 1 To objPPPres.Slides.Count
                ' Objektvariable mit dem jeweiligen Slide belegen
                Set objPPDoc = objPPPres.Slides(intTMP)
                ' Jedes Shape auf dem entsprechenden Slide
                For Each objShape In objPPDoc.Shapes
                    ' Wenn ein Text vorhanden ist, dann...
                    If objShape.TextFrame.TextRange.Text <> "" Then
                        ' ... befülle die Arrays mit dem Text, dem Namen
                        ' des jeweiligen Shape und dem Namen der Folie
                        varArr(lngCount) = objShape.TextFrame.TextRange.Text
                        varArr1(lngCount) = objPPDoc.Name
                        varArr2(lngCount) = objShape.Name
                        lngCount = lngCount + 1
                    End If
                Next objShape
                ' Objektvariable leeren / zurücksetzen
                Set objPPDoc = Nothing
            Next intTMP
            ' Arrays auf die tatsächliche Größe reduzieren
            ReDim Preserve varArr1(lngCount)
            ReDim Preserve varArr2(lngCount)
            ReDim Preserve varArr(lngCount)
            ' Arrays im ersten Tabellenblatt ausgeben
            With ThisWorkbook.Worksheets(1)
                .Cells(1, 1).Resize(UBound(varArr1) + 1) = _
                    WorksheetFunction.Transpose(varArr1)
                .Cells(1, 2).Resize(UBound(varArr2) + 1) = _
                    WorksheetFunction.Transpose(varArr2)
                .Cells(1, 3).Resize(UBound(varArr) + 1) = _
                    WorksheetFunction.Transpose(varArr)
            End With
            ' Präsentation Schliessen
            objPPPres.Close
            ' PP beenden
            .Quit
        End With
    Else
        MsgBox "Application not installed!"
    End If
Fin:
    ' Objektvariablen zurücksetzen
    Set objPPDoc = Nothing
    Set objPPPres = Nothing
    Set objPPApp = Nothing
    ' Die Applikation aufwecken
    With Application
        ' Bildschirmaktualisierung wieder einschalten
        .ScreenUpdating = True
        ' Ereignisroutinen werden wieder aktiviert
        .EnableEvents = True
        ' Setzen der Berechnung auf den gemerkten Wert
        .Calculation = lngCalc
        ' Eingabeaufforderungen und Warnmeldungen wieder zulassen
        .DisplayAlerts = True
        ' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens
        .CutCopyMode = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : OffApp
' Author    : Case (Ralf Stolzenburg)
' Date      : 28.05.2013
' Purpose   : Start application...
'--------------------------------------------------------------------------
Private Function OffApp(ByVal strApp As String, _
    Optional blnVisible As Boolean = True) As Object
    On Error Resume Next
    Set objPPApp = GetObject(, strApp & ".Application")
    Select Case Err.Number
        Case 429
            Err.Clear
            Set objPPApp = CreateObject(strApp & ".Application")
            If blnVisible = True Then
                On Error Resume Next
                objPPApp.Visible = True
                Err.Clear
            End If
    End Select
    On Error GoTo 0
    Set OffApp = objPPApp
    Set objPPApp = Nothing
End Function

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...