AW: PP-Präsentation aus Excel-Tabelle zusammenstellen
31.08.2008 19:04:59
Ramses
Hallo
Sorry, mein Fehler. Die zu importierenden Dateien haben ja nur 1 Folie
Probier mal das aus
Option Explicit
Sub CreateNewPowerPointPresentation()
'(C) Ramses
'Import aus einer externen Powerpoint Präsentation spezifische
'Folien und speichert diese in der angegebenen Nummerierung in
'einer neuen Präsentation
'-----------------------
'Die Tabelle muss in A1 der aktiven Tabelle den kompletten Pfad zur importierenden Präsentation haben
'In der Spalte A werden die jeweiligen durch eine Zahl markierte Folie importiert
'Die Zahlen in der Spalte A geben die Anordnung der zu importierenden Folien an
'Die zu importierende Datei wird aus den Einträgen in der Spalte C und D gebildet
'-----------------------
Dim myPP As Object, newTarPP As Object
Dim srcFile As String, newPPtar As String, newPPspec As String, tarPPPath As String
Dim i As Long
Dim startRow As Long, endRow As Long
Dim totSlides As Long, sinSlide As Long
'*************************************
'Anpassungen vornehmen
'Hier beginnen die Daten in der Tabelle
startRow = 4
'Ab hier keine Änderungen mehr vornehmen
'*************************************
On Error GoTo myErrorHandler
'Spezifischen Dateiname abfragen
newPPspec = InputBox("Geben Sie den Dateinamen an. " & vbCrLf & vbCrLf & _
"ACHTUNG: Keine Sonderzeichen wie ""/"", ""\"", "":"", "";"", ""@"" oder ähnliches verwenden." & vbCrLf & vbCrLf & _
"Die Datei wird als Präfix das Datum im Format ""YYYY-MM-DD"" haben", "Dateiname definieren", "Neue Präsentation")
If StrPtr(newPPspec) = 0 Then
MsgBox "Kein Dateinamen angegeben", vbCritical + vbOKOnly, "Fehler"
Exit Sub
End If
'Neues PP Object erstellen
Set myPP = CreateObject("Powerpoint.Application")
'Quellpäsentation definieren
srcFile = Range("a1").Text
'*******************************
'
'Zielpfad automatisch ermitteln
'Allenfalls auskommentieren mit Hochkomma
tarPPPath = Range("A1").Text
If Right(tarPPPath, 1) <> "\" Then
tarPPPath = tarPPPath & "\"
End If
'*******************************
'Neuer Name für Präsentation definieren
newPPtar = Format(Date, "YYYY-MM-DD") & newPPspec & ".ppt"
'Neue Präsentation anlegen
Set newTarPP = myPP.presentations.Add
'Letzten Eintrag in Spalte a feststellen
endRow = Cells(Rows.Count, 1).End(xlUp).Row
'Anzahl Folien feststellen für die Import Informationen in der Statusbar
totSlides = Application.WorksheetFunction.Count(Range(Cells(startRow, 1), Cells(endRow, 1)))
'SlideCounter definieren
sinSlide = 1
With newTarPP
'SlideImport starten
For i = startRow To endRow
If Cells(i, 1) <> "" Then
'Dateinamen zusammensetzen
srcFile = tarPPPath & Cells(i, 3) & Cells(i, 4)
'Datei auf existenz prüfen
'Testen ob Datei vorhanden
If Dir(srcFile) = "" Then
MsgBox "Quelldatei: " & srcFile & " wurde nicht gefunden.", vbCritical + vbOKOnly, "Fehler"
Exit Sub
End If
'Benutzerhinweis
Application.StatusBar = "Import Slide: " & sinSlide & " von " & totSlides & " Folien"
'Folie/n importieren
'Importsyntax lautet:
'.Slides.InsertFromFile Dateiname, An welche Position, Folie Von, Folie Bis
'"An welche Position" bedeutet hier zunächst ans Ende setzen, also ".Slides.Count"
'.Slides.InsertFromFile srcFile, .Slides.Count, Cells(i, 1).Value, Cells(i, 1).Value
'
'Die hier zu importierenden Präsentationen haben NUR 1 Folie
.Slides.InsertFromFile srcFile, .Slides.Count, 1, 1
'
'Slidecounter hochsetzen = Hilfsvariable für Statusbar-Anzeige
sinSlide = sinSlide + 1
End If
Next i
'Benutzerhinweis
Application.StatusBar = "Die Folien werden sortiert"
sinSlide = 1
For i = startRow To endRow
If Cells(i, 1) <> "" Then
'Benutzerhinweis
Application.StatusBar = "Verschiebe Folie: " & sinSlide & " von " & totSlides & " Folien"
.Slides(sinSlide).moveto topos:=Cells(i, 1).Value
sinSlide = sinSlide + 1
End If
Next i
.SaveAs tarPPPath & " " & newPPtar
End With
'Benutzerhinweis
MsgBox "Slideimport vollständig durchgeführt", vbInformation + vbOKOnly, "Abschluss"
'Ausstiegspunkt für den Fehlerhandler
ErrorExit:
'Statusbar zurücksetzen
Application.StatusBar = False
Exit Sub
myErrorHandler:
MsgBox "Folgender Fehler ist aufgetreten: " & vbCrLf & Err.Number & vbCrLf & vbCrLf & Err.Description, vbOKOnly + vbCritical, "Fehler"
Resume ErrorExit
End Sub
Gruss Rainer
