user_mobilelogo

Voici deux macros qui vont faire ce travail avec Outlook. Ces deux macros font une copie de la présentation et suppriment toutes les diapos qui ne nous intéressent pas. On aurait pu juste faire un copier-coller de la ou des diapos, mais on risque d'avoir un résultat non conforme à l'original du point de vue Mise en forme. Donc, ne prenons pas ce risque.

Cette première macro va envoyer la troisième diapositive de la présentation en cours.

Sub envoi()
'macro écrite par m@rina
Dim chemin As String, x As Integer, nb As Integer
Dim diapo3 As String
Dim ol As Object, monItem As Object
Set ol = CreateObject("outlook.application")
Set monItem = ol.CreateItem(0)
chemin = ActivePresentation.Path
nb = ActivePresentation.Slides.Count
ActivePresentation.SaveCopyAs chemin & "\diapo3.pptx"
diapo3 = chemin & "diapo3.pptx"
Presentations.Open (diapo3)
For x = nb To 1 Step -1
If x <> 3 Then ActivePresentation.Slides(x).Delete
Next
Presentations(diapo3).Save
With monItem
'adresse mail du destinataire
    .To = "destinataire@adresse.fr"
    'sujet du mail
    .Subject = "envoi diapo3"
    'texte du corps du mail
    .body = "Bonjour" & Chr(13& Chr(13& "Je vous prie de bien vouloir trouver blabla"
    .Attachments.Add diapo3
    .Send
End With
Set ol = Nothing
Presentations(diapo3).Close
MsgBox "l'envoi a bien été effectué."
Kill diapo3
End Sub

 

Cette seconde macro va envoyer la dernière diapositive de la présentation en cours.

Sub envoi2()
'macro écrite par m@rina
Dim chemin As String, nb As Integer, x As Integer
Dim p_result As String
Dim ol As Object, monItem As Object
Set ol = CreateObject("outlook.application")
Set monItem = ol.CreateItem(0)
chemin = ActivePresentation.Path
nb = ActivePresentation.Slides.Count
ActivePresentation.SaveCopyAs chemin & "\result.pptx"
p_result = chemin & "result.pptx"
Presentations.Open (p_result)
For x = nb - 1 To 1 Step -1
ActivePresentation.Slides(x).Delete
Next
Presentations(p_result).Save
With monItem
'adresse mail du destinataire
    .To = "destinataire@adresse.fr"
    'sujet du mail
    .Subject = "envoi dernière diapo"
    'texte du corps du mail
    .body = "Bonjour" & Chr(13& Chr(13& "Je vous prie de bien vouloir trouver blabla"
    .Attachments.Add p_result
    .Send
End With
Set ol = Nothing
Presentations(p_result).Close
MsgBox "l'envoi a bien été effectué."
Kill p_result
End Sub
 

Voir aussi...

Statistiques

Aujourd'hui126
Hier2668
Cette semaine14510
Ce mois62507
Total depuis 200412420492

4
visiteurs actuellement en ligne

26 septembre 2020