28.05.2013

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

14.05.2013

Variablendeklaration...

Frage: Immer wieder taucht die Frage auf - wie deklariere ich meine Variablen richtig, bzw. wie dimensioniere ich ausreichend ohne immer Variant zu verwenden?
z. B. über den Objektkatalog (F2 im VBA Editor). Oder man schreibt einen kleinen Code und deklariert die Variable nicht (z. B. Dim strTMP). Wenn nun mit der Taste F8 Schritt für Schritt der Code ausgeführt wird sieht man im Lokalfenster die richtige Dimensionierung vorgegeben (z. B. Variant/Long). Wobei Variant der momentane Wert der Variablen ist (weil nicht dimensioniert), Long von MS vorgegeben wird.

Again and again the question arises - how do I declare my variables correctly, and how do I dimension sufficient without ever Variant to use?
eg, using the Object Browser (F2 in the VBA editor). Or you can write a little code and the variable is not declared (eg Dim strTMP). Now, if the F8 key step by step the code is executed you can see the correct dimensions specified in the local window (eg Variant / Long). Wherein said variant is the current value of the variable (because not dimensioned) Long MS is preset.

Zu Lokalfenster siehe / Locals window to see:
Lokalfenster / Locals window

Hier noch eine Beispieldatei / Here's a sample file.
Nur Excel >= 2007, da XLSB-Datei / Only Excel >= 2007 because XLSB file:
Variablendeklaration...[XLSB 3 MB]

Option Explicit
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 14.05.2013
' Purpose   : Variablendeklaration...
'--------------------------------------------------------------------------
Sub Main()
    Dim lngColumn   'As Long
    Dim lngRow      'As Long
    Dim rngRange1   'As Range
    Dim rngRange    'As Range
    Dim shpShape    'As Shape
    Dim objShape    'As Object
    Dim strTMP      'As String
    Dim varArr      'As Variant
    Dim varArr1(5)  'As Variant
    Dim objPicture1 'As OLEObject
    Dim objPicture  'As Object
    Dim chtChart    'As ChartObject
    ' Auch sowas ist möglich..., aber eher nicht praktikabel :-)
    Dim DonauDampfschifffahrtsgesellschaftskapitaenspatentunterschrift As String
    On Error GoTo Fin
    ' Anzahl der Spalten
    lngColumn = Columns.Count
    ' Anzahl der Zeilen
    lngRow = Rows.Count
    ' Ohne Set und als Variant deklariert wird ein Array draus
    rngRange1 = Range("A1:C10")
    ' Der Bereich A1:C10 wird der Objektvariablen zugewiesen
    Set rngRange = Range("A1:C10")
    ' Das "erste" Shape wird der Objektvariablen zugewiesen
    Set shpShape = Sheet1.Shapes(1)
    ' Das "erste" Shape wird der Objektvariablen zugewiesen
    Set objShape = Sheet1.Shapes(1)
    ' Die Stringvariable wird gefüllt
    strTMP = "Test"
    ' Das Array wird gefüllt
    varArr = Range("A1:C10")
    ' Das zweite Feld des mit 6 Feldern vorbelegten Arrays wird gefüllt
    varArr1(1) = Range("A1")
    ' Die Objektvariable wird mit einem OLEObjekt,
    ' hier ein Imageelement, belegt
    Set objPicture1 = Sheet1.OLEObjects(1)
    ' Hier nochmal statt mit OLEObjects mit der Shapesauflistung
    Set objPicture = Sheet1.Shapes(1)
    ' Objektvariable mit ChartObjects-Auflistung (1) belegt
    Set chtChart = Sheet1.ChartObjects(1)
    ' Code stoppt hier automatisch
    Stop
Fin:
    ' Objektvariablen leeren
    Set chtChart = Nothing
    Set objPicture = Nothing
    Set objPicture1 = Nothing
    Set rngRange = Nothing
    Set shpShape = Nothing
    Set objShape = Nothing
    ' Eventuell auftretenden Fehler ausgeben
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
Sub Main_1()
    Dim lngColumn   As Long
    Dim lngRow      As Long
    ' Wenn das Kommentarzeichen vor "As Range" entfernt wird,
    ' läuft der Code auf einen Fehler, denn "rngRange1" muss als
    ' Objektvariable mit Set belegt werden.
    ' Oben funktioniert das noch, da es Variant ist,
    ' ergibt aber das "falsche" Ergebnis, da dann ein Array erzeugt wird
    Dim rngRange1   'As Range
    Dim rngRange    As Range
    Dim shpShape    As Shape
    Dim objShape    As Object
    Dim strTMP      As String
    Dim varArr      As Variant
    Dim varArr1(5)  As Variant
    Dim objPicture1 As OLEObject
    Dim objPicture  As Object
    Dim chtChart    As ChartObject
    Dim DonauDampfschifffahrtsgesellschaftskapitaenspatentunterschrift As String
    On Error GoTo Fin
    lngColumn = Columns.Count
    lngRow = Rows.Count
    rngRange1 = Range("A1:C10")
    Set rngRange = Range("A1:C10")
    Set shpShape = Sheet1.Shapes(1)
    Set objShape = Sheet1.Shapes(1)
    strTMP = "Test"
    varArr = Range("A1:C10")
    varArr1(1) = Range("A1")
    Set objPicture1 = Sheet1.OLEObjects(1)
    Set objPicture = Sheet1.Shapes(1)
    Set chtChart = Sheet1.ChartObjects(1)
    Stop
Fin:
    Set chtChart = Nothing
    Set objPicture = Nothing
    Set objPicture1 = Nothing
    Set rngRange = Nothing
    Set shpShape = Nothing
    Set objShape = Nothing
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

03.05.2013

PowerPoint - bestehende Datei - vorhandene TextBoxen befüllen...

Frage: Der Inhalt von einigen Zellen (im Beispiel von A1 bis A16) soll nach Powerpoint kopiert werden. In eine vorhandene Datei mit schon bestehenden TextBoxen. Wie geht das?

The content of some cells (in the example from A1 to A16) to be copied to PowerPoint. To an existing file with existing text boxes. How does it work?

Hier noch eine Beispieldatei / Here's a sample file:
PowerPoint - bestehende Datei - vorhandene TextBoxen befüllen...[ZIP 60 KB]

Option Explicit
' Speichername der Datei
Const strPPSave As String = "EXCELnachPP" ' anpassen!!!
' Leeres Slide in PowerPoint
Const ppLayoutBlank As Long = 12
' Objektvariable für Applikation
Dim objPP As Object
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 03.05.2013
' Purpose   : PowerPoint - Template - TextBoxen befüllen...
'--------------------------------------------------------------------------
Public Sub Main()
    ' Variablendeklaration
    Dim objPPPres As Object
    Dim objPPDoc As Object
    Dim intLeft As Integer
    Dim intTMP As Integer
    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
    ' PowerPoint starten
    ' Wenn PowerPoint ausgeblendet werden soll, dann so:
    ' http://vbanet.blogspot.de/2010/09/excel-powerpoint.html
    Set objPP = OffApp("PowerPoint")
    If Not objPP Is Nothing Then
        With objPP
            ' Vorhandene Präsentation öffnen
            Set objPPPres = .Presentations.Open _
                (Filename:=ThisWorkbook.Path & _
                Application.PathSeparator & "Template1.ppt")
            Set objPPDoc = objPPPres.Slides(1)
            ' Schleife um 16 Zellinhalte nach 16 TextBoxen in PP zu kopieren
            For intTMP = 1 To 16
                objPPDoc.Shapes(intTMP).TextFrame.TextRange.Text = " Inhalt aus " & _
                    ThisWorkbook.Worksheets(1).Cells(intTMP, 1).Value
            Next intTMP
            ' Unter neuem Namen speichern
            objPPPres.SaveAs ThisWorkbook.Path & _
                Application.PathSeparator & strPPSave & _
                Format(Now, "ddMMyyyy_hhmmss")
            ' 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 objPP = 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      : 03.05.2013
' Purpose   : Start application...
'--------------------------------------------------------------------------
Private Function OffApp(ByVal strApp As String, _
    Optional blnVisible As Boolean = True) As Object
    On Error Resume Next
    Set objPP = GetObject(, strApp & ".Application")
    Select Case Err.Number
        Case 429
            Err.Clear
            Set objPP = CreateObject(strApp & ".Application")
            If blnVisible = True Then
                On Error Resume Next
                objPP.Visible = True
                Err.Clear
            End If
    End Select
    On Error GoTo 0
    Set OffApp = objPP
    Set objPP = Nothing
End Function

Formeln auf einer UserForm in einer TextBox darstellen...

Formeln auf einer UserForm in einer TextBox anzeigen. Z. B. "Formula", "FormulaLocal"... und wie muss die Formel in VBA ...