Diaporama powerpoint depuis excel

Télécharger le projet
Commenter

Description

Créer un diaporama PPT depuis Excel.Vous sélectionnez un dossier d'images, vous pouvez supprimer, monter et descendre les fichiers dans une listBox.Vous pouvez mettre un cadre autour des images à la couleur, au dégradé, au motif et à la texture que vous désirez ainsi q'un titre de présentation sur la 1ère diapo.Vous pouvez choisir pour les transitions: l'effet, la vitesse et le délai ainsi q'un fichier son (wav uniquement). Option: Diapo en continu jusquà échap, Son en boucle.Ensuite vous sélectionnez tout les fichiers et votre diaporama est crée, il ne vous reste plus qu'a l'enregistrer.

Source / Exemple : 


'Necessite de cocher la référence:Microsoft PowerPoint 11.0 Object Library
'Ouvrir fichiers dans leur programme par défaut
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
    (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
    ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Dim var As String
Private Sub CommandButton1_Click()
On Error Resume Next 'En cas d'erreur d'ouverture
AfficheFichiersEtChemins 'on ouvre le dossier
LignesVisiblesSurFiltre 'on compte les fichiers
inverser 'inverser les fichiers pour qu'ils soient dans l'ordre dans la présentation
End Sub
Private Sub CommandButton2_Click() 'création du diaporama
    Dim I As Integer
    Dim ppApp As PowerPoint.Application
    Dim ppPres As PowerPoint.Presentation
    Dim ppShape As PowerPoint.Shape
    Dim ppCurrentSlide As PowerPoint.Slide
 
 On Error Resume Next
    Set ppApp = CreateObject("PowerPoint.Application")
    ppApp.Visible = True

    Set ppPres = ppApp.Presentations.Add(msoTrue)
    Set ppCurrentSlide = ppPres.Slides.Add(Index:=1, Layout:=ppLayoutBlank)
  
 'On sélectionne les images
              For I = 0 To Me.ListBox1.ListIndex()
           
            With ppPres.Slides.item(1).Shapes '*** Insère l'image.
                    
                    '*** Ajoute le slide
                  Set ppCurrentSlide = ppPres.Slides.Add(Index:=1, Layout:=PowerPoint.PpSlideLayout.ppLayoutBlank)
                        'Transitions
                        Set mySlides = ppPres.Slides.Range(Array(1, 3)).SlideShowTransition
'Vitesse Transition
If OptionButton3 = True Then
 mySlides.Speed = ppTransitionSpeedFast
ElseIf OptionButton4 = True Then
mySlides.Speed = ppTransitionSpeedMedium
ElseIf OptionButton5 = True Then
mySlides.Speed = ppTransitionSpeedSlow
End If

'Effets Transition voir feuil3
If OptionButton6 = True Then
mySlides.EntryEffect = ppEffectNone
ElseIf OptionButton7 = True Then
mySlides.EntryEffect = ppEffectAppear
ElseIf OptionButton8 = True Then
mySlides.EntryEffect = ppEffectBlindsHorizontal
ElseIf OptionButton9 = True Then
 mySlides.EntryEffect = ppEffectBlindsVertical
ElseIf OptionButton10 = True Then
mySlides.EntryEffect = ppEffectBoxIn
ElseIf OptionButton11 = True Then
mySlides.EntryEffect = ppEffectBoxOut
ElseIf OptionButton12 = True Then
mySlides.EntryEffect = ppEffectCheckerboardAcross
ElseIf OptionButton13 = True Then
mySlides.EntryEffect = ppEffectCheckerboardDown
ElseIf OptionButton14 = True Then
 mySlides.EntryEffect = ppEffectCoverDown
ElseIf OptionButton15 = True Then
mySlides.EntryEffect = ppEffectCoverLeft
ElseIf OptionButton16 = True Then
mySlides.EntryEffect = ppEffectCoverLeftDown
ElseIf OptionButton17 = True Then
mySlides.EntryEffect = ppEffectCoverLeftUp
ElseIf OptionButton18 = True Then
 mySlides.EntryEffect = ppEffectCoverRight
ElseIf OptionButton19 = True Then
mySlides.EntryEffect = ppEffectCoverRightDown
ElseIf OptionButton20 = True Then
mySlides.EntryEffect = ppEffectCoverRightUp
ElseIf OptionButton21 = True Then
mySlides.EntryEffect = ppEffectCoverUp
ElseIf OptionButton22 = True Then
mySlides.EntryEffect = ppEffectDissolve
ElseIf OptionButton23 = True Then
 mySlides.EntryEffect = ppEffectFade
ElseIf OptionButton24 = True Then
mySlides.EntryEffect = ppEffectRandom
ElseIf OptionButton25 = True Then
mySlides.EntryEffect = ppEffectSplitHorizontalIn
ElseIf OptionButton26 = True Then
mySlides.EntryEffect = ppEffectSplitHorizontalOut
ElseIf OptionButton27 = True Then
mySlides.EntryEffect = ppEffectSplitVerticalIn
ElseIf OptionButton28 = True Then
 mySlides.EntryEffect = ppEffectSplitVerticalOut
ElseIf OptionButton29 = True Then
mySlides.EntryEffect = ppEffectUncoverDown
ElseIf OptionButton30 = True Then
mySlides.EntryEffect = ppEffectUncoverLeft
ElseIf OptionButton31 = True Then
mySlides.EntryEffect = ppEffectUncoverLeftDown
ElseIf OptionButton32 = True Then
 mySlides.EntryEffect = ppEffectUncoverLeftUp
ElseIf OptionButton33 = True Then
mySlides.EntryEffect = ppEffectUncoverRight
ElseIf OptionButton34 = True Then
mySlides.EntryEffect = ppEffectUncoverRightDown
ElseIf OptionButton35 = True Then
 mySlides.EntryEffect = ppEffectUncoverRightUp
ElseIf OptionButton36 = True Then
mySlides.EntryEffect = ppEffectUncoverUp
ElseIf OptionButton37 = True Then
mySlides.EntryEffect = ppEffectWipeDown
ElseIf OptionButton38 = True Then
mySlides.EntryEffect = ppEffectWipeLeft
ElseIf OptionButton39 = True Then
 mySlides.EntryEffect = ppEffectWipeRight
ElseIf OptionButton40 = True Then
mySlides.EntryEffect = ppEffectWipeUp
ElseIf OptionButton41 = True Then
mySlides.EntryEffect = ppEffectStripsDownLeft
End If
    
    'DélaiTransitions
     mySlides.AdvanceOnTime = True
    mySlides.AdvanceTime = Me.ComboBox1 'délai entre les transitions en secondes
                
                '*** Ajoute la couleur désirée
                Set mySlides = ppPres.Slides(2) '2ème diapo
               
               'Ajoute Dégradés voir feuille 2
               If OptionButton56 = True Then
                        With mySlides.Shapes.AddShape(msoShapeRectangle, _
         0, 0, 720, 540).Fill
    .ForeColor.RGB = RGB(Label2, Label3, Label4) 'Sans dégradé
   End With
  ElseIf OptionButton57 = True Then
     With mySlides.Shapes.AddShape(msoShapeRectangle, _
         0, 0, 720, 540).Fill
    .ForeColor.RGB = RGB(Label2, Label3, Label4)
    .BackColor.RGB = RGB(Label9, Label10, Label11)
    .TwoColorGradient msoGradientHorizontal, Variant:=3  'dégradé Horizontal
End With
     ElseIf OptionButton58 = True Then
     With mySlides.Shapes.AddShape(msoShapeRectangle, _
         0, 0, 720, 540).Fill
    .ForeColor.RGB = RGB(Label2, Label3, Label4)
     .BackColor.RGB = RGB(Label9, Label10, Label11)
    .TwoColorGradient msoGradientFromCenter, Variant:=2  'dégradé du centre
End With
     ElseIf OptionButton59 = True Then
    With mySlides.Shapes.AddShape(msoShapeRectangle, _
         0, 0, 720, 540).Fill
    .ForeColor.RGB = RGB(Label2, Label3, Label4)
     .BackColor.RGB = RGB(Label9, Label10, Label11)
    .TwoColorGradient msoGradientDiagonalDown, Variant:=4 'dégradé Diagonal
End With
    End If
    
    'Ajoute Motifs voir feuille 4
 If OptionButton42 = True Then
mySlides.Shapes.Range(1).Fill _
    .Patterned msoPatternMixed
ElseIf OptionButton43 = True Then
mySlides.Shapes.Range(1).Fill _
  .Patterned msoPatternDiagonalBrick
ElseIf OptionButton44 = True Then
mySlides.Shapes.Range(1).Fill _
  .Patterned msoPatternTrellis
ElseIf OptionButton45 = True Then
mySlides.Shapes.Range(1).Fill _
  .Patterned msoPatternSphere
ElseIf OptionButton46 = True Then
mySlides.Shapes.Range(1).Fill _
  .Patterned msoPatternZigZag
ElseIf OptionButton47 = True Then
mySlides.Shapes.Range(1).Fill _
  .Patterned msoPatternPlaid
ElseIf OptionButton48 = True Then
mySlides.Shapes.Range(1).Fill _
  .Patterned msoPatternSolidDiamond
End If
    
      'Ajoute Textures voir feuille 4
 If OptionButton49 = True Then
mySlides.Shapes.Range(1).Fill _
    .PresetTextured msoPresetTextureMixed
ElseIf OptionButton50 = True Then
mySlides.Shapes.Range(1).Fill _
  .PresetTextured msoTextureCanvas
ElseIf OptionButton51 = True Then
mySlides.Shapes.Range(1).Fill _
  .PresetTextured msoTextureGreenMarble
ElseIf OptionButton52 = True Then
mySlides.Shapes.Range(1).Fill _
  .PresetTextured msoTexturePapyrus
ElseIf OptionButton53 = True Then
mySlides.Shapes.Range(1).Fill _
  .PresetTextured msoTextureWaterDroplets
ElseIf OptionButton54 = True Then
mySlides.Shapes.Range(1).Fill _
  .PresetTextured msoTextureBouquet
ElseIf OptionButton55 = True Then
mySlides.Shapes.Range(1).Fill _
  .PresetTextured msoTextureDenim
End If
    
         If OptionButton1 = True Then 'Sans cadre
         '*** Ajoute image à la dimension désirée
                         Set oPicture = .AddPicture(Me.ListBox1.List(I), msoFalse, msoTrue, 0, 0)
     If oPicture.Height > oPicture.Width Then
     'Mis à l'échelle
     oPicture.ScaleHeight 0.85, msoTrue 'mode portrait
     oPicture.ScaleWidth 0.85, msoTrue
 Else
     oPicture.ScaleHeight 1.13, msoTrue 'mode paysage
     oPicture.ScaleWidth 1.13, msoTrue
    End If
   'Centrer l'image
   With ppPres.PageSetup
         oPicture.Left = (.SlideWidth \ 2) - (oPicture.Width \ 2)
         oPicture.Top = (.SlideHeight \ 2) - (oPicture.Height \ 2)
     End With
  
     Else
            OptionButton2 = True  'Avec cadre
         '*** Ajoute image à la dimension désirée
   Set oPicture = .AddPicture(Me.ListBox1.List(I), msoFalse, msoTrue, 0, 0)
        If oPicture.Height > oPicture.Width Then
     'Mis à l'échelle
     oPicture.ScaleHeight 0.75, msoTrue 'mode portrait
     oPicture.ScaleWidth 0.75, msoTrue
 Else
     oPicture.ScaleHeight 1, msoTrue 'mode paysage
     oPicture.ScaleWidth 1, msoTrue
    End If
      'Centrer l'image
      With ppPres.PageSetup
         oPicture.Left = (.SlideWidth \ 2) - (oPicture.Width \ 2)
         oPicture.Top = (.SlideHeight \ 2) - (oPicture.Height \ 2)
     End With
  
        End If
                End With
            Next I
        'Titre de la présentation
                      Titre_presentation 'nom du PC
         '(1)affiche sur la 1ère diapo
      Set mySlides = ppPres.Slides(1) '1ère diapo
            
            'Ajoute Dégradés voir feuille 2
               If OptionButton56 = True Then
                        With mySlides.Shapes.AddShape(msoShapeRectangle, _
         0, 0, 720, 540).Fill
    .ForeColor.RGB = RGB(Label2, Label3, Label4) 'Sans dégradé
   End With
  ElseIf OptionButton57 = True Then
     With mySlides.Shapes.AddShape(msoShapeRectangle, _
         0, 0, 720, 540).Fill
    .ForeColor.RGB = RGB(Label2, Label3, Label4)
     .BackColor.RGB = RGB(Label9, Label10, Label11)
    .TwoColorGradient msoGradientHorizontal, Variant:=3  'dégradé Horizontal
End With
     ElseIf OptionButton58 = True Then
     With mySlides.Shapes.AddShape(msoShapeRectangle, _
         0, 0, 720, 540).Fill
    .ForeColor.RGB = RGB(Label2, Label3, Label4)
     .BackColor.RGB = RGB(Label9, Label10, Label11)
    .TwoColorGradient msoGradientFromCenter, Variant:=2  'dégradé du centre
End With
     ElseIf OptionButton59 = True Then
    With mySlides.Shapes.AddShape(msoShapeRectangle, _
         0, 0, 720, 540).Fill
    .ForeColor.RGB = RGB(Label2, Label3, Label4)
     .BackColor.RGB = RGB(Label9, Label10, Label11)
    .TwoColorGradient msoGradientDiagonalDown, Variant:=4 'dégradé Diagonal
End With
    End If
  
'Texte
Set mySlides = ppPres.Slides(1)
mySlides.Shapes.AddShape(msoShapeRectangle, 150, 200, 420, 120) _
.TextFrame.TextRange.Text = "Présentation créée par " & Me.TextBox3

'Ajoute Motifs voir feuille 4
Set mySlides = ppPres.Slides(1) '1ère diapo
If OptionButton42 = True Then
mySlides.Shapes.Range(Array(1, 2)).Fill _
    .Patterned msoPatternMixed
ElseIf OptionButton43 = True Then
mySlides.Shapes.Range(Array(1, 2)).Fill _
  .Patterned msoPatternDiagonalBrick
ElseIf OptionButton44 = True Then
mySlides.Shapes.Range(Array(1, 2)).Fill _
  .Patterned msoPatternTrellis
ElseIf OptionButton45 = True Then
mySlides.Shapes.Range(Array(1, 2)).Fill _
  .Patterned msoPatternSphere
ElseIf OptionButton46 = True Then
mySlides.Shapes.Range(Array(1, 2)).Fill _
  .Patterned msoPatternZigZag
ElseIf OptionButton47 = True Then
mySlides.Shapes.Range(Array(1, 2)).Fill _
  .Patterned msoPatternPlaid
ElseIf OptionButton48 = True Then
mySlides.Shapes.Range(Array(1, 2)).Fill _
   .Patterned msoPatternSolidDiamond
End If
   
      'Ajoute Textures voir feuille 4
 Set mySlides = ppPres.Slides(1) '1ère diapo
If OptionButton49 = True Then
mySlides.Shapes.Range(Array(1, 2)).Fill _
    .PresetTextured msoPresetTextureMixed
ElseIf OptionButton50 = True Then
mySlides.Shapes.Range(Array(1, 2)).Fill _
  .PresetTextured msoTextureCanvas
ElseIf OptionButton51 = True Then
mySlides.Shapes.Range(Array(1, 2)).Fill _
  .PresetTextured msoTextureGreenMarble
ElseIf OptionButton52 = True Then
mySlides.Shapes.Range(Array(1, 2)).Fill _
  .PresetTextured msoTexturePapyrus
ElseIf OptionButton53 = True Then
mySlides.Shapes.Range(Array(1, 2)).Fill _
  .PresetTextured msoTextureWaterDroplets
ElseIf OptionButton54 = True Then
mySlides.Shapes.Range(Array(1, 2)).Fill _
  .PresetTextured msoTextureBouquet
ElseIf OptionButton55 = True Then
mySlides.Shapes.Range(Array(1, 2)).Fill _
  .PresetTextured msoTextureDenim
End If
       'ppPres.Slides(1).Delete 'à activer si l'on veut supprimer le nom, modifier pour le son (2)
       
       'Titre de la présentation et nom du dernier auteur de modification du fichier
    With ppPres.Slides.Add(Index:=1, Layout:=ppLayoutTitle).Shapes
    .Title.TextFrame.TextRange = Me.TextBox4
    .Placeholders(2).TextFrame.TextRange = "Créé par " & ThisWorkbook.BuiltinDocumentProperties("Last author").Value _
   & vbNewLine & "Pour démarrer: cliquez." _
   & vbNewLine & "Défilement automatique ensuite."
   End With
 
            ' Diapo en continu jusqu'à echap
  If CheckBox1 = True Then
 With ppPres.SlideShowSettings
                    .LoopUntilStopped = msoTrue
                    .AdvanceMode = PowerPoint.PpSlideShowAdvanceMode.ppSlideShowUseSlideTimings
                End With
      End If

'Sonorisation
      If TextBox2 = "" Then
      Exit Sub
      Else
       If CheckBox2 = True Then
       With ppPres.Slides(3).SlideShowTransition '(3)démarre à la 1ère image
    .SoundEffect.ImportFromFile (Me.TextBox2) 'chemin fichier son
    .LoopSoundUntilNext = msoTrue 'en boucle jusqu'au son suivant
End With
      Else
      Set mySlides = ppPres.Slides(3).SlideShowTransition '(3)démarre à la 1ère image
                       mySlides.SoundEffect.ImportFromFile (Me.TextBox2) 'chemin fichier son
End If
End If
End Sub
Private Sub CommandButton3_Click()
SupprimeLignesAvecTtexte ' on efface la liste
TextBox1 = "0 fichier"
End Sub
Private Sub CommandButton4_Click()
SupprimeLignesAvecTtexte ' on efface la liste
Unload UserForm1 'on ferme
End
End Sub
Private Sub CommandButton5_Click()
Dim LigneSelectionnée As Integer
      'Cherche la ligne selectionnée
       LigneSelectionnée = Me.ListBox1.ListIndex + 1
         If Me.ListBox1.ListCount >= 0 And LigneSelectionnée > 0 Then
           'Supprime la ligne
           Feuil1.Rows(LigneSelectionnée).Delete
         End If
         LignesVisiblesSurFiltre 'On compte les fichiers
End Sub
Private Sub CommandButton6_Click()
choisir_color 'on appelle la boite couleur
Couleur 'on transforme en RGB
CommandButton6.BackColor = RGB(Label2, Label3, Label4) 'on met la couleur sur le bouton
OptionButton49 = True 'Sans texture
End Sub
Private Sub CommandButton7_Click()
'On cherche le chemin du fichier son
On Error Resume Next
 Application.FileDialog(msoFileDialogOpen).Show
 TextBox2 = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(1)
CheckBox2.Visible = True 'en boucle
End Sub
Private Sub CommandButton8_Click()
choisir_degrade 'on appelle la boite couleur
Degrade 'on transforme en RGB
CommandButton8.BackColor = RGB(Label9, Label10, Label11) 'on met la couleur sur le bouton
OptionButton49 = True 'Sans texture
End Sub
Sub inverser()
'inverser les données d'une colonne et renvoyer le résultat dans une autre
Dim LCol$, LRow&, I&, ValCol
 LCol = "A"
  If LCol = "" Then Exit Sub
  LRow = Range(LCol & Rows.Count).End(xlUp).Row
  ValCol = Range(LCol & "1:" & LCol & LRow).Value
  LCol = "A"
  If LCol = "" Then Exit Sub
  Application.ScreenUpdating = False
  For I = UBound(ValCol) To LBound(ValCol) Step -1
    Range(LCol & UBound(ValCol) - I + 1).Value = ValCol(I, 1)
  Next I

End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
On Error Resume Next
     With Me.ListBox1
        If .ListIndex > -1 Then
            var = .List(.ListIndex)
       End If
    End With
    If var = "" Then
MsgBox (" Il n'y a aucune saisie!.")
Exit Sub
Else

'Ouvriravec
Dim Ret As Variant
Ret = ShellExecute(hwnd, "open", var, "", vbNullString, 1)
End If
End Sub
Private Sub MoveDown_Click()
Dim lCurrentListIndex As Long
Dim strRowSource As String
Dim strAddress As String
Dim strSheetName As String

With ListBox1
  If .ListIndex < 0 Or .ListIndex = .ListCount - 1 Then Exit Sub
    lCurrentListIndex = .ListIndex + 1
    strRowSource = .RowSource
    strAddress = Range(strRowSource).Address
    strSheetName = Range(strRowSource).Parent.Name
    .RowSource = vbNullString
        With Range(strRowSource)
            .Rows(lCurrentListIndex).Cut
            .Rows(lCurrentListIndex + 2).Insert Shift:=xlDown
        End With
     'Sheets(strSheetName).Range(strAddress).Name = strRowSource
    .RowSource = strRowSource
    .Selected(lCurrentListIndex) = True
End With
End Sub
Private Sub MoveUp_Click()
Dim lCurrentListIndex As Long
Dim strRowSource As String
Dim strAddress As String
Dim strSheetName As String

With ListBox1
  If .ListIndex < 1 Then Exit Sub
    lCurrentListIndex = .ListIndex + 1
    strRowSource = .RowSource
    strAddress = Range(strRowSource).Address
    strSheetName = Range(strRowSource).Parent.Name
    .RowSource = vbNullString
        With Range(strRowSource)
            .Rows(lCurrentListIndex).Cut
            .Rows(lCurrentListIndex - 1).Insert Shift:=xlDown
        End With
     'Sheets(strSheetName).Range(strAddress).Name = strRowSource
    .RowSource = strRowSource
    .Selected(lCurrentListIndex - 2) = True
     End With
    End Sub
Private Sub OptionButton56_Click()
CommandButton8.Visible = False
End Sub
Private Sub OptionButton57_Click()
CommandButton8.Visible = True
End Sub
Private Sub OptionButton58_Click()
CommandButton8.Visible = True
End Sub
Private Sub OptionButton59_Click()
CommandButton8.Visible = True
End Sub
Private Sub TextBox4_Change()
 If TextBox4 = "" Then
      TextBox4 = "Nouvel Album"
      End If
End Sub
Private Sub UserForm_Initialize()
ListBox1.ControlTipText = "Double clic pour ouvrir" _
& vbNewLine & "Sélectionnez le dernier fichier pour créer un Diaporama" _
& vbNewLine & "Sélectionnez à chaque fois pour monter et descendre" _
& vbNewLine & "Sélectionnez Single pour supprimer"
OptionButton1 = True
OptionButton3 = True
OptionButton6 = True
OptionButton42 = True
OptionButton49 = True
OptionButton56 = True
Label2 = "255"
Label3 = "255"
Label4 = "255"
CommandButton6.BackColor = RGB(Label2, Label3, Label4) 'on met la couleur sur le bouton
CommandButton8.Visible = False
CheckBox2.Visible = False
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
'On empêche de fermer avec la croix
    If CloseMode = vbFormControlMenu Then
        MsgBox "Vous ne pouvez pas utiliser ce bouton de fermeture."
        Cancel = True
    End If
End Sub

Conclusion :


Je remercie: http://frederic.sigonneau.free.fr/ pour ses modules
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (cs_Le Pivert)