0/5 (17 avis)
Vue 14 538 fois - Téléchargée 1 127 fois
'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
15 janv. 2016 à 19:09
Nouvelle mise à jour. Fonctionne sous Windows 10.
Bonne programmation
6 août 2010 à 10:59
As-tu un dossier "Mes Documents" sur ton PC?
Quand tu sélectionnes "Arborescence complète" y-a-t-il un bug?
Pour ceux qui auraient ce bug, en attendant une réponse.Dans le classeur "Diaporama PowerPoint depuis Excel" il y a un module: Sub AfficheFichiersEtChemins()
Il suffit de mettre dans le bouton: cmdopen
AfficheFichiersEtChemins à la place de ListFiles
@+ Le Pivert
6 août 2010 à 08:06
Ses modules fonctionnent très bien tous les trois.
@+ Le Pivert
6 août 2010 à 07:26
Sub ListFiles()
Dim msg As String, answer As String
Dim Directory As String
Dim R As Integer
Dim i As Integer
msg = "Choisissez un endroit contenant les dossiers que vous voulez sélectionner."
Directory = GetDirectory(msg)
If Directory = "" Then Exit Sub
If Right(Directory, 1) <> "" Then Directory = Directory & ""
Bon courage pour ce superbe projet!
Si j'ai le temps, je verrais a regarder ce pb, au cas ou je te tiens au courant.
Bye.
18 mai 2010 à 17:53
Cela bug dans le code de l'UserForm ou dans un module?
Je suis sur Excel 2003 OfficeXP SP3 et LOLPIRATAS m'a confirmé que cela fonctionné sur Excel 2007. A ce jour il y a eu 650 téléchargements et je n'ai eu aucun problème. Je vais faire des recherches.
@+ Le Pivert
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.