Bilder speichern

 

Home
Nach oben

Last Update 20.07.2004

Copyright  2003
Ramses (C)

 

Alle Folien der aktiven Präsentation als JPG-Bilder speichern

Alle *ppt in einem Ordner öffnen, darin neuen Ordner mit dem Namen der Präsentation angelegen und alle Folien als  *.jpg Bilder darin speichern.

 

 

 


Sub List_Files_in_all_folder()

Dim i As Long, TotFiles As Long

Dim gefFile As String, dname As String

Dim suchpfad As FileDialog, myFolder As Variant, suchbegriff As String, Dateiform As String

Dim SavePfad As String, myPfad As String, myName As String

Dim OldStatus As Variant

myPfad = ""

myName = ""

'Für alle Versionen

'---

'Suchpfad = InputBox("Geben Sie den Ordner an, der durchsucht werden soll.", "Pfad definieren", Application.Path)

'If Suchpfad = "" Then Exit Sub

'---

'für Powerpoint 2000/XP

Set suchpfad = Application.FileDialog(msoFileDialogFolderPicker)

With suchpfad

      If .Show = -1 Then

   For x = 1 To .SelectedItems.Count

           myFolder = myFolder & .SelectedItems(x)

      Next

   End If

End With

'----

Dateiform = InputBox("Geben Sie den Dateityp an der gesucht werden soll", "Dateierweiterung", "*.ppt")

If Dateiform = "" Then Exit Sub

qe = MsgBox("Alle Folien werden als *.jpg in einem Ordner gespeichert," & Chr$(13) & "der gleich lautet wie die jeweilige Präsentation.", vbCritical + vbDefaultButton1 + vbYesNo, "JPEG-Export in " & Pfad)

If qe = 7 Then

'Für alle Versionen

'---

'myPfad = InputBox("Bitte Laufwerk und Pfad angeben", "Laufwerk", Pfad)

'myName = InputBox("Ordner angeben wo die Folien gespeichert werden", "Laufwerk", Left(ActivePresentation.Name, Len(ActivePresentation.Name) - 4))

'---

'Für Powerpoint XP

With suchpfad

      'Es wurde ein Pfad ausgewählt

      If .Show = -1 Then

      For x = 1 To .SelectedItems.Count

           myPfad = myFolder & .SelectedItems(x)

      Next

     End If

End With

End If

With Application.FileSearch

      'Ordner durchsuchen

     .LookIn = myFolder

      'Keine Unterordner durchsuchen

     .SearchSubFolders = False

     'Dateityp der gesucht werden soll definieren

     .FileName = Dateiform

     'Ausführung wenn mindesten 1 Datei gefunden wurde

     If .Execute() > 0 Then

     For i = 1 To .FoundFiles.Count

           'Namen und Pfad auslesen

           gefFile = .FoundFiles(i)

           'Datei "gefFile" öffnen

           Presentations.Open FileName:=gefFile, ReadOnly:=msoFalse

           If myPfad <> "" Then

                  ActivePresentation.SaveAs FileName:=myPfad & "\" & myName, FileFormat:=ppSaveAsJPG, EmbedTrueTypeFonts:=msoFalse

           Else

                  ActivePresentation.SaveAs FileName:=myFolder & "\" & Left(ActivePresentation.Name, Len(ActivePresentation.Name) - 4),_

                  FileFormat:=ppSaveAsJPG,     EmbedTrueTypeFonts:=msoFalse

          End If

          ActiveWindow.Close

     Next i

     End If

End With

End Sub

 

 

Sub Save_All_Slides_As_JPG()
'Variablen definieren
Dim Pfad As String, myPfad As String, myName As String
'Pfad aus aktuelle Datei extrahieren
Pfad = Left(ActivePresentation.FullName, Len(ActivePresentation.FullName) - Len(ActivePresentation.Name))
'Ordnername definieren
qe = MsgBox("Alle Folien werden als *.jpg in einem Ordner gespeichert," & Chr$(13) & "der gleich lautet wie die jeweilige Präsentation.", vbCritical + vbDefaultButton1 + vbYesNo, "JPEG-Export in " & Pfad)
If qe = 7 Then
    myPfad = InputBox("Bitte Laufwerk und Pfad angeben", "Laufwerk", Pfad)
    myName = InputBox("Ordner angeben wo die Folien gespeichert werden", "Laufwerk", Left(ActivePresentation.Name, Len(ActivePresentation.Name) - 4))
    ActivePresentation.SaveAs FileName:=myPfad & "\" & myName, FileFormat:=ppSaveAsJPG, EmbedTrueTypeFonts:=msoFalse
End If
ActivePresentation.SaveAs FileName:=Left(ActivePresentation.FullName, Len(ActivePresentation.FullName) - 4), FileFormat:=ppSaveAsJPG, EmbedTrueTypeFonts:=msoFalse
End Sub