Réaliser un complément PowerPoint pour extraire les images d'une présentation

Je tiens à remercier tout particulièrement toutes celles et ceux qui ont participé à la relecture de ce document en y incluant leurs remarques.

Pour tout renseignement complémentaire, veuillez me contacter directement (Argyronet) par MP.

Sélection de la présentation

Lorsque vous avez cliqué sur cette rubrique du menu Outils, le projet affiche une fenêtre (le UserForm) dans lequel se trouve les différents contrôles permettant :

• de sélectionner la présentation
• de définir le dossier d'extraction
• de définir le format d'extraction des images

Il ne vous reste plus alors :

• qu'à sélectionner une présentation aux formats *.pps ou *.ppt,
• qu'à définir le format de sortie,
• puis qu'à cliquer sur le bouton d'extraction pour démarrer le processus.

Formats de fichiers pour l'exportation

Ce projet vous permet d'extraire les images de la présentation sélectionnée et de les enregistrer dans le dossier cible aux formats suivants :

• BMP
• GIF
• JPG
• PNG
• WMF

Ces formats étant définis par des constantes intrinsèques dans PowerPoint, il est aisé de les exploiter...

Sélection de la présentation

Pour sélectionner la présentation contenant des images, j'ai choisi d'utiliser l'API GetOpenFileName() que vous connaissez certainement déjà et qui a pour rôle d'afficher cette boîte de dialogue, invitant l'utilisateur à sélectionner la présentation souhaitée...

Il n'y a pas d'événements particuliers en ce qui concerne la sélection du fichier.
Le fait d'annuler ne provoque pas d'erreur puisque la propriété Enabled des contrôles suivant dépend de la non nullité du nom de la présentation choisie...

Vous pouvez mettre en place d'autres routines liées ; celle que je vous propose reste la plus simple.

L'extraction des images débute aussitôt que vous cliquez sur le bouton "Extraire les images de la présentation"...
Une fois la procédure achevée, un message vous informe que les images sont maintenant extraites ou non :

Message d'extraction avec succès

Les images extraites sont stockées dans le dossier de la présentation...

Message d'extraction en échec

S'il n'y a aucune image, ce message s'affiche...

Objectif du tutoriel

L'objectif de ce tutoriel est de vous montrer le coté pratique d'un complément dont le seul rôle est d'extraire les images d'une présentation...
Il reste - en quelques points - fidèle à la même méthodologie de développement que dans mon précédent tutoriel qui générait un diaporama minute...

Au sein du code VBA de ce nouveau projet, vous verrez alors :

• Comment créer un complément
• Comment charger et décharger ce complément
• Comment insérer un élément de menu dans un menu existant qui se supprime lorsque le complément est déchargé.
• Comment exploiter l'API GetOpenFileName filtrée sur plusieurs fichiers...

Pour charger le complément, une fois que vous l'avez développé bien entendu et que vous l'avez compilé, vous pouvez le charger ou le décharger depuis le menu Outils/Macros complémentaires...

Cette boîte de dialogue apparaît, vide si aucun complément n'a déjà été chargé ;
là, il vous faut cliquer sur Nouvelle (sous-entendu nouvelle macro complémentaire) pour qu'apparaisse la boîte de dialogue permettant de sélectionner le ou les compléments concernés.

Notez ici que le chemin par défaut des compléments créés est définit comme suit :

C:\Documents and Settings\Argyronet\Application Data\Microsoft\Macros complémentaires

où, ici, l'utilisateur en cours est Argyronet (c'est encore moi !!! )

Il vous apparatient de faire en sorte que ce dernier soit stocké dans un dossier accessible à tous les utilisateurs si toutefois vous souhaitez faire en sorte que ce complément soit disponible, quelle que soit la session chargée.

Dans ce cas précis ci-avant, seul Argyronet peut utiliser ce complément.

Une fois que vous avez cliqué sur OK, le message d'alerte d'activation des macros se fait suivre et vous invite à choisir si vous voulez ou non activer les macros de ce complément.

Ce message n'apparaît pas du tout si le niveau de sécurité est défini à Bas (non recommandé) et charge le complément ou si votre projet est signé numériquement.
Donc, réglez la sécurité sur Moyen de manière à ce que ce message s'affiche systématiquement.

Vous cliquez alors sur Activer les macros derrière quoi, le menu Outils se voit greffé d'une nouvelle commande comme cela est stipulé ici...

La fenêtre de la liste des compléments reste affichée :

• Le complément que vous avez sélectionné se voit alors précédé d'une croix pour signifier qu'il est chargé.
• La croix disparaît lorsqu'il est déchargé.

Cliquez alors sur Fermer et choisissez Extraire les images depuis le menu Outils.

La procédure CloseAddinsPopup() ferme par API la fenêtre des compléments dès que la fenêtre d'alerte des macros se ferme.

Ce module contient l'ensemble des API's nécessaires au projet associé aux fonctions qui s'occupent de fournir le nom du dossier des images et celles permettant la construction de la chaîne contenant les fichiers.

• d'appels de sélection de la présentation,
• de la fermeture de la boîte de dialogue des macros complémentaires,

Option Explicit
 
Private Const WM_CLOSE = &H10
Private Const ADDIN_POPUP_CLASSNAME As String = "#32770"
Private Const ADDIN_POPUP_TITLE As String = "Macros complémentaires"
 
Private Const OFN_FILEMUSTEXIST = &H1000
Private Const OFN_HIDEREADONLY = &H4
Private Const OFN_EXPLORER As Long = &H80000
 
Private Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type
 
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
 
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" _
(pOpenfilename As OPENFILENAME) As Long
 
Public Function GetPresentation(ByRef TargetFolder As String) As String
Dim OFName As OPENFILENAME
Dim strFilesName As String
 
    With OFName
        .lStructSize = Len(OFName)
        .hwndOwner = 0
        .hInstance = 0
        .lpstrFilter = "Présentations PowerPoint (*.ppt, *.pps)" + vbNullChar + "*.ppt; *.pps" + vbNullChar
        .lpstrFile = Space$(254)
        .nMaxFile = 255
        .lpstrFileTitle = Space$(254)
        .nMaxFileTitle = 255
        .lpstrInitialDir = vbNullString
        .lpstrTitle = "Ouvrir une présentation Power Point"
        .flags = OFN_HIDEREADONLY Or OFN_EXPLORER Or OFN_FILEMUSTEXIST
    End With
    strFilesName = IIf(GetOpenFileName(OFName), Trim$(OFName.lpstrFile), vbNullString)
    If Len(strFilesName) Then
      TargetFolder = Left(strFilesName, InStrRev(strFilesName, "\", -1, 1))
      strFilesName = StripNullChar(Mid(strFilesName, InStrRev(strFilesName, "\", -1, 1) + 1))
    Else
      strFilesName = vbNullString
      TargetFolder = vbNullString
    End If
    GetPresentation = strFilesName
End Function
 
Private Function StripNullChar(ByVal Buffer As String) As String
Dim intPosition As Integer
    intPosition = InStr(Buffer, vbNullChar)
    If intPosition > 0 Then
        StripNullChar = Left(Buffer, intPosition - 1)
    Else
        StripNullChar = Buffer
    End If
End Function
 
Public Function AddDirSep(strPathName As String)
    If Right(Trim(strPathName), Len("\")) <> "\" And _
       Right(Trim(strPathName), Len("\")) <> "\" Then
        strPathName = RTrim$(strPathName) & "\"
    End If
    AddDirSep = strPathName
End Function
 
Public Sub CloseAddinsPopup()
Dim lngHWnd As Long
 
    lngHWnd = FindWindow(ADDIN_POPUP_CLASSNAME, ADDIN_POPUP_TITLE)
    Call SetForegroundWindow(lngHWnd)
    If lngHWnd Then
        PostMessage lngHWnd, WM_CLOSE, 0&, 0&
    End If
End Sub

• La fonction GetPresentation() : exploite GetOpenFileName() afin de sélectionner une présentation.
• La procédure StripNullChar() : supprime les caractères vbNullChar "Chr(0)" d'une chaîne passée en paramètre.
• La fonction AddDirSep() : ajoute le séparateur de fichier.
• La procédure CloseAddinsPopup() : ferme la boîte de dialogue "Macros complémentaires" dès que la fenêtre d'alerte des macros se ferme.

C'est le module qui contient l'ensemble du code qui gère l'ouverture du complément...

• l'appel de la procédure Auto_Open
• l'appel de la procédure Auto_Close
• l'accès à l'affichage du UserForm

Option Explicit
 
Const MENU_NAME As String = "Tools"
Const MENU_NAME_FR As String = "Outils"
Const ACTION_TO_DO As String = "ShowExtractorForm"
Const TOOL_TIP_TEXT As String = "Extraire les images de la présentation"
Const ICON_CAPTION As String = "Extraire les images"
Const ICON_DESCRIPTION As String = "Extraire les images d'une présentation PPS ou PPT"
Const ICON_TAG As String = "TAG_ExtractImage"
 
 
Sub Auto_Open()
Dim oControl As CommandBarControl
Dim oCBMenu As CommandBars
Dim blnFound As Boolean
 
 
    On Error Resume Next
    Set oCBMenu = Application.CommandBars
    For Each oControl In oCBMenu(MENU_NAME).Controls
        If oControl.Tag = ICON_TAG Then
            blnFound = True
            Exit For
        End If
    Next oControl
 
    If blnFound = False Then
        On Error Resume Next
        Set oControl = CommandBars(MENU_NAME).Controls.Add(msoControlButton)
            With oControl
                .BeginGroup = msoTrue
                .FaceId = 1362
                .OnAction = ACTION_TO_DO
                .TooltipText = TOOL_TIP_TEXT
                .Caption = ICON_CAPTION
                .DescriptionText = ICON_DESCRIPTION
                .Visible = msoTrue
                .Style = msoButtonCaption
                .Tag = ICON_TAG
            End With
    End If
 
    Set oControl = Nothing
 
    On Error GoTo 0
    DoEvents
    CloseAddinsPopup
End Sub
 
Sub Auto_Close()
Dim oControl As CommandBarControl
Dim oCBMenu As CommandBars
 
    On Error Resume Next
    Set oCBMenu = Application.CommandBars
    For Each oControl In oCBMenu(MENU_NAME).Controls
        If oControl.Tag = ICON_TAG Then
          oControl.Delete
        End If
    Next oControl
    Set oCBMenu = Nothing
End Sub
 
Sub ShowExtractorForm()
  frmMain.Show vbModal
End Sub

• La procédure Auto_Open() : permet d'installer le menu.
• La procédure Auto_Close() : permet de supprimer le menu.
• La procédure ShowExtractorForm() : permet l'affichage du UserForm.

Pour concevoir le UserForm, insérer un nouvel objet UserForm dans votre projet et insérez-y :

• Un contrôle Image contenant une image représentative (ici, c'est du fait maison avec un éditeur d'images)
  
• Trois contrôles Label nommés
  - lblPresentation (Nom de la présentation),
  - lblTargetFolder (Image à enregistrer dans)
  - lblExtension (Format de sortie)
  respectivement pour chaque Textbox et le ComboBox.
• Deux contrôles Textbox nommés
  - txtPresentation (Fichier présentation)
  - txtTargetFolder (Dossier de stockage).
  
• Un contrôle ComboBox nommé cmbFormats (Extension des images)
  
• Deux contrôles CommandButton nommés
  - cmdExtract et
  - cmdCancel dûment intitulés comme dans l'illustration ci-après

J'ai logé les contrôles Textboxes et Labels dans un cadre pour faire plus esthétique et posé un séparateur entre ce dernier et les boutons pour les mêmes raisons.

Vous nommerez cet objet UserForm frmMain.
- Il y a quelques propriétés à définir ici :

• le titre qui est ici "PPS Pictures Extractor"
• la propriété Enabled à False pour les contrôles cmbFormats et cmdExtract
• la propriété Locked à True pour les contrôles txtPresentation et txtTargetFolder

- Vous les disposez de telle sorte à ce que vous obteniez quelque chose ressemblant à l'illustration ci-dessous.

Son module de classe contient l'ensemble du code qui gère notamment :

• l'affichage de la fenêtre de sélection de la présentation,
• l'insertion du nom et du chemin de la présentation dans les contrôles appropriés,
• la sélection du format de sortie,
• l'opération d'extraction des images.

Option Explicit
 
Const PPT_EXTENSION As String = "ppt"
Const PPS_EXTENSION As String = "pps"
 
Private Const IMGFORMAT_GIF As String = "GIF"
Private Const IMGFORMAT_JPG As String = "JPG"
Private Const IMGFORMAT_PNG As String = "PNG"
Private Const IMGFORMAT_BMP As String = "BMP"
Private Const IMGFORMAT_WMF As String = "WMF"
 
Private Sub UserForm_Initialize()
 With cmbFormats
   .AddItem IMGFORMAT_BMP
   .AddItem IMGFORMAT_GIF
   .AddItem IMGFORMAT_JPG
   .AddItem IMGFORMAT_PNG
   .AddItem IMGFORMAT_WMF
 End With
End Sub
 
Private Sub cmbFormats_Change()
  cmdExtract.Enabled = (Len(cmbFormats.Text) > 0)
End Sub
 
Private Sub cmdCancel_Click()
  Unload Me
  End
End Sub
 
Private Sub cmdSelectPresentation_Click()
Dim strPresentation As String
Dim strDirectory As String
 
 strPresentation = GetPresentation(strDirectory)
 txtPresentation.Text = strPresentation
 txtTargetFolder.Text = strDirectory
 cmbFormats.Enabled = (Len(txtPresentation.Text) > 0)
End Sub
 
Private Sub cmdExtract_Click()
Dim strMessage As String
Dim intPictureCount As Integer
Dim strPresentationPathFile As String
 
  strPresentationPathFile = txtTargetFolder.Text & txtPresentation.Text
  If IsAValidPresentation(txtPresentation.Text) Then
    Presentations.Open strPresentationPathFile, msoCTrue, msoFalse, msoTrue
    intPictureCount = ExtractPictureFromSlides(Application.Version, txtTargetFolder.Text, cmbFormats.Text)
    If intPictureCount Then
      strMessage = Trim(Str(intPictureCount)) & _
	  IIf(intPictureCount = 1, " image extraite", " images extraites") & _
	  " de la présentation [" & txtPresentation.Text & "]..."
      MsgBox "L´extraction est maintenant terminée..." & vbCrLf & vbCrLf & strMessage, vbInformation, "Fin"
    Else
      MsgBox "Il n´y a aucune image à extraire dans cette présentation...", vbInformation, "Extraction échouée"
    End If
    Unload Me
    ActivePresentation.Close
  Else
    MsgBox "Le fichier sélectionné n´est pas une présentation valide !", 48, "Présentation invalide"
  End If
End Sub
 
Private Function ExtractPictureFromSlides(ByVal Version As String, ByVal TargetFolder As String, _
ByVal OutputFormat As String) As Integer
Const IMAGE_NAME As String = "Image"
 
Dim oPresentation As Presentation
Dim oSrcSlide As Slide
Dim oShapeRange As ShapeRange
Dim oShape As Shape
Dim oTrgSlide As Slide
Dim oTempShape As Shape
Dim I As Integer
 
Dim strExtension As String
Dim pptFormat As Integer
 
  pptFormat = GetIntFormat(OutputFormat, strExtension)
 
  I = 0
  For Each oSrcSlide In ActivePresentation.Slides
    For Each oShape In oSrcSlide.Shapes
      Select Case oShape.Type
        Case msoPicture, msoEmbeddedOLEObject ', msoLinkedOLEObject, msoLinkedPicture
            oShape.Export TargetFolder & IMAGE_NAME & Format(I + 1, "000") _
			& strExtension, pptFormat
            I = I + 1
      End Select
    Next oShape
  Next oSrcSlide
  ExtractPictureFromSlides = I
End Function
 
Private Function GetIntFormat(ByVal OutputFormat, ByRef Extension) As Integer
Dim intPPShpFormat As Integer
 
 Select Case OutputFormat
   Case IMGFORMAT_BMP
     intPPShpFormat = ppShapeFormatBMP
   Case IMGFORMAT_JPG
     intPPShpFormat = ppShapeFormatJPG
   Case IMGFORMAT_PNG
     intPPShpFormat = ppShapeFormatPNG
   Case IMGFORMAT_GIF
     intPPShpFormat = ppShapeFormatGIF
   Case IMGFORMAT_WMF
     intPPShpFormat = ppShapeFormatWMF
 End Select
 Extension = "." & LCase(OutputFormat)
 GetIntFormat = intPPShpFormat
End Function
 
Private Function IsAValidPresentation(ByVal ppFile As String) As Boolean
Dim strExtension As String
 
  strExtension = LCase(Mid(ppFile, InStrRev(ppFile, ".", -1, vbBinaryCompare) + 1))
  Select Case strExtension
    Case PPT_EXTENSION, PPS_EXTENSION
      IsAValidPresentation = True
    Case Else
      IsAValidPresentation = False
  End Select
End Function

• L'événement UserForm_Initialize : Rempli le ComboBox avec les 5 extensions de formats de fichiers par la méthode AddItem.
• L'événement cmbFormats_Change : Active le bouton cmdExtract.
• L'événement cmdCancel_Click : Décharge le formulaire et met fin au programme.
• L'événement cmdSelectPresentation_Click : Appelle GetPresentation() afin d'alimenter les TextBoxes puis donne la main au ComboBox.
• L'événement cmdExtract_Click : Permet après vérifications de lancer la procédure d'extraction.
• La procédure ExtractPictureFromSlides : Procédure d'extraction à proprement parler des images.
• La fonction GetIntFormat : Fonction retournant le format selon l'élément choisi dans le ComboBox.
• La fonction IsAValidPresentation : Petite fonction toute simple qui contrôle l'extension de la présentation.

On peut masquer la présentation ouverte en stipulant msoFalse plutôt que msoTrue dans l'appel de l'ouverture de la présentation
via Presentations.Open() au paramètre WithWindow.
Pour ce faire, vous modifierez la ligne contenant :
Presentations.Open(...) par Set oPresentation = Presentations.Open(...)
puis vous ajouterez le paramètre ByVal oPresentation As Presentation à la procédure ExtractPictureFromSlides
Vous n'ometterez alors pas de supprimer la déclaration Dim oPresentation As Presentation dans ExtractPictureFromSlides
et de la déclarer à la place dans cmdExtract_Click ; enfin, n'oubliez pas non plus de libérer l'objet avec Nothing.

Private Sub cmdExtract_Click()
Dim strMessage As String
Dim intPictureCount As Integer
Dim strPresentationPathFile As String
Dim oPresentation As Presentation
 
  strPresentationPathFile = txtTargetFolder.Text & txtPresentation.Text
  If IsAValidPresentation(txtPresentation.Text) Then
    Set oPresentation = Presentations.Open(strPresentationPathFile, msoTrue, msoFalse, msoFalse)
    intPictureCount = ExtractPictureFromSlides(oPresentation, Application.Version, txtTargetFolder.Text, cmbFormats.Text)
	'[...]
	ActivePresentation.Close
    Set oPresentation = Nothing
	'[...]
End Sub
 
Private Function ExtractPictureFromSlides(ByVal oPresentation As Presentation, ByVal Version As String, _
ByVal TargetFolder As String, ByVal OutputFormat As String) As Integer
	'[...]
  For Each oSrcSlide In oPresentation.Slides
	'[...]
  Next oSrcSlide
	'[...]
End Sub

• Commencez par enregistrer votre projet au format Présentation PowerPoint (PPT) sous un nom explicite
  de manière à garder une source modifiable ;
• Une fois cela fait, testez votre projet en appuyant sur F5 dans la procédure Auto_Open();

• Réduisez l'éditeur VBE;
• Sélectionnez dans le menu Insertion la rubrique Extraire les images: la procédure doit s'exécuter aussitôt ;
• Sélectionnez une présentation contenant des images ;
• C'est tout...

Une fois que vos tests sont concluants, enregistrez votre projet au format Macro complémentaire PowerPoint (PPA).

C'est terminé.