Envoi des slides sélectionnés

[Kulgan]

Bonjour à tous!

Je cherche désespérément à pouvoir réaliser une macro qui prend toutes les slides sélectionnées, crée un fichier à part en conservant la mise en forme et envoie le tout dans un mail.

Je n'ai pas trouvé de réponse sur ce site, et je me heurte à une faible connaissance de VBA...

Quelqu'un aurait-il une idée, même vague, de ce que je pourrais faire?

Merci bcp par avance!!

 

[mromain]

Re : Envoi des slides sélectionnés

Bonjour Kulgan, le forum

Ton problème pourrait se décomposer comme suit :

• Créer une copie de la présentation active ne contenant que les diapositives sélectionnées ;
• Envoyer cette copie en mail ;
• Supprimer la copie.

Cette fonction permet de réaliser le premier point. Elle crée donc une copie de la présentation contenant uniquement les diapositives sélectionnées dans le répertoire TMP de l’utilisateur :

Private Function CopySelection() As String
Dim slidesSelection As SlideRange, i As Long, j As Long, k As Long, slidesNumber() As Long, pathNewPres As String, newPres As Presentation, toDelete As Boolean, myFso As Object
    
    'récupérer la sélection
     On Error Resume Next
     Set slidesSelection = ActiveWindow.Selection.SlideRange
    On Error GoTo ErrorManagement
    If slidesSelection Is Nothing Then Exit Function
    
    'récupérer les numéros de slides sélectionnés
     ReDim slidesNumber(1 To slidesSelection.Count)
    For i = 1 To slidesSelection.Count
        slidesNumber(i) = slidesSelection.Item(i).SlideNumber
    Next i
    
    'trier dans l'ordre croissant les numéros de slides sélectionnés
     For i = LBound(slidesNumber) To UBound(slidesNumber) - 1
        For j = i + 1 To UBound(slidesNumber)
            If slidesNumber(i) > slidesNumber(j) Then
                k = slidesNumber(j)
                slidesNumber(j) = slidesNumber(i)
                slidesNumber(i) = k
            End If
        Next j
    Next i
    
    'créer une copie de la présentation dans le répertoire "TMP" de l'utilisateur
     Set myFso = CreateObject("Scripting.FileSystemObject")
    pathNewPres = Environ("TMP") & "\Copie_" & myFso.GetBaseName(ActivePresentation.Name)
'    pathNewPres = pathNewPres & ".pptm"                'avec macro (.pptm)
 '    ActivePresentation.SaveCopyAs pathNewPres          'avec macro (.pptm)
     pathNewPres = pathNewPres & ".pptx"                                         'sans macro (.pptx)
     ActivePresentation.SaveCopyAs pathNewPres, ppSaveAsOpenXMLPresentation      'sans macro (.pptx)
     Set newPres = Application.Presentations.Open(pathNewPres)
    
    'supprimer les slides (dans la copie) qui n'étaient pas sélectionnés
     For i = newPres.Slides.Count To 1 Step -1
        toDelete = True
        For j = LBound(slidesNumber) To UBound(slidesNumber)
            If newPres.Slides(i).SlideNumber = slidesNumber(j) Then toDelete = False
        Next j
        If toDelete Then newPres.Slides(i).Delete
    Next i
    'fermer la copie
     newPres.Save
    newPres.Close
    
    CopySelection = pathNewPres
    Exit Function
ErrorManagement:
End Function

Elle retourne une chaine de caractère vide s’il y a eu une erreur, sinon elle retourne le path de la nouvelle présentation.

Ci-dessous un exemple de macro qui utilise cette fonction :

Public Sub SendSelectionMail()
Dim pathNewPres As String, myFso As Object

    'créer une présentation contenant les slides sélectionnés dans le répertoire "TMP" de l'utilisateur
     pathNewPres = CopySelection()
    If pathNewPres = "" Then
        MsgBox "Erreur durant la création du fichier PowerPoint." & vbNewLine & "Fin de la macro...", vbCritical, "Erreur"
        Exit Sub
    End If
    
    'créer un mail avec cette présentation en PJ
     '...
     '...
     '...
    
    'supprimer la présentation du dossier "TMP" de l'utilisateur
     Set myFso = CreateObject("Scripting.FileSystemObject")
    myFso.DeleteFile pathNewPres, True
    
End Sub

Il ne reste que la partie envoi de mail avec PJ qui n’est pas implémentée, mais tu trouveras une foule d’exemples sur le forum.

A+

Miki

 

[Kulgan]

Re : Envoi des slides sélectionnés

Merci beaucoup de ta réponse! Je vais regarder ça de près ce week end!