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]
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]
OptionExplicit
DimobjPPAppAsObject
'--------------------------------------------------------------------------
' Module : Module1
' Procedure : Main
' Author : Case (Ralf Stolzenburg)
' Date : 28.05.2013
' Purpose : PowerPoint - Alle Texte auslesen...
'--------------------------------------------------------------------------
PublicSubMain()
' Variablendeklaration
DimvarArr1()AsVariant
DimvarArr2()AsVariant
DimvarArr()AsVariant
DimobjPPPresAsObject
DimobjShapeAsObject
DimobjPPDocAsObject
DimintLeftAsInteger
DimintTMPAsInteger
DimlngCountAsLong
DimlngCalcAsLong
' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
OnErrorGoToFin
' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
WithApplication
' 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
EndWith
' Arrays dimensionieren - größer als die zu erwartende Anzahl
' um ein Redim Preserve in der Schleife zu vermeiden
ReDimvarArr1(10000)
ReDimvarArr2(10000)
ReDimvarArr(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
SetobjPPApp=OffApp("PowerPoint")
IfNotobjPPAppIsNothingThen
WithobjPPApp
' Vorhandene Präsentation öffnen
' Ist in diesem Beispiel im gleichen Ordner
' wie die Exceldatei mit dem Code
SetobjPPPres=.Presentations.Open_
(Filename:=ThisWorkbook.Path&_
Application.PathSeparator&"Title.ppt")
' Schleife über alle Folien
ForintTMP=1ToobjPPPres.Slides.Count
' Objektvariable mit dem jeweiligen Slide belegen
SetobjPPDoc=objPPPres.Slides(intTMP)
' Jedes Shape auf dem entsprechenden Slide
ForEachobjShapeInobjPPDoc.Shapes
' Wenn ein Text vorhanden ist, dann...
IfobjShape.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
EndIf
NextobjShape
' Objektvariable leeren / zurücksetzen
SetobjPPDoc=Nothing
NextintTMP
' Arrays auf die tatsächliche Größe reduzieren
ReDimPreservevarArr1(lngCount)
ReDimPreservevarArr2(lngCount)
ReDimPreservevarArr(lngCount)
' Arrays im ersten Tabellenblatt ausgeben
WithThisWorkbook.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)
EndWith
' Präsentation Schliessen
objPPPres.Close
' PP beenden
.Quit
EndWith
Else
MsgBox"Application not installed!"
EndIf
Fin:
' Objektvariablen zurücksetzen
SetobjPPDoc=Nothing
SetobjPPPres=Nothing
SetobjPPApp=Nothing
' Die Applikation aufwecken
WithApplication
' 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
EndWith
' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
IfErr.Number<>0ThenMsgBox"Error: "&_
Err.Number&" "&Err.Description
EndSub
'--------------------------------------------------------------------------
' Module : Module1
' Procedure : OffApp
' Author : Case (Ralf Stolzenburg)
' Date : 28.05.2013
' Purpose : Start application...
'--------------------------------------------------------------------------
PrivateFunctionOffApp(ByValstrAppAsString,_
OptionalblnVisibleAsBoolean=True)AsObject
OnErrorResumeNext
SetobjPPApp=GetObject(,strApp&".Application")
SelectCaseErr.Number
Case429
Err.Clear
SetobjPPApp=CreateObject(strApp&".Application")
IfblnVisible=TrueThen
OnErrorResumeNext
objPPApp.Visible=True
Err.Clear
EndIf
EndSelect
OnErrorGoTo0
SetOffApp=objPPApp
SetobjPPApp=Nothing
EndFunction