Réaliser un complément PowerPoint pour générer un diaporama à partir d'un dossier

Ce document a pour but de vous montrer comment, avec Visual Basic for Application, concevoir un complément PowerPoint pour générer un diaporama à partir d'un dossier contenant des images.
Bien qu'il existe une fonctionnalité similaire, mais loin d'être aussi simpliste dans les versions ultérieures à la version 2000, ce tutoriel vous apporte entre autre une connaissance et une approche qui n'est pas souvent évoquée sur les forums.

Commentez Donner une note à l'article (0)

Article lu   fois.

L'auteur

Site personnel

Liens sociaux

Viadeo Twitter Facebook Share on Google+   

1. Avant propos

Ce document a pour but de vous montrer comment, avec Visual Basic for Application, concevoir un complément PowerPoint pour générer un diaporama à partir d'un dossier contenant des images.
Bien qu'il existe une fonctionnalité similaire, mais loin d'être aussi simpliste dans les versions ultérieures à la version 2000, ce tutoriel vous apporte entre autre une connaissance et une approche qui n'est pas souvent évoquée sur les forums.

Le résultat final vous donnera la possibilité de sauvegarder ou non votre fichier PPS prêt à l'emploi.

1-1. Remerciements

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

1-2. Contact

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

 

2. Présentation du projet

Le projet n'est au départ qu'une simple nouvelle présentation vierge et dépourvue de toute diapositive.
Le principe de réalisation consiste à attaquer directement le code VBA depuis l'interface de développement Visaul Basic Editor (VBE).

Le projet se compose de deux Modules et d'un objet UserForm (faculatif)

Chargement du projet

Lorsque vous lancez PowerPoint en vue de créer une présentation quelconque, si peu que n'ayez pas coché la case appropriée, ce message apparaît à chaque fois.

Il indique que le complément "DiaporamaCreator" est chargé et que vous disposez de la fonction "Créer un diaporama..." dans le menu Insertion.

Ce message est représenté par un objet UserForm que vous allez créer ci-après.

Image non disponible


La case à cocher permet de ne plus voir ce message au démarrage de PowerPoint.
Du fait que la mise en place de ce formulaire est facultative, je vous laisse le soin de choisir également si vous souhaitez ou non inclure ce contrôle et le code qui l'accompagne.

Mode de fonctionnement

C'est à partir du menu Insertion que la génération s'effectue.

Image non disponible

Rien de vous empêche de réaliser votre propre menu ou bien de faire en sorte que cette rubrique soit située dans un autre menu.

Les diapositives

Par défaut, le code fait en sorte que chaque diapositive est mise en forme avec un dégradé noir centré qu'il convient de modifier à votre guise si ce rendu ne vous convenait pas.
Le choix de cette palette est établi sur le fait qu'elle s'adapte à tout type de photographie.

Image non disponible


Pour ce faire, vous pourrez toujours utiliser l'enregistreur de macros, récupérer le code pour l'adapter ou le substituer à l'existant.

2-1. Utilisation

Lorsque vous êtes prêt à générer le diaporama, le projet vous demande quelle intervalle en secondes faut-il définir entre chaque diapositive.
En effet, l'ensemble du diaporama est régie par la même transition de fondu par le noir avec une intervalle définie par défaut à 5 secondes.

Encore une fois, il vous appartient de modifier le code source pour mettre en oeuvre des transitions aléatoires selon vos préférences.

Image non disponible


Par la suite, un message vous demande si vous souhaitez utiliser la présentation en cours ou bien si vous souhaitez en générer une nouvelle.
En effet, en choisissant la présentation active, vous cumulerez les images au fur et à mesure que vous sélectionnerez un nouveau dossier.

Dans le cas contraire, le programme ajoute une nouvelle présentation vierge avant d'y insérer les images.

Image non disponible


Types de fichiers

Pour pouvoir insérer l'ensemble des images dans chaque diapositive, vous devez sélectionner un dossier contenant des images.
Les formats supportés sont dans cet exemple au nombre de 4 à savoir :

  • JPG
  • GIF
  • BMP
  • EMF

Mais vous pouvez ajouter aux constantes représentants ces extensions, toutes celles supportées par PowerPoint.

 
Sélectionnez

Const JPG As String = "jpg"
Const BMP As String = "bmp"
Const WMF As String = "wmf"
Const EMF As String = "emf"


Sélection du dossier

Pour afficher la liste des dossiers, j'ai choisi d'utiliser l'API SHBrowseForFolder() qui affiche cette boîte de dialogue, invitant l'utilisateur à sélectionner le dossier souhaité...

Image non disponible


Pour un confort d'utilisation , j'ai implémenté une procédure permettant de faire en sorte que la liste des dossiers se cale sur le dernier dossier sélectionné.
Par ailleurs, le chemin de ce dossier est stocké dans la base de Registre de Windows.

J'ai intentionnellement - et parce que ce forum regorge de code source pour le faire de façon plus personnelle - exploité la clé dédié aux applications Visual Basic à savoir :

 
Sélectionnez

HKEY_CURRENT_USER\Software\VB and VBA Program Settings\

où seront créées les valeurs respectivement nommées LastPathUsed pour définir le dernier dossier utilisé et DoNotShowAtStartup pour laisser afficher l'invite du projet, le tout, à partir de la sous-clé Settings.

2-2. Fin de génération

Lorsque vous avez séléctionné le dossier, aussitôt après, le processus de génération commence pour, quelques secondes plus tard1 , afficher ce message :

Image non disponible

1) - Le temps de réalisation du diaporama dépend à la fois de l'ordinateur sur lequel est exécuté ce projet et aussi du nombre d'images contenu dans le dossier. J'avais envisagé de greffer une barre de progression mais je vous laisse le choix d'ajouter ce petit plus finalement superflu...


Sélection du dossier

Par défaut, la présentation nouvellement créée est nommée "Diaporama No jmyyyy hhmmss.pps" où jmyyyy représente, vous l'avez deviné, la date du jour et hhmmss l'heure de génération.
Là aussi, c'est à vous de coder le processus pour que le nom des fichiers générés portent ceux que vous souhaitez.

Que vous répondiez Oui ou Non pour la sauvegarde du fichier, le diaporama s'exécute aussitôt après.
De là, après avoir appuyé sur Echap pour interrompre le cycle, vous pouvez agir comme sur une simple présentation à savoir :

  • Modifier les transitions
  • Donner des effets d'animation
  • Supprimer des diapositives
  • ...

Toutefois, l'objectif de ce tutoriel se borne à vous montrer le coté pratique de ce complément qui se limite à la génération d'un 'diaporama minute'.

Au sein du code VBA, vous verrez notamment :

  • 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 les fonctions SaveSetting() et GetSetting()
  • Comment exploiter l'API SHBrowseForFolder avec option d'ouverture sur un dossier cible...

2-3. Chargement et déchargement du complément

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...

Image non disponible


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 boite de dialogue permettant de sélectionner le ou les compléments concernés.

Image non disponible


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

 
Sélectionnez

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

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

Il vous apparatient de faire en sorte que ce dernier soit stocké dans un dossier où tous les utilisateurs y aient accès 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.

Image non disponible


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.

Image non disponible

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, cette fenêtre apparaît selon les modalités expliquées 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é.
Image non disponible


Cliquez alors sur Fermer et choisissez Créer un diaporama depuis le menu Insertion.

La procédure CloseAddinsPopup() ferme par API la fenêtre des compléments dès que vous avez appuyé sur OK sur la fenêtre de bienvenue.

3. Code VBA du projet

Le code VBA du projet nécessite un certain degré de connaissance en matière de développement.

Il est vrai qu'il n'est pas commenté (Je commente très peu mon code en général) du fait que la lisibilité associée au nom des objets et procédures soit suffisament explicite pour un développeur habitué au VB ou au VBA.

3-1. Le module de gestion des diapositives

C'est le module qui contient l'ensemble du code qui gère les images à savoir :

  • l'insertion de nouvelle diapos en fonction du nombre d'images du dossier
  • leur sélection et leur mise en place dans les diapositives en les ajustant

Le tout cerné par l'ensemble des routines

  • d'appels de sélection de dossier,
  • de confirmation d'utilisation de la présentation en cours,
  • du délai à définir pour le diaporama,
  • de l'enregistrement de la présentation,
  • ...
Module basPictures
Sélectionnez

Option Explicit
 
Public Const APP_NAME As String = "DiaporamaCreator"
Public Const KEY_SETTINGS As String = "Settings"
Public Const VALUE_LASTPATHUSED As String = "LastPathUsed"
Public Const VALUE_DONOTSHOWATSTARTUP As String = "DoNotShowAtStartup"
Public Const MENU_NAME As String = "Insert"
Public Const MENU_NAME_FR As String = "Insertion"
Public Const ICON_CAPTION As String = "Créer un diaporama..."
 
Private Const ACTION_TO_DO As String = "InsertAutoFitPicturesIntoSlides"
Private Const TOOL_TIP_TEXT As String = "Génération d´un diaporama"
Private Const ICON_DESCRIPTION As String = "Insére des photos ajustées pour la génération d´un diaporama"
Private Const ICON_TAG As String = "TAG_InsertAutoFitPictureIntoSlides"
 
Private Const THIS_PRESENTATION_PPT As String = "DiaporamaCreator.ppt"
Private Const THIS_PRESENTATION_PPA As String = "DiaporamaCreator.ppa"
 
Sub Auto_Open()
Dim oBar As CommandBar
Dim oControl As CommandBarControl
Dim oCBMenu As CommandBars
Dim blnFound As Boolean
Dim blnValue As Boolean
Dim I As Integer
 
 
    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
 
    blnValue = CBool(GetSetting(APP_NAME, KEY_SETTINGS, VALUE_DONOTSHOWATSTARTUP))
    If blnValue = False Then frmWelcome.Show
    On Error GoTo 0
    DoEvents
    CloseAddinsPopup
End Sub
 
Sub Auto_Close()
Dim oBar As CommandBar
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 InsertAutoFitPicturesIntoSlides()
Dim straFilesName() As String
Dim strFilesName As String
Dim strPictureName As String
Dim strPath As String
Dim strDelay As String
Dim strFileName As String
Dim strLastFolderUsed As String
Dim I As Integer
 
    If Presentations.Count <> 0 Then
        If ActivePresentation.Name <> THIS_PRESENTATION_PPT And ActivePresentation.Name <> THIS_PRESENTATION_PPA Then
            If MsgBox("Voulez-vous utiliser la présentation active (" & ActivePresentation.Name & ") pour insérer les photos ?", _
			36, "Utiliser la présentation") = 6 Then
                If ActiveWindow.ViewType <> ppViewSlideSorter Then
                   ActiveWindow.ViewType = ppViewSlideSorter
                End If
            Else
                CreateNewPresentation
            End If
        Else
            CreateNewPresentation
        End If
    Else
        CreateNewPresentation
    End If
 
    ActiveWindow.ViewType = ppViewSlide
    strDelay = InputBox("Combien de secondes entre chaque photos ?", "Durée du cycle", "5")
    If Len(strDelay) Then
      If IsNumeric(strDelay) = msoFalse Then
        Exit Sub
      End If
    Else
      Exit Sub
    End If
 
    strLastFolderUsed = GetSetting(APP_NAME, KEY_SETTINGS, VALUE_LASTPATHUSED)
    If Len(strLastFolderUsed) = 0 Then
        strLastFolderUsed = Left(ActivePresentation.Path, 3)
    End If
    strPath = GetPicturesFolder(strLastFolderUsed)
    strLastFolderUsed = strPath
    strFilesName = GetFileString(strPath)
 
    If Len(strFilesName) = 0 Then
        MsgBox "Exécution annulée par l´utilisateur !", 48, "Fin"
        Exit Sub
    Else
      straFilesName = Split(strFilesName, SEPARATOR)
    End If
 
    For I = LBound(straFilesName) To UBound(straFilesName)
      strPictureName = strPath & Trim(straFilesName(I))
      AutoFitCurrentPicture strPictureName
      If I < UBound(straFilesName) Then
        ActiveWindow.View.GotoSlide ActivePresentation.Slides.Add(ActivePresentation.Slides.Count, ppLayoutBlank).SlideIndex
      End If
    Next
 
    If MsgBox("Le diaporama est maintenant créé..." & vbCrLf & vbCrLf & "Voulez-vous l´enregistrer ?" & vbCrLf & _ 
	vbCrLf & "Note: Le dossier cible sera" & vbCrLf & strPath, 36, "Enregistrer la présentation") = 6 Then
      strFileName = "Diaporama No " & Format(Now, "dmyyyy hhmmss")
      ActivePresentation.SaveAs strPath & strFileName, ppSaveAsShow, msoFalse
    End If
 
    ShowDiaporama CInt(strDelay)
 
    With ActivePresentation.SlideShowSettings
      .Run
    End With
End Sub
 
Private Sub SetSlideBackground()
    If ActivePresentation.HasTitleMaster Then
        With ActivePresentation.TitleMaster.Background
            .Fill.Visible = msoTrue
            .Fill.ForeColor.SchemeColor = ppTitle
            .Fill.Transparency = 0#
            .Fill.OneColorGradient msoGradientFromTitle, 2, 0.89
        End With
    End If
    With ActivePresentation.SlideMaster.Background
        .Fill.Visible = msoTrue
        .Fill.ForeColor.SchemeColor = ppTitle
        .Fill.Transparency = 0#
        .Fill.OneColorGradient msoGradientFromTitle, 2, 0.89
    End With
    With ActivePresentation.Slides.Range
        .FollowMasterBackground = msoTrue
        .DisplayMasterShapes = msoTrue
    End With
End Sub
 
Private Sub AutoFitCurrentPicture(ByVal FileName As String)
Dim oShape As ShapeRange
Dim sngPictureWidth As Single
Dim sngPictureHeight As Single
Dim sngSlideWidth As Single
Dim sngSlideHeight As Single
Dim sngScaleValue As Single
 
  ActiveWindow.Selection.SlideRange.Shapes.AddPicture(FileName, msoFalse, msoTrue, 0, 0).Select
  Set oShape = ActiveWindow.Selection.ShapeRange
 
  sngPictureWidth = oShape.Width
  sngPictureHeight = oShape.Height
  sngSlideWidth = ActivePresentation.PageSetup.SlideWidth
  sngSlideHeight = ActivePresentation.PageSetup.SlideHeight
 
  If sngPictureWidth > sngPictureHeight Then
      sngScaleValue = sngSlideWidth / sngPictureWidth
  Else
      sngScaleValue = sngSlideHeight / sngPictureHeight
  End If
  sngScaleValue = sngScaleValue - 0.16
 
  oShape.ScaleHeight CSng(sngScaleValue), msoTrue
  oShape.ScaleWidth CSng(sngScaleValue), msoTrue
 
  With ActivePresentation.PageSetup
      oShape.Left = (.SlideWidth \ 2) - (oShape.Width \ 2)
      oShape.Top = (.SlideHeight \ 2) - (oShape.Height \ 2)
      oShape.Select
  End With
End Sub
 
Private Sub CreateNewPresentation()
    Presentations.Add msoTrue
    ActiveWindow.View.GotoSlide ActivePresentation.Slides.Add(1, ppLayoutBlank).SlideIndex
    SetSlideBackground
End Sub
 
Private Sub ShowDiaporama(ByVal Delay As Integer)
 
  ActiveWindow.ViewType = ppViewSlideSorter
  ActivePresentation.Slides.Range.Select
  With ActivePresentation.Slides.Range.SlideShowTransition
    .EntryEffect = ppEffectFade
    .Speed = ppTransitionSpeedSlow
    .AdvanceOnClick = msoTrue
    .AdvanceOnTime = msoTrue
    .AdvanceTime = Delay
    .SoundEffect.Type = ppSoundNone
  End With
  With ActivePresentation.SlideShowSettings
    .ShowType = ppShowTypeSpeaker
    .LoopUntilStopped = msoTrue
    .ShowWithNarration = msoTrue
    .ShowWithAnimation = msoTrue
    .RangeType = ppShowAll
    .AdvanceMode = ppSlideShowUseSlideTimings
    .PointerColor.SchemeColor = ppForeground
  End With
End Sub
 
  • La procédure Auto_Open() : S'exécute au démarrage du complément et créé le menu.
  • La procédure Auto_Close() : S'exécute au déchargement du complément et supprime le menu.
  • La procédure InsertAutoFitPicturesIntoSlides() : Procédure globale du projet qui gère la mise en place des images dans chaque diapositive.
  • La procédure SetSlideBackground() : Créé un arrière plan sur chaque diapositive.
  • La procédure AutoFitCurrentPicture() : Ajuste l'objet picture au sein de la diapositive en cours.
  • La procédure CreateNewPresentation() : Créé une nouvelle présentation vierge.
  • La procédure ShowDiaporama() : Configure les paramètres du diaporama et l'exécute en bouche jusqu'à Echap.

3-2. Le module de gestion des dossiers et des fichiers

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.

Module basFiles
Sélectionnez

Option Explicit
 
Private Const OFN_FILEMUSTEXIST = &H1000
Private Const OFN_HIDEREADONLY = &H4
Private Const OFN_ALLOWMULTISELECT = &H200
Private Const OFN_EXPLORER As Long = &H80000
 
Private Const BIF_STATUSTEXT  As Long = &H4&
Private Const BIF_RETURNONLYFSDIRS  As Long = 1
Private Const BIF_DONTGOBELOWDOMAIN  As Long = 2
Private Const MAX_PATH  As Long = 260
 
Private Const WM_USER  As Long = &H400
Private Const BFFM_INITIALIZED  As Long = 1
Private Const BFFM_SELCHANGED  As Long = 2
Private Const BFFM_SETSTATUSTEXT  As Long = (WM_USER + 100)
Private Const BFFM_SETSELECTION  As Long = (WM_USER + 102)
 
Public Const SEPARATOR As String = "|"
 
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 GetOpenFileName Lib "comdlg32.dll" Alias _
  "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
 
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function SendMessage Lib "user32" Alias _
  "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam _
  As Long, ByVal lParam As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As _
  BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal _
  pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias _
  "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As _
  Long
 
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 GetClassName Lib "user32" Alias _
  "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, _
  ByVal nMaxCount As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, _
  ByVal nCmdShow As Long) As Long
Private Const SW_SHOWNORMAL = 1
Private Const WM_CLOSE = &H10
Private Const ADDIN_POPUP_CLASSNAME As String = "#32770"
Private Const ADDIN_POPUP_TITLE As String = "Macros complémentaires"
 
Private Type BROWSEINFO
    hwndOwner      As Long
    pidlRoot       As Long
    pszDisplayName As Long
    lpszTitle      As Long
    ulFlags        As Long
    lpfnCallback   As Long
    lParam         As Long
    iImage         As Long
End Type
 
Private m_strDirectory As String
 
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
 
Public Function GetPicturesFolder(ByVal StartPath As String) As String
Dim strFolder As String
    strFolder = BrowseForFolder(StartPath)
    If Len(strFolder) Then
        SaveSetting APP_NAME, KEY_SETTINGS, VALUE_LASTPATHUSED, strFolder
        strFolder = AddDirSep(strFolder)
    End If
    GetPicturesFolder = strFolder
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
 
Private 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 Function GetFileString(ByVal Path As String) As String
Dim oFSO As Object ' As Scripting.FileSystemObject
Dim oFld As Object ' As Scripting.Folder
Dim oFile As Object ' As Scripting.File
Dim strFilesName As String
Dim strFilePath As String
Dim strType As String
Dim I As Integer
 
Const JPG As String = "jpg"
Const BMP As String = "bmp"
Const WMF As String = "wmf"
Const EMF As String = "emf"
 
    Set oFSO = CreateObject("Scripting.FileSystemObject")
'    Set oFSO = New FileSystemObject
    Set oFld = oFSO.GetFolder(AddDirSep(Path))
    For Each oFile In oFld.Files
        strType = Mid(oFile.Name, InStrRev(oFile.Name, ".") + 1)
        Select Case LCase(strType)
            Case JPG, BMP, WMF, EMF
                strFilesName = strFilesName & oFile.Name & SEPARATOR
            Case Else
        End Select
    Next
    If Len(strFilesName) Then
        GetFileString = Left(strFilesName, Len(strFilesName) - 1)
    End If
    Set oFld = Nothing
    Set oFile = Nothing
    Set oFSO = Nothing
End Function
 
Public Function BrowseForFolder(StartDir As String) As String
Dim lngReturn As Long
Dim strBuffer As String
Dim udtBrowseInfo As BROWSEINFO
 
  m_strDirectory = StartDir & vbNullChar
 
  With udtBrowseInfo
    .hwndOwner = 0
    .lpszTitle = lstrcat("Sélection d´un dossier contenant des photos...", " ")
    .ulFlags = BIF_RETURNONLYFSDIRS
    .lpfnCallback = GetAddressOfFunction(AddressOf BrowseCallbackProc)
  End With
 
  lngReturn = SHBrowseForFolder(udtBrowseInfo)
  If (lngReturn) Then
    strBuffer = Space(MAX_PATH)
    SHGetPathFromIDList lngReturn, strBuffer
    CoTaskMemFree lngReturn
    strBuffer = StripNullChar(strBuffer)
    BrowseForFolder = strBuffer
  Else
    BrowseForFolder = vbNullString
  End If
 
End Function
 
Private Function BrowseCallbackProc(ByVal hwnd As Long, ByVal uMessage As Long, ByVal lpIDList As Long, _
ByVal pData As Long) As Long
Dim lngRet As Long
Dim strBuffer As String
 
  On Error Resume Next
  Select Case uMessage
    Case BFFM_INITIALIZED
        Call SendMessage(hwnd, BFFM_SETSELECTION, 1, m_strDirectory)
    Case BFFM_SELCHANGED
      strBuffer = Space(MAX_PATH)
      lngRet = SHGetPathFromIDList(lpIDList, strBuffer)
      If lngRet = 1 Then
        Call SendMessage(hwnd, BFFM_SETSTATUSTEXT, 0, strBuffer)
      End If
  End Select
  BrowseCallbackProc = 0
End Function
 
Private Function GetAddressOfFunction(P As Long) As Long
  GetAddressOfFunction = P
End Function
  • La procédure CloseAddinsPopup() : ferme la boîte de dialogue "Macros complémentaires" une fois que vous cliquez sur OK du UserForm.
  • La fonction GetPicturesFolder() : retourne le nom du dossier sélectionné et l'inscrit dans le Registre.
  • 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 fonction GetFileString() : retourne la chaîne complète de l'ensemble des fichiers images du dossier, séparés par le séparateur (Constante SEPARATOR) qui sera traitée comme un tableau avec la fonction Split().
  • La fonction BrowseForFolder() : affiche la boîte de dialogue de sélection des dossiers.
  • La fonction BrowseCallbackProc() : initialise l'élément typé lpfnCallback de la variable udtBrowseInfo : cette initialisation est facultative mais permet de pouvoir afficher cette fenêtre sur le dernier dossier sélectionné (StartDir).
  • La fonction GetAddressOf : retourne l'adresse de la fonction (Attention ceci n'est pas supporté par Office 97)

L'usage des variables associées à Scripting.FileSystemObject sont déclarées en Objet de façon volontaire afin d'éviter la référence à scrrun.dll. Mais rien ne vous empêche de cocher la référence et ainsi bénéficier de l'intellisence pour compléter par exemple le code.

L'affectation de la variable oFSO se fait alors avec un CreateObject().

3-3. Le formulaire UserForm

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

  • Un contrôle Image contenant l'icône vbInformation
  • Un contrôle Label nommé lblMessage dont la légende est # signifiant (pour moi) que celui-ci est alimenté dynamiquement.
  • Un contrôle CheckBox intitulé chkDontShow
  • Un contrôle bouton de commande intitulé cmdOK

Vous nommerez cet objet frmWelcome.
- Il n'y a pas de propriétés particulières à définir ici si ce n'est le titre qui est "Créer un diaporama".
- Vous les disposez de telle sorte à ce que vous obteniez quelque chose ressemblant à l'illustration ci-dessous.

Image non disponible


Le label devant contenir le message à afficher contient un caractère #.

En effet, c'est sur l'événement UserForm_Activate() que s'initialise ce message.
Ce message est stockée provisoirement dans une variable de type String où sont appelées les valeurs des constantes du nom du menu (MENU_NAME_FR) et le nom de la rubrique (ICON_CAPTION).

Code du UserForm frmWelcome
Sélectionnez

Option Explicit
 
Private Sub chkDontShow_Click()
    SavePreferences chkDontShow.Value
End Sub
 
Private Sub cmdOK_Click()
    SavePreferences chkDontShow.Value
    Unload Me
End Sub
 
Private Sub UserForm_Activate()
Dim strMessage As String
 
    strMessage = "Vous êtes prêt(e) à créer un diaporama à partir des photos que vous allez sélectionner..." & _
	vbCrLf & vbCrLf & "Dans le menu [" & MENU_NAME_FR & "], choisissez la rubrique [" & _
	ICON_CAPTION & "]."
    lblMessage.Caption = strMessage
End Sub
 
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Cancel = (CloseMode = vbFormControlMenu)
End Sub
 
Private Sub SavePreferences(ByVal ShowAtStartup As Boolean)
    SaveSetting APP_NAME, KEY_SETTINGS, VALUE_DONOTSHOWATSTARTUP, ShowAtStartup
End Sub
  • L'événement chkDontShow_Click : Evénement Click qui appelle la procédure SavePreferences.
  • L'événement cmdOK_Click : Evénement Click qui appelle la procédure SavePreferences puis décharge le UserForm.
  • L'événement UserForm_Activate : Initialise le contenu du Label lblMessage.
  • L'événement UserForm_QueryClose : Empêche la fermeture de la fenêtre par la croix en initialisant Cancel selon le paramètre CloseMode.
  • La procédure SavePreferences : Procédure écrivant la valeur dans la base de Registre.

4. Comment cela fonctionne t-il ?

1 - Le principe est relativement simple :

L'ouverture de l'application entraîne l'exécution de la procédure Auto_Open() qui installe le menu puis affiche un message de bienvenue.
Lorsque l'utilisateur charge le complément depuis la liste des macros complémentaires (à faire une seule et unique fois) le même phénomène se produit.

2 - Déroulement :

Lorsque l'utilisateur clique sur le menu pour créer son diaporama, le programme vérifie d'abord s'il y a une présentation active autre
que celle du projet, bien entendu.
La question lui est-alors posée, le cas échéant, de savoir s'il veut ou non l'utiliser s'il y en a une.
Cela permet en fait d'enrichir la présentation de photos à partir de dossiers différents.

=> Dans tout autre cas, une nouvelle présentation est créée.

La question du délai à définir entre chaque diapo est alors posée puis la sélection du dossier s'en suit aussitôt après...

3 - Sélection du dossier :

Le programme ensuite appelle l'ouverture de la boîte de dialogue des dossiers par le biais de la fonction BrowseForFolder() mais
vérifie dans le Registre si un dossier a déjà été sélectionné auquel cas il affiche la dite boîte sur ce dernier.

Aussitôt après, le nom du dossier est exploité par la fonction GetFileString() qui alimente la variable strFilesName.
Cette variable va contenir une chaîne de l'ensemble des fichiers du dossier séparés par un séparateur déclaré en constante.

4 - Construction de la présentation :

Une boucle s'établit alors avec l'exploitation des bornes d'un tableau de Strings retourné par la fonction Split() :

Pour chaque élément du tableau, une variable s'initialise avec le nom du dossier suivi du nom du fichier dans l'index de la boucle et appelle
la procédure AutoFitCurrentPicture() pour y loger l'image.

4 - Visualisation :

Lorsque la boucle a terminé son cycle, un message apparaît pour en informer l'utilisateur et pose la question de l'enregistrement
de cette dernière.

Le diaporama est alors lancé quelle que soit la réponse.

5. Création du complément

La dernière étape consiste à générer le complément.

5-1. Sauvegarde du projet

  • 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();

5-2. Les tests

  • Réduisez l'éditeur VBE;
  • Sélectionnez dans le menu Insertion la rubrique Créer un diaporama: la procédure doit s'exécuter aussitôt ;
  • Sélectionnez un dossier contenant des images aux formats appropriés ;
  • C'est tout...

5-3. La génération du complément

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

C'est terminé.

6. Conclusion

Ce tutoriel va vous permettre de connaître l'étendue de quelques possibiltés intéressantes réalisables avec PowerPoint.
Il est évident que cette application n'est pas vouée à être exploitée en tant que telle comme les autres applications Office mais, il peut être intéressant de connaître et mettre en place ce genre de processus pour par exemple, faire une présentation instantanée par programme depuis une autre application.

Les possibiltés sont relativement vastes compte tenu du fait que ce sont les idées qui vous permettront d'exploiter ce tutoriel.
Si vous rencontrez des difficultés ou si j'ai omis de préciser quelque chose qui reste obscur, n'hésitez pas à m'en faire part.

Vous avez aimé ce tutoriel ? Alors partagez-le en cliquant sur les boutons suivants : Viadeo Twitter Facebook Share on Google+   

Ce document est issu de http://www.developpez.com et reste la propriété exclusive de son auteur. La copie, modification et/ou distribution par quelque moyen que ce soit est soumise à l'obtention préalable de l'autorisation de l'auteur.