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