0
(0)
Sommaire

Pour répondre à la demande d'un utilisateur du forum answers.microsoft.com, j'ai développé des outils afin d'appliquer des étiquettes aux diapositives pour pouvoir facilement sélectionner celles à projeter.

Pour cela je vous propose d'utiliser 3 macros :

  • La 1ère permet d'ajouter des étiquettes aux diapositives d'une présentation en se basant sur un tableau Excel.
  • La 2ème permet de supprimer toutes les étiquettes associées aux diapositives.
  • La 3ème permettant de générer des diaporamas personnalisés (ruban Diaporama) correspondant à une "requête" basée sur ces étiquettes.

Macro 1 : Génération des étiquettes des diapositives

> Préparer un tableau Excel recensant les étiquettes et les valeurs pour chaque diapositive.

Powerpoint : Tableau des étiquettes 'Tags'

À partir de Powerpoint, exécuter le code suivant pour ajouter ces étiquettes et leur valeur à toutes les diapositives mentionnées dans la présentation active.

Si certaines étiquettes sont déjà présentes, leurs valeurs seront mise à jour.

Sub AjouterTagsAuxDiapos()
  ' Objectif    : Appliquer des étiquettes aux diapositives d'une présentation en se basant sur les
  '               données d'un tableau Excel.
  '               Remarque : Si l'étiquette est déjà présente, sa valeur sera mise à jour.
  ' Utilisation : > Générer un tableau Excel présentant en 1ere colonne les N° des diapositives,
  '                 chaque colonnesuivante représentant l'intitulé de l'étiquette en ligne 1
  '                 (exemple : Pays) puis les valeurs correspondantes au N° de diapositive. Cette
  '                 plage devant être nommé "Tags" (sélectionner la plage puis Formules>Définir un nom).
  '               > Lancer la macro à partir de Powerpoint.
  ' Retour      : Néant
  ' Auteur      : Arnaud (www.1forme.fr).
  ' Licence     : CC-BY-NC-SA (Vous pouvez diffuser/partager/modifier cette macro dans les même
  '                        conditions, seulement à titre personnel et citant l'auteur/site d'origine.

    Dim objExcelApp     As Object
    Dim objWb           As Object
    Dim objRng          As Object
    Dim objCell         As Object
    Dim objDialog       As FileDialog
    Dim strFilePath     As String
    Dim lngSlideIndex   As Long
    Dim i               As Integer
    Dim strTagName      As String
    Dim strTagValue     As String
    Dim objSlide        As slide
    
    ' Ouvrir la fenêtre de sélection de fichier
    Set objDialog = Application.FileDialog(msoFileDialogFilePicker)
    objDialog.Filters.Add "Fichiers Excel", "*.xls; *.xlsx", 1
    objDialog.AllowMultiSelect = False
    objDialog.Title = "Sélectionner le fichier Excel contenant la plage 'Tags' à utiliser"
    
    If objDialog.Show = -1 Then ' Si l'utilisateur sélectionne un fichier
        strFilePath = objDialog.SelectedItems(1)
    Else
        MsgBox "Aucun fichier sélectionné.", vbExclamation
        Exit Sub
    End If
    
    ' Lancer Excel et ouvrir le fichier sélectionné
    On Error Resume Next
    Set objExcelApp = CreateObject("Excel.Application")
    On Error GoTo 0
    
    If objExcelApp Is Nothing Then
        MsgBox "Excel n'a pas pu être lancé.", vbExclamation
        Exit Sub
    End If
    
    Set objWb = objExcelApp.Workbooks.Open(strFilePath)
    
    ' Vérifier si la plage nommée "Tags" existe
    On Error Resume Next
    Set objRng = objWb.names("Tags").RefersToRange
    On Error GoTo 0
    
    If objRng Is Nothing Then
        MsgBox "La plage nommée 'Tags' n'existe pas dans le fichier sélectionné.", vbExclamation
        objWb.Close False
        objExcelApp.Quit
        Exit Sub
    End If
    
    ' Parcourir les lignes de la plage "Tags"
    For Each objCell In objRng.Columns(1).Cells ' La première colonne contient les numéros de diapositive
        If IsNumeric(objCell.Value) Then
            lngSlideIndex = CLng(objCell.Value)
            On Error GoTo erreur ' Pas d'erreur si la diapositive n'existe pas
            Set objSlide = ActivePresentation.Slides(lngSlideIndex)
            On Error GoTo 0
            
            If Not objSlide Is Nothing Then
                ' Parcourir les colonnes pour ajouter les tags
                For i = 2 To objRng.Columns.Count
                    strTagName = objRng.Cells(1, i).Value ' Étiquette de colonne comme nom de tag
                    strTagValue = objRng.Cells(objCell.Row, i).Value ' Valeur du tag
                    If Not IsEmpty(strTagName) And Not (strTagValue = "") Then
                        objSlide.Tags.Add strTagName, strTagValue
                    End If
                Next i
            End If
        End If
    Next objCell
    
    ' Fermer le classeur et quitter Excel
    objWb.Close False
    Set objWb = Nothing
    objExcelApp.Quit
    Set objExcelApp = Nothing
    MsgBox "Les tags ont été ajoutés avec succès.", vbInformation
    Exit Sub
erreur:
    ' Diapositive non existante
    Set objSlide = Nothing
    Resume Next
End Sub

Macro 2 : Effacement des étiquettes des diapositives

À utiliser si l'on veut annuler/supprimer toutes les étiquettes des diapositives de la présentation active.

Sub SupprimerTousLesTags()
  ' Objectif    : Supprimer toutes les étiquettes de toutes les diapositives de la présentation.
  ' Utilisation : Lancer la macro à partir de Powerpoint.
  ' Retour      : Néant
  ' Auteur      : Arnaud (www.1forme.fr).
  ' Licence     : CC-BY-NC-SA (Vous pouvez diffuser/partager/modifier cette macro dans les même
  '                        conditions, seulement à titre personnel et citant l'auteur/site d'origine.
    Dim objSlide    As slide
    Dim i           As Integer
    
    ' Parcourir toutes les diapositives de la présentation active
    For Each objSlide In ActivePresentation.Slides
        ' Supprimer tous les tags de la diapositive en cours
        For i = objSlide.Tags.Count To 1 Step -1
            objSlide.Tags.Delete objSlide.Tags.Name(i)
        Next i
    Next
    
    MsgBox "Tous les tags ont été supprimés de toutes les diapositives.", vbInformation
End Sub

Macro 3 : Génération du diaporama personnalisé à partir des étiquettes

Il faudra fournir une chaîne de texte représentant le nom du diaporama personnalisé suivit du caractère ':' puis la chaine indiquant quelles étiquettes sont à prendre en compte pour sélectionner les diapositives devant être ajoutées au diaporama personnalisé.

  • Le nom du diaporama personnalisé n'a pas de contrainte précise (espaces, chiffres...). Si ce diaporama personnalisé existe déjà dans cette présentation, l'exécution du code s'arrêtera et le diaporama personnalisé ne sera pas créé.
  • La chaîne de "requête" peut contenir les opérateurs suivants : =, >, >=, <, <=, <>, et, ou, +, -, *, /.
  • Utiliser des parenthèses pour gérer l'ordre de priorité d'évaluation de la chaîne de requête.
    Exemple :
    • ((Pays="Fr") ou (Pays="Gb")) et (Valeur>=(50+20))
      Pour sélectionner les diapositives dont l'étiquette Pays est 'Fr' ou 'Gb' mais dont l'étiquette Valeur est supérieur ou égale à 70.
Sub CreerDiaporamaPersoBaseSurTags()
  ' Objectif    : Générer un diaporama personnalisé sélectionnant les diapositives ayant certaines
  '               étiquettes et ce via une "requête".
  ' Utilisation : > Lancer la macro à partir de Powerpoint.
  '               > Saisir le nom du diaporama personnalisé puis le caractère ':' et enfin la chaine
  '                 correspondante à la "requête".
  '                 Exemple : ((Pays="Fr") ou (Pays="Gb")) et (Valeur>=(50+20)) pour sélectionner les
  '                     diapositives dont l'étiquette Pays est 'Fr' ou 'Gb' mais dont l'étiquette
  '                     Valeur est supérieur ou égale à 70.
  ' Retour      : Un nouveau diaporamas personnalisés.
  ' Auteur      : Arnaud (www.1forme.fr).
  ' Licence     : CC-BY-NC-SA (Vous pouvez diffuser/partager/modifier cette macro dans les même
  '                         conditions, seulement à titre personnel et citant l'auteur/site d'origine.

    Dim strUserInput    As String
    Dim strDiapoName    As String
    Dim strCriteria     As String
    Dim objSlide        As slide
    Dim tabSlides()     As Long
    Dim intSlideIndex   As Integer
    Dim varModCriteria  As Variant
    Dim bolExist        As Boolean
    Dim i               As Integer
    Dim objPersonDiap   As NamedSlideShow
    Dim objExcelApp     As Object
    
    ' Demander à l'utilisateur de saisir la chaîne de texte
    strUserInput = InputBox("Saisir le nom du diaporama personnalisé à créer et " & vbCrLf & _
                "la chaîne de critères de sélection des diapositives " & vbCrLf & _
                "à utiliser séparé par le caractère ':'." & vbCrLf & vbCrLf & _
                "Exemple de saisie >>>" & vbCrLf & _
                "FranceSup2:(Pays=""Fr"") et (Valeur>2)", "Création de diaporama personnalisé")
    
    ' Vérifier si l'utilisateur a bien saisi une chaîne avec ":"
    If InStr(strUserInput, ":") = 0 Then
        MsgBox "Le format de la chaîne est incorrect. Assurez-vous qu'il contient ':' pour " & _
                "séparer le nom et la chaîne de critères.", vbExclamation, "Commande incorrecte !"
        Exit Sub
    End If
    
    ' Séparer le nom du diaporama et les critères
    strDiapoName = Trim(Left(strUserInput, InStr(strUserInput, ":") - 1))
    
    If strDiapoName = "" Then
        MsgBox "Le format de la chaîne est incorrect. Assurez-vous qu'il contient " & _
                "bien un texte à gauche du caractère ':' représentant le nom du " & _
                "nouveau diaporama personnalisé.", vbExclamation, "Pas de nom !"
        Exit Sub
    End If
    
    ' Vérifier si le diaporama personnalisé existe déjà
    bolExist = False
    For Each objPersonDiap In ActivePresentation.SlideShowSettings.NamedSlideShows
        If objPersonDiap.Name = strDiapoName Then
            bolExist = True
            Exit For
        End If
    Next
    If bolExist Then
        MsgBox "Diaporama personnalisé est déja existant"
        Exit Sub
    End If
    
    strCriteria = Trim(Mid(strUserInput, InStr(strUserInput, ":") + 1))
    
    If strCriteria = "" Then
        MsgBox "Le format de la chaîne est incorrect. Assurez-vous qu'il contient " & _
                "bien un texte à droite du caractère ':' représentant les critères " & _
                "de sélection des diapositives", vbExclamation, "Pas de critères de sélection !"
        Exit Sub
    End If
    
    ' Remplacer les "Ou" et "Et"
    strCriteria = Replace(strCriteria, " Ou ", " + ", , , vbTextCompare)
    strCriteria = Replace(strCriteria, " Et ", " * ", , , vbTextCompare)
    
    ' Initialiser le tableau des diapositives à sélectionner
    ReDim tabSlides(1 To ActivePresentation.Slides.Count)
    
    On Error Resume Next
    Set objExcelApp = CreateObject("Excel.Application")
    On Error GoTo 0

    ' Parcourir les diapositives et vérifier les critères
    For Each objSlide In ActivePresentation.Slides
        varModCriteria = strCriteria
        
        ' Remplacer chaque tag par sa valeur pour cette diapositive
        For i = 1 To objSlide.Tags.Count
                ValTag = objSlide.Tags.Value(i)
                If IsNumeric(ValTag) Then
                    varModCriteria = Replace(UCase(varModCriteria), UCase(objSlide.Tags.Name(i)), CLng(ValTag))
                Else
                    varModCriteria = Replace(UCase(varModCriteria), UCase(objSlide.Tags.Name(i)), """" & UCase(ValTag) & """")
                End If
        Next i
        
        ' Évaluer l'expression Pays="Fr" et Valeur>2
        On Error Resume Next
        If UCase(varModCriteria) <> UCase(strCriteria) Then
            If objExcelApp.Evaluate(varModCriteria) Then
                intSlideIndex = intSlideIndex + 1
                tabSlides(intSlideIndex) = objSlide.slideID
            End If
        End If
        On Error GoTo 0
    Next objSlide
    Set objExcelApp = Nothing
    
    ' Mettre à jour la liste des diapositives du diaporama personnalisé
    If intSlideIndex > 0 Then
        ' Redimensionner le tableau pour correspondre au nombre réel de diapositives sélectionnées
        ReDim Preserve tabSlides(1 To intSlideIndex)
        ' Créer un nouveau diaporama personnalisé vide
        ActivePresentation.SlideShowSettings.NamedSlideShows.Add strDiapoName, tabSlides
        MsgBox "Le diaporama personnalisé '" & strDiapoName & "' a été créé avec succès.", vbInformation
    Else
        MsgBox "Aucune diapositive ne correspond aux critères spécifiés.", vbExclamation
    End If
End Sub

Merci pour votre attention bienveillante.

Article intéressant ?

Cliquez sur une étoile pour noter cet article !

Note moyenne 0 / 5. Nombre de votes : 0

Aucun vote pour l'instant ! Soyez le premier à noter ce post.

Nous sommes désolés que cet article ne vous ait pas été utile !

Améliorons cet article !

Dites nous comment nous pouvons améliorer cet article ?

Publications similaires

Afficher un ruban personnalisé à l'ouverture d'un document spécifique

ParArnaud

Je vous propose de créer un ruban personnalisé, intégré dans un document (distribution et mise à jour facile). Il s’affichera à l’ouverture du document et donnera accès via des icones à des documents de références par exemple (possibilité non disponible via la personnalisation manuelle)

Laisser un commentaire

Votre adresse e-mail ne sera pas publiée. Les champs obligatoires sont indiqués avec *