Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1572to1576
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Powerpoint-Fußzeile aus Excel befüllen

Powerpoint-Fußzeile aus Excel befüllen
14.08.2017 09:51:43
PJ
Hallo zusammen,
ich habe auf Basis des Makros aus einem altem Forenbeitrags (https://www.herber.de/forum/archiv/1416to1420/1419848_Powerpoint_Dateien_per_Excel_Makro_zusammenfuegen.html) eine Excel-Datei gebastelt, mit der ich verschiedene Präsentationsbausteine zu einer Powerpoint-Datei zusammenfügen kann.
Nun würde ich das Makro gerne so ergänzen, dass das Textfeld der Fußzeile (sofern vorhanden) jeder Folie in der erstellten Präsentation mit einem Text befüllt wird, der aus einer Zelle der Excel-Datei ausgelesen wird. Der Platzhalter-Text soll dabei überschrieben werden und die Textformatierung des Textfeldes erhalten bleiben (alternativ kann die Formatierung gerne auch direkt im Makro hinterlegt werden). Das Textfeld ist in jeder Folie der "Fußzeilenplatzhalter 4".
Leider übersteigt das meine VBA-Fähigkeiten. Ich würde mich freuen, wenn mir jemand hier helfen könnte.
Vielen Dank schon einmal für eure Hilfe.
Gruß
Peter

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Habe Dir mal ein...
15.08.2017 09:44:08
PJ
Hallo Case,
vielen Dank für deine Links. Wenn ich den VBA-Code deiner beiden Makros richtig verstehe, dann benötige ich nur einen kleinen Ausschnitt (Schleife zur Textbox-Befüllung) davon, da das bestehende Makro bereits die PPT-Datei erstellt hat und die Datei noch offen ist.
Ich habe versucht den Code in das bestehende Makro einzufügen, aber ich scheitere immer daran, dass das Textfeld nicht gefunden wird (Item Footer Placeholder 4 not found in Shapes collection). Den Namen habe ich schon überprüft, daran liegt es nicht. Allerdings sind meine VBA-Kenntnisse bestenfalls rudimentär, so dass ich wahrscheinlich ein paar Fehler in das kurze Stück eingebaut habe.
Könntest du einen kurzen Blick auf den VBA-Code werfen?
Den Anfang und das Ende der Ergänzungen, die ich aus deinem Beispiel in das bestehende Makro eingefügt habe sich durch Striche (------) abgegrenzt.
Schon einmal vielen Dank für deine Hilfe.
Gruß
Peter
Option Explicit
' Hier ev. Spalteninhalte anpassen
Private Const cZeileQuellenStart = 2
Private Const cSpaltePfad = 1
Private Const cSpalteDateiname = 2
Private Const cSpalteDateierweiterung = 3
Public objRibbon As IRibbonUI
#If VBA7 Then
Declare PtrSafe Function SetWindowPos Lib "user32" _
(ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, _
ByVal x As Long, ByVal y As Long, ByVal cx As Long, _
ByVal cy As Long, ByVal wFlags As Long) As Long
#Else
Private Declare Function SetWindowPos Lib "user32" _
(ByVal hwnd As Long, ByVal hWndInsertAfter As Long, _
ByVal x As Long, ByVal y As Long, ByVal cx As Long, _
ByVal cy As Long, ByVal wFlags As Long) As Long
#End If
Const HWND_TOPMOST = -1
Const HWND_NOTOPMOST = -2
'Callback for customUI.onLoad
Public Sub RibbonOnLoad(ribbon As IRibbonUI)
Set objRibbon = ribbon
End Sub
'Callback for btnMerge onAction
Public Sub btnMergeOnAction(control As IRibbonControl)
PräsentationenZusammenfügen
End Sub
'============================================================
Sub PräsentationenZusammenfügen()
Dim strSrcFile As String, strSrcPath As String, strSrcExt As String
Dim strDestFile As String, strDestPath As String
Dim i As Long
Dim pptApp As Object, pptPres As Object
'---------------------------------------------------------------
Dim intTMP As Integer
Dim objPP As Object
Dim objPPPres As Object
Dim objPPDoc As Object
'----------------------------------------------------------------------
On Error GoTo ErrHandler
' PowerPoint-Application erstellen
Set pptApp = CreateObject("Powerpoint.Application")
' Zeile erste Quelldatei festlegen
i = cZeileQuellenStart
With ActiveSheet
'SlideImport starten
Do While .Cells(i, cSpalteDateiname).Text ""
' Dateiname ermitteln
' Pfad
If .Cells(i, cSpaltePfad).Text "" Then
strSrcPath = .Cells(i, cSpaltePfad).Text
strSrcPath = strSrcPath & IIf(Right(strSrcPath, 1) "\", "\", "")
End If
' Erweiterung
strSrcExt = .Cells(i, cSpalteDateierweiterung).Text
If strSrcExt = "" Then strSrcExt = ".pptx"
strSrcExt = IIf(Left(strSrcExt, 1) ".", ".", "") & strSrcExt
' Datei
strSrcFile = strSrcPath & .Cells(i, cSpalteDateiname) & strSrcExt
'Testen ob Datei vorhanden
If Dir(strSrcFile) = "" Then
MsgBox "Die Präsentation:" & vbLf _
& strSrcFile & vbLf _
& "konnte nicht eingefügt werden," & vbLf _
& "da sie nicht gefunden wurde!", _
vbExclamation, "Fehler"
Else
If i = cZeileQuellenStart Then
' Öffnen => Übernahme von SlideMaster
Set pptPres = pptApp.Presentations.Open(strSrcFile, , True)
Else
' Alle Folien einfügen
pptPres.Slides.InsertFromFile strSrcFile, pptPres.Slides.Count
End If
End If
i = i + 1 ' nächste Präsentation
Loop
End With
'----------------------------------------------------------------------------------------
Set objPP = GetObject(, "Powerpoint.Application")
With objPP
' Offene Präsentation bearbeiten
Set objPPPres = objPP.activepresentation
' Schleife über alle Folien
For intTMP = 1 To objPPPres.Slides.Count
Set objPPDoc = objPPPres.Slides(intTMP)
' Fusszeile TextBox mit Name: "Footer Placeholder 4" befüllen
objPPDoc.Shapes("Footer Placeholder 4").TextFrame.TextRange.Text = _
ThisWorkbook.Worksheets("MergeListe 1").Range("O15").Value
Set objPPDoc = Nothing
Next intTMP
End With
'------------------------------------------------------------------------------------------
' Erfolgsmeldung
With Application
pptApp.WindowState = 2 ' 2 = ppWindowMinimized
Call SetWindowPos(.hwnd, HWND_TOPMOST, 0, 0, 0, 0, 1)
MsgBox "Die Präsentation wurde erstellt. Bitte speichern Sie die Datei in Ihrem Ordner ab, bevor Sie diese bearbeiten.", vbInformation
Call SetWindowPos(.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, 1)
End With
ErrExit: ' Aufräumen
pptApp.Activate
Set pptPres = Nothing
Set pptApp = Nothing
Exit Sub
ErrHandler:
Dim strErrMsg As String
strErrMsg = "Ups, da ist ewas schiefgelaufen!" & vbLf & vbLf _
& "Fehlernummer: " & Err.Number & vbLf _
& Err.Description
On Error Resume Next ' Endlosschleife verhindern falls weitere Fehler
With Application
pptApp.WindowState = 2 ' 2 = ppWindowMinimized
Call SetWindowPos(.hwnd, HWND_TOPMOST, 0, 0, 0, 0, 1)
MsgBox strErrMsg, vbCritical, "Fehler"
Call SetWindowPos(.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, 1)
End With
Resume ErrExit
End Sub
Anzeige
Du hast doch schon...
15.08.2017 11:10:07
Case
Hallo Peter, :-)
... das Objekt "pptPres". Arbeite doch damit: ;-)
Du solltest Deinen Code etwas mehr strukturieren (z. B. Einrückungen) - sonst hat da keiner Lust sich mit auseinanderzusetzen. Mit meiner Beispiel PP-Datei also "Test.pptx" und "Footer Placeholder 3" geht das dann so: ;-)
Option Explicit
' Hier ev. Spalteninhalte anpassen
Private Const cZeileQuellenStart = 2
Private Const cSpaltePfad = 1
Private Const cSpalteDateiname = 2
Private Const cSpalteDateierweiterung = 3
Public objRibbon As IRibbonUI
#If VBA7 Then
Declare PtrSafe Function SetWindowPos Lib "user32" _
(ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, _
ByVal x As Long, ByVal y As Long, ByVal cx As Long, _
ByVal cy As Long, ByVal wFlags As Long) As Long
#Else
Private Declare Function SetWindowPos Lib "user32" _
(ByVal hwnd As Long, ByVal hWndInsertAfter As Long, _
ByVal x As Long, ByVal y As Long, ByVal cx As Long, _
ByVal cy As Long, ByVal wFlags As Long) As Long
#End If
Const HWND_TOPMOST = -1
Const HWND_NOTOPMOST = -2
'Callback for customUI.onLoad
Public Sub RibbonOnLoad(ribbon As IRibbonUI)
Set objRibbon = ribbon
End Sub
'Callback for btnMerge onAction
Public Sub btnMergeOnAction(control As IRibbonControl)
PräsentationenZusammenfügen
End Sub
Sub PräsentationenZusammenfügen()
Dim strSrcFile As String, strSrcPath As String, strSrcExt As String
Dim strDestFile As String, strDestPath As String
Dim i As Long
Dim pptApp As Object, pptPres As Object
Dim intTMP As Integer
Dim objPP As Object
Dim objPPPres As Object
Dim objPPDoc As Object
On Error GoTo ErrHandler
' PowerPoint-Application erstellen
Set pptApp = CreateObject("Powerpoint.Application")
' Zeile erste Quelldatei festlegen
i = cZeileQuellenStart
With ActiveSheet
'SlideImport starten
Do While .Cells(i, cSpalteDateiname).Text  ""
' Dateiname ermitteln
' Pfad
If .Cells(i, cSpaltePfad).Text  "" Then
strSrcPath = .Cells(i, cSpaltePfad).Text
strSrcPath = strSrcPath & IIf(Right(strSrcPath, 1)  "\", "\", "")
End If
' Erweiterung
strSrcExt = .Cells(i, cSpalteDateierweiterung).Text
If strSrcExt = "" Then strSrcExt = ".pptx"
strSrcExt = IIf(Left(strSrcExt, 1)  ".", ".", "") & strSrcExt
' Datei
strSrcFile = strSrcPath & .Cells(i, cSpalteDateiname) & strSrcExt
'Testen ob Datei vorhanden
If Dir(strSrcFile) = "" Then
MsgBox "Die Präsentation:" & vbLf _
& strSrcFile & vbLf _
& "konnte nicht eingefügt werden," & vbLf _
& "da sie nicht gefunden wurde!", _
vbExclamation, "Fehler"
Else
If i = cZeileQuellenStart Then
' Öffnen => Übernahme von SlideMaster
Set pptPres = pptApp.Presentations.Open(strSrcFile, , True)
Else
' Alle Folien einfügen
pptPres.Slides.InsertFromFile strSrcFile, pptPres.Slides.Count
End If
End If
For intTMP = 1 To pptPres.Slides.Count
Set objPPDoc = pptPres.Slides(intTMP)
' Fusszeile TextBox mit Name: "Footer Placeholder 3" befüllen
objPPDoc.Shapes("Footer Placeholder 3").TextFrame.TextRange.Text = _
ThisWorkbook.Worksheets("MergeListe 1").Range("O15").Value
Set objPPDoc = Nothing
Next intTMP
i = i + 1 ' nächste Präsentation
Loop
End With
'Set objPP = GetObject(, "Powerpoint.Application")
'With objPP
'' Offene Präsentation bearbeiten
'Set objPPPres = objPP.activepresentation
'' Schleife über alle Folien
'For intTMP = 1 To objPPPres.Slides.Count
'Set objPPDoc = objPPPres.Slides(intTMP)
'' Fusszeile TextBox mit Name: "Footer Placeholder 4" befüllen
'objPPDoc.Shapes("Footer Placeholder 4").TextFrame.TextRange.Text = _
'ThisWorkbook.Worksheets("MergeListe 1").Range("O15").Value
'Set objPPDoc = Nothing
'Next intTMP
'End With
' Erfolgsmeldung
With Application
pptApp.WindowState = 2 ' 2 = ppWindowMinimized
Call SetWindowPos(.hwnd, HWND_TOPMOST, 0, 0, 0, 0, 1)
MsgBox "Die Präsentation wurde erstellt. Bitte speichern Sie die Datei in Ihrem Ordner ab,  _
bevor Sie diese bearbeiten.", vbInformation
Call SetWindowPos(.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, 1)
End With
ErrExit: ' Aufräumen
pptApp.Activate
Set pptPres = Nothing
Set pptApp = Nothing
Exit Sub
ErrHandler:
Dim strErrMsg As String
strErrMsg = "Ups, da ist ewas schiefgelaufen!" & vbLf & vbLf _
& "Fehlernummer: " & Err.Number & vbLf _
& Err.Description
On Error Resume Next ' Endlosschleife verhindern falls weitere Fehler
With Application
pptApp.WindowState = 2 ' 2 = ppWindowMinimized
Call SetWindowPos(.hwnd, HWND_TOPMOST, 0, 0, 0, 0, 1)
MsgBox strErrMsg, vbCritical, "Fehler"
Call SetWindowPos(.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, 1)
End With
Resume ErrExit
End Sub
Du musst den Code natürlich noch aufräumen. :-)
Servus
Case

Anzeige
DAAAAAANKE!!!
15.08.2017 15:37:40
PJ
Hallo Case,
herzlichen Dank für deine Hilfe. Es funktioniert jetzt einwandfrei.
Ich hatte zuerst versucht mit dem Objekt "pptPres" zu arbeiten, aber nachdem es damit wegen der anderen Fehler nicht funktioniert hat, habe ich es mit deinen Objektnamen versucht. Hat natürlich aus den gleichen Gründen nicht funktioniert...
Im Original sieht der Code viel strukturierter aus. Wahrscheinlich hätte ich nur das Makro einfügen sollen und nicht den ganzen Inhalt des Editors. Oder ich hätte das manuell anpassen müssen. Das teste ich beim nächsten Mal ;-)
Nochmals vielen Dank für deine Unterstützung!
Viele Grüße
Peter
Anzeige
Gerne - Danke für die Rückmeldung! O. w. T.
15.08.2017 16:09:16
Case
:-)

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige