Visual Basic, VB6, VB.NET, VB 2005, VB CodeS-SourceS

CodeS-SourceS est hébergé par Frontier.fr

Ce site au démarrage

begin process at 2012 02 13 22:48:29

Accueil Codes Tutoriels Forum Livres Emploi Services Connexion

Trouver un code source :

dans

[ Dernières recherches ]

Accueil >

DIAPORAMA POWERPOINT DEPUIS EXCEL

Information sur la source

Note :
Aucune note

Catégorie :VBA Classé sous :Diaporama, ListBox, Fichier, PPT, PowerPoint Niveau :Débutant Date de création :05/02/2009 Date de mise à jour :23/03/2009 12:41:28 Vu / téléchargé :7 708 / 767

Auteur : Le Pivert

Ecrire un message privé

Commentaire sur cette source (16)

Ajouter un commentaire et/ou une note

Description

Cliquez pour voir la capture en taille normale

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

'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

'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

Fichier Zip

Les Membres Club peuvent télécharger directement un fichier contenu dans le zip sans télécharger le zip en entier !

Creer Diaporama.xls262 144 octets

Télécharger le zip

Historique

06 février 2009 14:08:11 :: Correction d'un bug à l'ouverture d'un dossier si l'on n'ouvrez pas. Correction du comptage des fichiers qui ce réactualise au fur et à mesure des suppression.
07 février 2009 12:20:27 :: On peut mettre un cadre autour des images à la couleur désirée.
07 février 2009 12:27:00 :: Mauvais zip
09 février 2009 15:10:29 :: Vous pouvez choisir un délai de transition et un fichier son. Une transition ainsi que sa vitesse est programmé.Consultez l'aide qui est diponible dans le MenuBar.
09 février 2009 15:15:41 :: Le code ne s'était pas enregistré.
10 février 2009 09:35:38 :: Toutes les transitions sont sur la feuille 3, je n'ai pas réussi à automatisé avec un combo cela ne fonctionne pas. J'ai supprimé certaines redondances.Le son est sur la dernière image, si une personne a une idée poue le mettre sur la 1ère diapo? Merci à tous
10 février 2009 12:05:56 :: C'est fait le son se déclenche à la 1ère image. J'ai mis un comboBox pour les transitions, mais il n'est pas opérationnel, si une personne avait une idée pour le faire fonctionner?
11 février 2009 16:57:49 :: Transitions: vous pouvez choisir les effets, la vitesse et le délai comme avec PowerPoint. Je n'y arrivais pas avec les comboBox, j'ai donc mis des OptionButton.Cela fait un peu plus de code et de travail.
14 février 2009 12:30:49 :: Motifs de texture sur les AR plans des images et un titre de présentation sur la 1ère Diapo.
14 février 2009 13:58:45 :: Oubli de l'option "Sans motif de texture".
20 février 2009 16:05:10 :: Ajout des textures en plus des motifs.
03 mars 2009 17:46:03 :: Mise à l'échelle et centrage de l'image en mode portrait Option: Diapo en continu jusquà échap
11 mars 2009 12:22:32 :: Vous pouvez mettre la couleur sans cadre en mode portrait. Ajout de dégradé de couleurs que vous pouvez choisir. Son en boucle jusqu'au prochain son. Nom de l'auteur de la dernière modification de fichier en en-tête de présentation ( enregistrer le fichier Excel pour prendre effet)
18 mars 2009 18:45:18 :: Suivant les conseils de BIGFISH_LEVRAI que je remercie, j'ai modifié l'ouverture des dossiers images en ajoutant un filtre pour les extensions "JPG et Gif" ce qui évite d'avoir des fichiers inutiles à supprimer.
23 mars 2009 12:41:28 :: Nouveau module d'ouverture: filtre des sous-dossiers,cela évite des erreurs d'ouverture. Choix de l'arborescence: Complète ou "Mes Documents"

Sources du même auteur

CREER UN GIF ANIMÉ

EXPORTER LES IMAGES DE WORD ET D' EXCEL

COLLECTION ID

PROTECTION VBAPROJECT

PASSWORD CLASSEUR EXCEL

Toutes les sources de Le Pivert

Sources de la même categorie

GESTION PERSONNEL par oudlarbi

CALENDRIER EN VBA POUR EXCEL 2010 par nounou94

MANIPULER LES FENETRES ENFANT D'EXCEL par bigfish_le vrai

COLLECTION ID par Le Pivert

VBA MASQUE DE SAISIE NUMÉRIQUE par acive

Toutes les sources de la catégorie VBA

Sources en rapport avec celle ci

JOUER UN SON MP3 DANS UN DIAPORAMA POWERPOINT par Le Pivert

COMPARER_2FICHIERS_TEXTE par Le Pivert

GADGET DIAPORAMA par Le Pivert

CRÉER DIAPORAMA PPT par Le Pivert

HORLOGE DIAPORAMA par Le Pivert

Commentaires et avis

Commentaire de Le Pivert le 06/02/2009 12:04:05

Pour que le programme fonctionne faites:
Alt F11- Outils- Références, et cochez:
Microsoft PowerPoint 11.0 Object Library.
@+ Le Pivert

Commentaire de LolPiratas le 08/02/2009 15:36:03

salut
j'ai essayé mais il ne m'affiche qu'une seule image dans PowerPoint de la liste j'ai la derniere version PowerPoint

Commentaire de LolPiratas le 08/02/2009 15:43:17

re j'ai donc refaite la manip et en faite il je devais selectionner la derniere image de la liste. c'est pas mal mais il faudrait y ajouter un code pour les images automatique car je doit cliquer pour voir l'image suivante.

Commentaire de Le Pivert le 08/02/2009 17:49:29

Bonjour LolPiratas
Il faut sélectionner toutes les images que tu veux voir figurer dans ton diaporama et ne pas en laisser sinon tu as des diapos vierges.
Ensuite pour le défilement des images, je pense que tu dois parler de PowerPoint.Tu vas dans la Barre de Menu: Diaporama et Transition. Tu sélectionnes ta 1ère image, à droite tu verras: "Passer à la diapositive suivante", tu sélectionnes "Automatique" après, tu mets le nombre de secondes et tu cliques sur "Appliquer à toutes les diapositives".
As-tu Excel 2007. J'aimerais savoir si cela fonctionne avec?
@+Le Pivert

Commentaire de LolPiratas le 08/02/2009 19:28:40

.........As-tu Excel 2007. J'aimerais savoir si cela fonctionne avec?
oui cela fonctionne avec 2007.

...........Tu vas dans la Barre de Menu: Diaporama et Transition. Tu sélectionnes ta 1ère image, à droite tu verras: "Passer à la diapositive suivante", tu sélectionnes "Automatique" après, tu mets le nombre de secondes et tu cliques sur "Appliquer à toutes les diapositives".
oui mais pourrez tu pas dans ton code ajouter directement les options (automatiques ......)

Commentaire de Le Pivert le 08/02/2009 20:43:19

Excuse-moi, je n'avais pas compris pour le minutage, je trouvais qu'avec la présentation ouverte c'était facile de choisir toutes les options. Je vais essayer d'adapter un code pour cela.
@+ Le Pivert

Commentaire de Le Pivert le 09/02/2009 11:23:28

Bonjour LolPiratas
Je te remercie de m'avoir stimulé, effectivement ayant trouver le code pour colorer les AR Plans, il m'a été facile de faire le reste: Délai, choix de transitions; Sonorisation. Je met tout cela au propre et j' envoie une MAJ
@+ Le Pivert

Commentaire de bigfish_le vrai le 17/03/2009 11:51:21

Salut,

une petite remarque sur la selection du repertoire qui ne fonctionne pas tres bien et notament sur la selection des repertoires system tel que le repertoire MesImages.

La solution que tu utilises est une mauvaise methode largement rependu sur le web... comme quoi ce n'est pas forcement le meilleur qui ce repend ^^.

Je te propose donc 3 autres methodes dont 2 basées sur le shell.Application tel que ta methode

methode 1 ===========================================================

Function ChoisirDossier()
    Dim objShell, objFolder, chemin As String, SecuriteSlash

    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(&H0&, "Choisisser un répertoire", &H1&)
    On Error Resume Next
    chemin = objFolder.Items.Item.Path

    SecuriteSlash = InStr(objFolder.Title, ":")

    If SecuriteSlash > 0 Then
        chemin = Mid(objFolder.Title, SecuriteSlash - 1, 2) & ""
    End If
    ChoisirDossier = chemin
End Function

methode 2 ===========================================================
(methode qui vient du msdn et que je n'ai jamais vu ailleur)

Function ChoisirDossier() As String
    Dim objShell As Object, objFolder2 As Object

    Set objShell = CreateObject("Shell.Application")
    Set objFolder2 = objShell.BrowseForFolder(&H0&, "Choisisser un répertoire", &H1&)
        If (Not objFolder2 Is Nothing) Then
            Dim objFolderItem As Object
            Set objFolderItem = objFolder2.Self
                If (Not objFolderItem Is Nothing) Then
                    ChoisirDossier = objFolderItem.Path
                Else
                    ChoisirDossier = ""
                End If
            Set objFolderItem = Nothing
        Else
            ChoisirDossier = ""
        End If
    Set objFolder2 = Nothing
    Set objShell = Nothing
End Function

methode 3 ===========================================================

Function ChoisirDossier(Optional ByVal LeChemin As String, Optional FolderDialogTitle As String) As String
  If FolderDialogTitle = "" Then FolderDialogTitle = "Select Default files location: "
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = FolderDialogTitle
    .InitialFileName = LeChemin
    If .Show = -1 Then
        ChoisirDossier = .InitialFileName
    Else ' bonton Cancel (annulé)
        ChoisirDossier = ""
    End If
  End With
End Function

En ce qui me concerne j'ai une preference pour la methode 3 mais il ne faut pas que cela influence ton choix.

A+ :)

Commentaire de Le Pivert le 17/03/2009 14:37:13

Merci BIGFISH_LE VRAI pour ton commentaire. J'ai essayé les 3 méthodes, l'avantage de la 3ème est que tu restes sur le dernier dossier ouvert, par contre il faut aller jusqu'au bout dans "Ouvrir" sinon tu n'ouvres que le chemin des dossiers et non celui des fichiers.Je pense opter pour la 1ère méthode qui est la plus simple. Par contre j'aurais aimé trouver un système d'ouverture qui supprimerait les fichiers non images pour ne pas a avoir le faire manuellement.
@+ Le Pivert

Commentaire de Le Pivert le 18/03/2009 18:50:08

Bonjour BIGFISH_LE VRAI,
J'ai réussi à trouvé un filtre pour les extensions et j'ai mis ta méthode 1 de sélection du répertoire.
Merci et @+ Le Pivert

Commentaire de Le Pivert le 26/07/2009 11:41:58

Bonjour
Il est possible que lors du transfert des images, elles soient trop grandes ou trop petites dans la présentation.
J'ai réglé le diapo sur des images de: 1600 px X 1200 px et une résolution de 180 ppp, ce qui donne en cm : 22,58 X 16,94
La solution: redimensionner les images à: 22,58 cm sur le plus grand côté à l'aide du programme "Redimensionner Image" que vous pouvez télécharger sur:
http://www.vbfrance.com/codes/REDIMENSIONNER-IMAGE_50214.aspx
@+ Le Pivert

Commentaire de loana3000 le 18/05/2010 15:29:35

Bonjour,
j'ai un problème. Cela bugge à CHR, mid et la référence Microsoft PowerPoint 11.0 Object Library est cochée.
Merci d'avance

Commentaire de Le Pivert le 18/05/2010 17:53:10

Bonjour LOANA3000,
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

Commentaire de maitesidur le 06/08/2010 07:26:42

Salut Le Pivert, comme loana, je te confirme que ton projet, bien qu'excellent, beug à ce niveau ci (If Right(Directory, 1) <> "\"), sous xp pro et excel 2003, lors de la sélection de dossier image:

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.

Commentaire de Le Pivert le 06/08/2010 08:06:20

Merci MAITESIDUR pour ton commentaire. Je me sers de ce programme depuis sa création et je n'ai pas de bug.Donc il m'est difficile de trouvé d'où cela provient. Ce que je te conseille c'est de changer le module par un de ceux proposés par Bigfish_le Vrai qui avait fait une remarque à ce sujet.
Ses modules fonctionnent très bien tous les trois.
@+ Le Pivert

Commentaire de Le Pivert le 06/08/2010 10:59:15

Deux questions MAITESIDUR:
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

Ajouter un commentaire

Discussions en rapport avec ce code source dans le forum

Powerpoint [ par patsonk ] Salut,j'ai un probleme de debutant. je dois au fait inserer un slide d'un fichier powerpoint dans un autre fichier powerpointj'ai utiliser la fonction automatiser powerpoint [ par breton51 ] Bonjour, Je viens vers vous pour un petit éclaircissement, voila je voulais automatiser des diaporamas via un logiciel externe le but de ce logiciel [Catégorie modifiée VB6 -> VBA] Macro entre excel et powerpoint [ par schevs10 ] Bonjour, Voici mon sujet : j'ai un fichier excel avec pleins de tableau. Après la mise à jour des tableaux, je dois les coller sur un powerpoint. J Comment enregistrer le contenu d'une ListBox dans un fichier txt ? [ par Sab ] Merci pour votre aide Comment faire pour ne pas avoir 2 même string dans une listbox ??? [ par [ReSTiTuTe] ] Salut,Je vous explique, j'ouvre un fichier et je le met dans une liste box, après, je rajoute un autre fichier dans cette listbox, je voudrais savoir comment mettre un fichier TXT dans une "listbox" [ par sebas ] Je voudrait pouvoir lire dans ma list box le contenu d'un fichier txtmerci d'avence =:-) Sauvegarder/Charger plusieurs listbox dans un même fichier [ par Chum ] Comment proceder pour pouvoir sauvegarder dans un meme fichier plusieurs listbox ?Comment les charger ?Voila ! Comment enregistrer le contenu d'un ListBox Dans un Fichier xls (*.xls) [ par Patou ] (Dans la première colnne de préférence)Merci pour vos réponses ouvrir un diaporama Powerpoint (.pps) en VBA sous Excel [ par rvduclos ] SalutEst-ce que quelqu'un à une idée pour lancer un diaporama sous Excel.Je ne comprends pas pourquoi un shell ne fonctionne pas ?Shell ("C:\WINDOWS\B VB et XML [ par pierreII ] Bonjour,J'ai réalisé un petit programme qui affiche du texte dans une ListBox, j'aimerais récupérer les éléments de cette ListBox, et les mettre dans

Nos sponsors

Derniers Blogs

XNA IS DEAD! par richardc

TECHDAYS PARIS 2012 : WINDOWS SERVER "8" QUOI DE 9 ! par ROMELARD Fabrice

[HTML5] AUTOUR DU W3C : NOUVEAUX STANDARDS ET WEB MOBILE (LILLE) par Gio

TECHDAYS PARIS 2012 : CHUCK MORRIS N'A PAS PEUR DES MALWARES, CE SONT LES MALWARES QUI ONT PEUR DE CHUCK MORRIS par ROMELARD Fabrice

[WP7] DYNAMICALLY CHANGE STARTUP PAGE par KooKiz

Forum

TRACER UNE COURBE EN VB DOTNET par sassouyassmouna

RE : PARCOURIR FICHIER TEXTE (.TXT) EN VBA par sancho12345

COMPORTEMENT BIZZARD : LES NOUVEAUX ENREGISTREMENTS DE LA TABLE ENFANTS SONT IGNORéS par BasicZx81

SELECTIONNER UN FICHIER EXCEL ET L'OUVRIR par ossama261988

RE : OUVRIR DES CLASSEURS EXCEL ? par ossama261988

Côté IT

Offres d'emploi

Formations Video

Appels d'offres

URGENT - Realisation d-un flux standard XML -NewsML- CAHIER DES CHARGES DISPONIBLE
Budget : 400€
Creation de newsletter sur une page Facebook
Budget : 400€
fichier d-export de site OS commerce ver plateforme logistique-CDC disponible
Budget : 1 200€

Logiciels

DocTranslate (V3.1.0.0)
DOCTRANSLATE (V3.1.0.0)

DocTranslate est un traducteur de document Microsoft Word, PowerPoint et Excel. Il permet d'autom...

Cliquez pour télécharger DocTranslate
Tribler (2012)
TRIBLER (2012)

Tribler est un client pair à pair (P2P/Peer-to-Peer) open source avec la capacité de regarder des...

Cliquez pour télécharger Tribler
OneSwarm (2012)
ONESWARM (2012)

Le peer-to-peer qui protège votre vie privée, c'est OneSwarm. Ce logiciel de peer-to-peer crypté...

Cliquez pour télécharger OneSwarm
PONAMEDIA PREMIUM - HELLLOOO FLASH DEMO (V8.4)
PONAMEDIA PREMIUM - HELLLOOO FLASH DEMO (V8.4)

PONAMEDIA TV DEVIENS HELLLOOO FLASH LA TV SUR VOTRE ORDINATEUR. Toute une plateforme Multi...

Cliquez pour télécharger PONAMEDIA PREMIUM - HELLLOOO FLASH DEMO
Academy System (17.2.1.0)
ACADEMY SYSTEM (17.2.1.0)

Logiciel de gestion des établissements. - élèves/étudiants (inscription, dossier, absence...) -...

Cliquez pour télécharger Academy System