14.08.2017

PowerPoint - Fusszeile - TextBox befüllen - alle Folien...

PowerPoint alle Folien - in der Fusszeile die Textbox befüllen.

PowerPoint all slides - fill the text box in the footer.

Hier noch eine Beispieldatei / Here's a sample file:
PowerPoint - Fusszeile - TextBox befüllen - alle Folien...[ZIP 50 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      : 14.08.2017
' Purpose   : PowerPoint - Fusszeile - TextBox 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 GLEICHER Ordner wie die Exceldatei
            Set objPPPres = .Presentations.Open _
                (Filename:=ThisWorkbook.Path & _
                Application.PathSeparator & "Test.pptx")
            ' Schleife über alle Folien
            For intTMP = 1 To objPPPres.Slides.Count
                Set objPPDoc = objPPPres.Slides(intTMP)
                ' Fusszeile TextBox mit Name: "Footer Placeholder 3" befüllen
                objPPDoc.Shapes("Footer Placeholder 3").TextFrame.TextRange.Text = _
                    ThisWorkbook.Worksheets("Tabelle1").Range("C3").Value
                Set objPPDoc = Nothing
            Next intTMP
            ' Unter neuem Namen speichern
            objPPPres.SaveAs ThisWorkbook.Path & _
                Application.PathSeparator & strPPSave & _
                Format(Now, "ddMMyyyy_hhmmss")
            ' Auf langsamen Netzlaufwerken kann es zu Problemen kommen (Speichern)
            ' Deshalb hier 2 Sekunden Wartezeit - kann natürlich
            ' bei Bedarf auskommentiert bzw. verändert werden
            Application.Wait Now + TimeSerial(0, 0, 2)
            ' 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      : 14.08.2017
' 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 ...