VBA pour exporter des images de PowerPoint avec Section et Titre comme nom de fichier

Question

Je travaille actuellement sur une solution pour un groupe au sein de notre entreprise qui leur permettra de créer des diapositives en utilisant PowerPoint 2013 à partir d'une présentation PowerPoint en résolution HD avec des noms de fichiers spécifiques sera utilisé comme affichage numérique via un système différent qui ne prend pas en charge les fichiers PowerPoint.

Je cherchais une solution utilisant VBA pour exporter les fichiers au besoin, mais je n'ai pas vraiment atteint la cible. Je ne suis pas moi-même programmeur VBA et j'ai fait de mon mieux pour compiler quelque chose qui est proche de mes besoins.

exigences précises:

• entrée de demande de l'utilisateur pour le répertoire d'exporter vers
• exporter des diapositives au format PNG à résolution 1920 x 1080
• Seules les diapositives à l'exportation où le fichier n'existe pas déjà
• Le format du nom de fichier est [Section Name] [Slide Title] [Unique Title Number].png, et à défaut de glisser un titre dans la diapositive, remplacez [Slide Title] par [Placeholder Title], exemple (sans crochets): [KS4 All Temp] [20160630 20160731 Casual Dress] [1].png.
  • Le numéro Titre unique devrait partir de 1 pour chaque diapositive, sauf lorsque plusieurs diapositives du même nom exact sont générés, le nombre devrait augmenter par diapositive pour ce nom de fichier

ici est le code que j'ai jusqu'à présent:

Option Explicit 
Const ImageBaseName As String = "Slide_" 
Const ImageWidth As Long = 1920 
Const ImageHeight As Long = 1080 
Const ImageType As String = "PNG" 

Function fileExists(s_directory As String, s_fileName As String) As Boolean 

    Dim obj_fso As Object 

    Set obj_fso = CreateObject("Scripting.FileSystemObject") 
    fileExists = obj_fso.fileExists(s_directory & "\" & s_fileName) 

End Function 

Sub ExportSlides() 

    Dim oSl As Slide 
    Dim Path As String 
    Dim File As String 
    Dim i As Long 

    If ActivePresentation.Path = "" Then 
     MsgBox "Please save the presentation then try again" 
     Exit Sub 
    End If 

    Application.FileDialog(msoFileDialogFolderPicker).ButtonName = "Select Path" 

    Path = GetSetting("FPPT", "Export", "Default Path") 

    With Application.FileDialog(msoFileDialogFolderPicker) 
     .AllowMultiSelect = False 
     .Title = "Select destination folder" 
     If .Show = -1 And .SelectedItems.Count = 1 Then 
      Path = .SelectedItems(1) 
     Else: Exit Sub 
     End If 
    End With 

    With ActivePresentation.SectionProperties 
     For i = 1 To .Count 
      For Each oSl In ActivePresentation.Slides 
       If Not oSl.Shapes.HasTitle Then 
        File = .Name(i) & ImageBaseName & Format(oSl.SlideIndex, "0000") & "." & ImageType 
        Else: File = .Name(i) & oSl.Shapes.Title.TextFrame.TextRange.Text & Format(oSl.SlideIndex, "0000") & "." & ImageType 
       End If 
       If Not fileExists(Path, File) Then 
        oSl.Export Path & "\" & File, ImageType, ImageWidth, ImageHeight 
       End If 
      Next 
     Next 
    End With 
End Sub 

le code génère actuellement les fichiers, mais doublons chaque diapositive avec chaque nom de la section, au lieu de simplement les diapositives dans ces sections.

Answer 1

Une approche pour la numérotation séquentielle:

Dim dict As Object, sName As String 
Set dict = CreateObject("scripting.dictionary") 


With ActivePresentation.SectionProperties 
    For i = 1 To .Count 
     For Each oSl In ActivePresentation.Slides 

      If Not oSl.Shapes.HasTitle Then 
       sName = .Name(i) & ImageBaseName 
      Else 
       sName = .Name(i) & oSl.Shapes.Title.TextFrame.TextRange.Text 
      End If 

      dict(sName) = dict(sName) + 1 
      File = sName & Format(dict(sName), "0000") & "." & ImageType 

      If Not fileExists(Path, File) Then 
       oSl.Export Path & "\" & File, ImageType, ImageWidth, ImageHeight 
      End If 
     Next 
    Next 
End With