CRÉER DIAPORAMA PPT

Option Strict Off
Option Explicit On
Imports VB = Microsoft.VisualBasic
Imports System.IO
Imports System.Drawing.Imaging
Friend Class Form1
    Inherits System.Windows.Forms.Form
    Private Structure COULEUR 'type personnalisé
        Dim red As Byte 'qté de rouge
        Dim green As Byte 'qté de vert
        Dim blue As Byte 'qté de bleu
    End Structure
    Public Shared ftype As String = ".gif.GIF.bmp.BMP.jpg.jpeg.JPG.png.PNG.tif.TIF.ppm"
    Public Shared imgPaths() As String
    Dim i As Integer
    Dim intReturn As Integer
    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
        cmdcreer.Enabled = False
        cmddegrade.Visible = False
        RadioButton1.Checked = True
        RadioButton4.Checked = True
        RadioButton6.Checked = True
        RadioButton8.Checked = True
        RadioButton14.Checked = True
        RadioButton20.Checked = True
        RadioButton26.Checked = True
        CheckBox2.Visible = False
        ComboBox1.Text = "3"
        ComboBox2.Text = "*.jpg"
        Label6.Text = "255"
        Label7.Text = "255"
        Label8.Text = "255"
    End Sub
#Region " Ouverture"
    Private Sub cmdopen_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdopen.Click
        cmdcreer.Enabled = False
        Textlistcount.Text = "0"
        Textcount.Text = "0"
        lstvItem.Items.Clear() 'effacement de la listeview 
        Textfile.Text = "" 'effacement du chemin
        ListBox1.Items.Clear() 'effacement de la liste 
        FileListBox1.Items.Clear() 'effacement de la liste 
        Dim a As New FolderBrowserDialog
        If a.ShowDialog = Windows.Forms.DialogResult.OK Then
            On Error Resume Next
            Textfile.Text = "" & a.SelectedPath & "\"
            FileListBox1.Pattern = ComboBox2.Text
            FileListBox1.Path = Textfile.Text
        End If
        If Textfile.Text = "" Then
            MsgBox("Opération annulée par l'utilisateur")
            Exit Sub
        End If
        LstFill(Textfile.Text)
        Triinverse() 'on inverse la liste pour la présentation 

    End Sub
#End Region
#Region " ListBox Up Down Inverse Delete"
    Sub Triinverse()
        Dim ou As Integer
        ou = 0
        For i = 0 To ListBox1.Items.Count - 1
            ListBox1.Items.Insert(ou, ListBox1.Items(ListBox1.Items.Count - 1))
            ou = ou + 1
            ListBox1.Items.RemoveAt(ListBox1.Items.Count - 1)
        Next

    End Sub
    Private Sub cmdup_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdup.Click
        Dim int As Integer = ListBox1.SelectedIndex
        If ListBox1.SelectedItems.Count = 0 Then Exit Sub
        int = ListBox1.SelectedIndex - 1
        Dim item As String = ListBox1.SelectedItem
        ListBox1.Items.Remove(item)
        ListBox1.Items.Insert(int, item)
        ListBox1.SetSelected(int, True)
    End Sub
    Private Sub cmddown_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmddown.Click
        Dim int As Integer = ListBox1.SelectedIndex
        If ListBox1.SelectedItems.Count = 0 Then Exit Sub
        int = ListBox1.SelectedIndex + 1
        Dim item As String = ListBox1.SelectedItem
        ListBox1.Items.Remove(item)
        ListBox1.Items.Insert(int, item)
        ListBox1.SetSelected(int, True)
    End Sub
    Private Sub cmddelete_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmddelete.Click
        For i As Integer = ListBox1.Items.Count - 1 To 0 Step -1
            If ListBox1.SelectedIndices.Contains(i) Then ListBox1.Items.RemoveAt(i)
        Next
    End Sub
    Private Sub ListBox1_SelectedIndexChanged_1(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles ListBox1.SelectedIndexChanged
        If ListBox1.SelectedIndex <> -1 Then
            cmdup.Enabled = False
            cmddown.Enabled = False
        End If
        'Ça ne sert à rien de vouloir cliquer sur Monter si l'entrée est déjà tout en haut.
        If ListBox1.SelectedIndex > 0 Then cmdup.Enabled = True Else cmdup.Enabled = False

        'Idem, inutile de vouloir descendre si on est déjà tout en bas.
        If ListBox1.SelectedIndex < ListBox1.Items.Count - 1 Then cmddown.Enabled = True Else cmddown.Enabled = False

        Textcount.Text = ListBox1.SelectedItems.Count 'Nbre de fichiers sélectionnés
        cmdcreer.Enabled = True
    End Sub
#End Region
#Region " Imageviewer"
    Private Sub LstFill(ByVal ipath As String)
        Dim xx As Integer = 0

        'On vérifie si le path est valable
        If ipath.Trim.Length = 0 Then
            MsgBox("Le chemin d'accès spécifié n'existe pas. Veuillez recommencer.", MsgBoxStyle.Exclamation)
            Exit Sub
        End If

        If ipath.EndsWith("\") = False Then
            ipath += "\"
        End If

        If Directory.Exists(ipath) = False Then
            MsgBox("Le chemin d'accès spécifié n'existe pas. Veuillez recommencer.", MsgBoxStyle.Exclamation)
            Exit Sub
        End If

        Try
            Dim ist As String
            Dim i As Integer = 0
            Dim opt As System.IO.SearchOption = System.IO.SearchOption.TopDirectoryOnly
            Me.Cursor = Cursors.WaitCursor
            'on vide la viewer et la liste d'images

            With lstvItem
                .BeginUpdate()
                .Clear()
            End With

            imglst.Images.Clear()

            ReDim imgPaths(0)

            'On remplit la liste
            For Each ist In Directory.GetFiles(ipath, "*", opt)

                If ftype.Contains(Path.GetExtension(ist)) = True Then
                    ReDim Preserve imgPaths(i)
                    imgPaths(i) = ist

                    Select Case Path.GetExtension(ist)

                        Case Is = ".gif", ".GIF"
                            imglst.Images.Add(My.Resources.gif)
                        Case Is = ".bmp", ".BMP"
                            imglst.Images.Add(My.Resources.bmp)
                        Case Is = ".jpg", ".JPG", ".jpeg"
                            imglst.Images.Add(My.Resources.jpg)
                        Case Is = ".png", ".PNG"
                            imglst.Images.Add(My.Resources.png)
                        Case Is = ".tif", ".TIF"
                            imglst.Images.Add(My.Resources.tif)
                        Case Is = ".ppm"
                            imglst.Images.Add(My.Resources.ppm)
                    End Select

                    With lstvItem
                        .Items.Add(Path.GetFileNameWithoutExtension(ist), i)
                        .Items.Item(i).SubItems.Add(ist)
                    End With
                    xx += 1
                    Textlistcount.Text = lstvItem.Items.Count

                    i += 1
                End If
            Next
            Me.Cursor = Cursors.Arrow
            lstvItem.EndUpdate()
            Application.DoEvents()

            'on affiche les images en miniature
            If Me.lstvItem.Items.Count <> 0 Then
                For i = 0 To imglst.Images.Count - 1
                    imglst.Images.Item(i) = Image.FromFile(imgPaths(i)).GetThumbnailImage(120, 120, Nothing, IntPtr.Zero)
                    ListBox1.Items.Add(imgPaths(i))
                    lstvItem.RedrawItems(i, i, True)
                    Application.DoEvents()
                Next
            End If

        Catch ex As Exception

        End Try

        If lstvItem.Items.Count <> 0 Then

        End If

    End Sub
    Private Sub lstvItem_SelectedIndexChanged_1(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles lstvItem.SelectedIndexChanged
        Dim frm As New Form2
        Try
            Dim s As String = lstvItem.SelectedItems(0).SubItems(1).Text

            If File.Exists(s) = True Then
                If Path.GetExtension(s) = ".ppm" Then
                    frm.BackgroundImage = ShaniSoft.Drawing.PNM.ReadPNM(s)
                    frm.Width = frm.BackgroundImage.Width
                    frm.Height = frm.BackgroundImage.Height + 20
                    frm.Text = s
                    frm.TopMost = True
                    frm.Show()
                Else
                    frm.BackgroundImage = Image.FromFile(s)
                    frm.Width = frm.BackgroundImage.Width
                    frm.Height = frm.BackgroundImage.Height + 20
                    frm.Text = s
                    frm.TopMost = True
                    frm.Show()
                End If
            End If

        Catch ex As Exception
        End Try
    End Sub
    Private Sub cmdtriaz_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdtriaz.Click
        lstvItem.Sorting = SortOrder.Ascending
    End Sub
    Private Sub cmdtriza_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdtriza.Click
        lstvItem.Sorting = SortOrder.Descending
    End Sub
#End Region
#Region " Diaporama"
    Private Sub cmdcreer_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdcreer.Click
        '**********************************************************
        Dim ppApp As PowerPoint.Application
        Dim ppPres As PowerPoint.Presentation
        Dim ppShape As PowerPoint.Shape
        Dim ppCurrentSlide As PowerPoint.Slide
        '**********************************************************
        Dim Path_File As String
        Dim Path_Picture As String
        '**********************************************************
        Static shapePicture As PowerPoint.Shape
        '**********************************************************
        Dim lngHeight As Integer
        Dim lngWidth As Integer
        '**********************************************************
        Dim Imsg As Short
        '**********************************************************
        Dim ppt As Object
        Dim Pres As Object
        '************************************************
      
        If Textname.Text = "" Or ListBox1.Text = "" Then
            MsgBox("Vous devez mettre un titre et sélectionner les fichiers.")
            Exit Sub
        Else

            ppApp = CreateObject("PowerPoint.Application") '*** Création nouvelle présentation
            'ppApp.Visible = True                           '*** Powerpoint non visible
            ppPres = ppApp.Presentations.Add(Microsoft.Office.Core.MsoTriState.msoTrue) '*** Ajoute diapo
            ppCurrentSlide = ppPres.Slides.Add(Index:=1, Layout:=PowerPoint.PpSlideLayout.ppLayoutBlank)
            '*** Sur diapo en cours
            lngHeight = ppPres.PageSetup.SlideHeight  '*** Obtient la hauteur et la largeur de la diapositive.
            lngWidth = ppPres.PageSetup.SlideWidth

            'On sélectionne les images
            For i = 0 To ListBox1.Items.Add(-1)
                With ppPres.Slides.Item(1).Shapes '*** Insère l'image.
                    On Error Resume Next
                    '*** Ajoute le slide
                    ppCurrentSlide = ppPres.Slides.Add(Index:=1, Layout:=PowerPoint.PpSlideLayout.ppLayoutBlank)

                    'Transitions
                    ppCurrentSlide = ppPres.Slides(2)
                    'Effets Transition
                    If RadioButton8.Checked = True Then
                        ppCurrentSlide.SlideShowTransition.EntryEffect = PowerPoint.PpEntryEffect.ppEffectNone
                    ElseIf RadioButton9.Checked = True Then
                        ppCurrentSlide.SlideShowTransition.EntryEffect = PowerPoint.PpEntryEffect.ppEffectRandom
                    ElseIf RadioButton10.Checked = True Then
                        ppCurrentSlide.SlideShowTransition.EntryEffect = PowerPoint.PpEntryEffect.ppEffectFade
                    ElseIf RadioButton11.Checked = True Then
                        ppCurrentSlide.SlideShowTransition.EntryEffect = PowerPoint.PpEntryEffect.ppEffectDissolve
                    ElseIf RadioButton12.Checked = True Then
                        ppCurrentSlide.SlideShowTransition.EntryEffect = PowerPoint.PpEntryEffect.ppEffectBlindsVertical
                    ElseIf RadioButton13.Checked = True Then
                        ppCurrentSlide.SlideShowTransition.EntryEffect = PowerPoint.PpEntryEffect.ppEffectBlindsHorizontal
                    End If

                    'Vitesses Transition
                    If RadioButton6.Checked = True Then
                        ppCurrentSlide.SlideShowTransition.Speed = PowerPoint.PpTransitionSpeed.ppTransitionSpeedFast
                    ElseIf RadioButton5.Checked = True Then
                        ppCurrentSlide.SlideShowTransition.Speed = PowerPoint.PpTransitionSpeed.ppTransitionSpeedMedium
                    ElseIf RadioButton7.Checked = True Then
                        ppCurrentSlide.SlideShowTransition.Speed = PowerPoint.PpTransitionSpeed.ppTransitionSpeedSlow
                    End If
                    'Délai entre les transitions
                    ppCurrentSlide.SlideShowTransition.AdvanceOnTime = Microsoft.Office.Core.MsoTriState.msoCTrue
                    ppCurrentSlide.SlideShowTransition.AdvanceTime = ComboBox1.Text 'délai entre les transitions

                    'On met la couleur
                    ppCurrentSlide = ppPres.Slides(2) '2ème diapo

                    'Dégradés
                    If RadioButton26.Checked = True Then
                        With ppCurrentSlide.Shapes.AddShape(Microsoft.Office.Core.MsoAutoShapeType.msoShapeRectangle, _
                        0, 0, 720, 540).Fill
                            .ForeColor.RGB = RGB(Label6.Text, Label7.Text, Label8.Text) 'Sans 
                        End With
                    ElseIf RadioButton27.Checked = True Then
                        With ppCurrentSlide.Shapes.AddShape(Microsoft.Office.Core.MsoAutoShapeType.msoShapeRectangle, _
                                               0, 0, 720, 540).Fill
                            .ForeColor.RGB = RGB(Label6.Text, Label7.Text, Label8.Text)
                            .BackColor.RGB = RGB(Label11.Text, Label12.Text, Label13.Text)
                            .TwoColorGradient(Microsoft.Office.Core.MsoGradientStyle.msoGradientHorizontal, 3) ' Horizontal
                        End With
                    ElseIf RadioButton28.Checked = True Then
                        With ppCurrentSlide.Shapes.AddShape(Microsoft.Office.Core.MsoAutoShapeType.msoShapeRectangle, _
                                               0, 0, 720, 540).Fill
                            .ForeColor.RGB = RGB(Label6.Text, Label7.Text, Label8.Text)
                            .BackColor.RGB = RGB(Label11.Text, Label12.Text, Label13.Text)
                            .TwoColorGradient(Microsoft.Office.Core.MsoGradientStyle.msoGradientFromCenter, 2) ' du Centre
                        End With
                    ElseIf RadioButton29.Checked = True Then
                        With ppCurrentSlide.Shapes.AddShape(Microsoft.Office.Core.MsoAutoShapeType.msoShapeRectangle, _
                                               0, 0, 720, 540).Fill
                            .ForeColor.RGB = RGB(Label6.Text, Label7.Text, Label8.Text)
                            .BackColor.RGB = RGB(Label11.Text, Label12.Text, Label13.Text)
                            .TwoColorGradient(Microsoft.Office.Core.MsoGradientStyle.msoGradientDiagonalDown, 4) ' Diagonal
                        End With
                    End If

                    'Motifs
                    ppCurrentSlide = ppPres.Slides(2)
                    If RadioButton14.Checked = True Then
                        ppCurrentSlide.Shapes.Range.Fill.Patterned(Microsoft.Office.Core.MsoPatternType.msoPatternMixed)
                    ElseIf RadioButton15.Checked = True Then
                        ppCurrentSlide.Shapes.Range.Fill.Patterned(Microsoft.Office.Core.MsoPatternType.msoPatternDottedDiamond)
                    ElseIf RadioButton16.Checked = True Then
                        ppCurrentSlide.Shapes.Range.Fill.Patterned(Microsoft.Office.Core.MsoPatternType.msoPatternDiagonalBrick)
                    ElseIf RadioButton17.Checked = True Then
                        ppCurrentSlide.Shapes.Range.Fill.Patterned(Microsoft.Office.Core.MsoPatternType.msoPatternPlaid)
                    ElseIf RadioButton18.Checked = True Then
                        ppCurrentSlide.Shapes.Range.Fill.Patterned(Microsoft.Office.Core.MsoPatternType.msoPatternZigZag)
                    ElseIf RadioButton19.Checked = True Then
                        ppCurrentSlide.Shapes.Range.Fill.Patterned(Microsoft.Office.Core.MsoPatternType.msoPatternSphere)
                    End If
                    'Textures
                    ppCurrentSlide = ppPres.Slides(2)
                    If RadioButton20.Checked = True Then
                        ppCurrentSlide.Shapes.Range.Fill.PresetTextured(Microsoft.Office.Core.MsoPresetTexture.msoPresetTextureMixed)
                    ElseIf RadioButton21.Checked = True Then
                        ppCurrentSlide.Shapes.Range.Fill.PresetTextured(Microsoft.Office.Core.MsoPresetTexture.msoTextureGreenMarble)
                    ElseIf RadioButton22.Checked = True Then
                        ppCurrentSlide.Shapes.Range.Fill.PresetTextured(Microsoft.Office.Core.MsoPresetTexture.msoTextureWaterDroplets)
                    ElseIf RadioButton23.Checked = True Then
                        ppCurrentSlide.Shapes.Range.Fill.PresetTextured(Microsoft.Office.Core.MsoPresetTexture.msoTextureBouquet)
                    ElseIf RadioButton24.Checked = True Then
                        ppCurrentSlide.Shapes.Range.Fill.PresetTextured(Microsoft.Office.Core.MsoPresetTexture.msoTexturePapyrus)
                    ElseIf RadioButton25.Checked = True Then
                        ppCurrentSlide.Shapes.Range.Fill.PresetTextured(Microsoft.Office.Core.MsoPresetTexture.msoTextureDenim)
                    End If

                    'Sans cadre
                    If RadioButton4.Checked = True Then
                        '*** Ajoute image à la dimension désirée
                        shapePicture = .AddPicture(ListBox1.SelectedItems(i), Microsoft.Office.Core.MsoTriState.msoTrue, Microsoft.Office.Core.MsoTriState.msoTrue, 0, 0) 'sans encadrement
                        If shapePicture.Height > shapePicture.Width Then
                            'Mis à l'échelle
                            shapePicture.ScaleHeight(0.85, Microsoft.Office.Core.MsoTriState.msoCTrue) 'mode portrait
                            shapePicture.ScaleWidth(0.85, Microsoft.Office.Core.MsoTriState.msoCTrue)
                        Else
                            shapePicture.ScaleHeight(1.13, Microsoft.Office.Core.MsoTriState.msoCTrue) 'mode paysage
                            shapePicture.ScaleWidth(1.13, Microsoft.Office.Core.MsoTriState.msoCTrue)
                        End If
                        'Centrer l'image
                        With ppPres.PageSetup
                            shapePicture.Left = (.SlideWidth \ 2) - (shapePicture.Width \ 2)
                            shapePicture.Top = (.SlideHeight \ 2) - (shapePicture.Height \ 2)
                        End With

                        'Avec cadre
                    ElseIf RadioButton3.Checked = True Then
                        '*** Ajoute image à la dimension désirée
                        shapePicture = .AddPicture(ListBox1.SelectedItems(i), Microsoft.Office.Core.MsoTriState.msoTrue, Microsoft.Office.Core.MsoTriState.msoTrue, 0, 0) 'avec encadrement
                        If shapePicture.Height > shapePicture.Width Then
                            'Mis à l'échelle
                            shapePicture.ScaleHeight(0.75, Microsoft.Office.Core.MsoTriState.msoCTrue) 'mode portrait
                            shapePicture.ScaleWidth(0.75, Microsoft.Office.Core.MsoTriState.msoCTrue)
                        Else
                            shapePicture.ScaleHeight(1, Microsoft.Office.Core.MsoTriState.msoCTrue) 'mode paysage
                            shapePicture.ScaleWidth(1, Microsoft.Office.Core.MsoTriState.msoCTrue)
                        End If
                        'Centrer l'image
                        With ppPres.PageSetup
                            shapePicture.Left = (.SlideWidth \ 2) - (shapePicture.Width \ 2)
                            shapePicture.Top = (.SlideHeight \ 2) - (shapePicture.Height \ 2)
                        End With
                    End If
                End With
            Next i
          ppPres.Slides(1).Delete() 'suppression de la 1ère diapo
           
           'Texte
            ppCurrentSlide = ppPres.Slides(1)
            ppCurrentSlide.Shapes.AddShape(Microsoft.Office.Core.MsoAutoShapeType.msoShapeRectangle, 150, 200, 420, 120) _
            .TextFrame.TextRange.Text = Textname.Text 'Titre présentation

           'Sonorisation
            ppCurrentSlide = ppPres.Slides(2) '(2)démarre à la 1ère image
            If CheckBox2.Checked = True Then
                With ppCurrentSlide.SlideShowTransition
                    ppCurrentSlide.SlideShowTransition.SoundEffect.ImportFromFile(TextBoxsound.Text) 'chemin fichier son
                    .LoopSoundUntilNext = Microsoft.Office.Core.MsoTriState.msoCTrue 'en boucle jusqu'au son suivant
                End With
            Else
                ppCurrentSlide.SlideShowTransition.SoundEffect.ImportFromFile(TextBoxsound.Text) 'chemin fichier son
            End If
            ' En continu jusqu'à echap
            If CheckBox1.Checked = True Then
                With ppPres.SlideShowSettings
                    .LoopUntilStopped = Microsoft.Office.Core.MsoTriState.msoCTrue
                    .AdvanceMode = PowerPoint.PpSlideShowAdvanceMode.ppSlideShowUseSlideTimings
                End With
            End If
            If RadioButton1.Checked = True Then
                'On enregistre la présentation en ppt
                Path_File = Textfile.Text & "\" & Textname.Text & ".ppt"
                If Path_File = "" Then Exit Sub
                If Dir(Path_File) <> "" Then
                    Imsg = MsgBox("Ce fichier existe déjà. Voulez-vous le remplacer ?", MsgBoxStyle.YesNo + MsgBoxStyle.Question + MsgBoxStyle.DefaultButton2)
                    If Imsg = MsgBoxResult.Yes Then
                        Kill(Path_File) '*** Détruit existant
                    Else
                        ppApp.Quit() '*** Quitte
                        ppApp = Nothing '*** Efface de memoire
                        Exit Sub
                    End If
                End If

                ppPres.SaveAs(Path_File, PowerPoint.PpSaveAsFileType.ppSaveAsPresentation) '*** Enregistre
                ppApp.Quit() '*** Quitte
                ppApp = Nothing '*** Efface de memoire

                intReturn = MsgBox("Votre présentation: " & Textname.Text & " a été créée, voulez-vous la visionner?" & vbCrLf & "Emplacement de la présentation:  " & Path_File, MsgBoxStyle.Question + MsgBoxStyle.DefaultButton2 + MsgBoxStyle.YesNoCancel, )

                Select Case intReturn
                    Case MsgBoxResult.Yes
                        'On ouvre la présentation
                        ppt = CreateObject("PowerPoint.Application")
                        ppt.Visible = True ' Indispensable, sinon il ne peut pas ouvrir de fichier (Erreur)
                        Pres = ppt.Presentations.Open(Filename:=My.Application.Info.DirectoryPath & "\" & Textname.Text & ".ppt")
                    Case MsgBoxResult.No

                End Select

            ElseIf RadioButton2.Checked = True Then
                'On enregistre la présentation en pps
                Path_File = Textfile.Text & "\" & Textname.Text & ".pps"
                If Path_File = "" Then Exit Sub
                If Dir(Path_File) <> "" Then
                    Imsg = MsgBox("Ce fichier existe déjà. Voulez-vous le remplacer ?", MsgBoxStyle.YesNo + MsgBoxStyle.Question + MsgBoxStyle.DefaultButton2)
                    If Imsg = MsgBoxResult.Yes Then
                        Kill(Path_File) '*** Détruit existant
                    Else
                        ppApp.Quit() '*** Quitte
                        ppApp = Nothing '*** Efface de memoire
                        Exit Sub
                    End If
                End If

                ppPres.SaveAs(Path_File, PowerPoint.PpSaveAsFileType.ppSaveAsPresentation) '*** Enregistre
                ppApp.Quit() '*** Quitte
                ppApp = Nothing '*** Efface de memoire

                intReturn = MsgBox("Votre présentation: " & Textname.Text & " a été créée, voulez-vous la visionner?" & vbCrLf & "Emplacement de la présentation:  " & Path_File, MsgBoxStyle.Question + MsgBoxStyle.DefaultButton2 + MsgBoxStyle.YesNoCancel, )

                Select Case intReturn
                    Case MsgBoxResult.Yes
                        'On ouvre la présentation
                        ppt = CreateObject("PowerPoint.Application")
                        ppt.Visible = True ' Indispensable, sinon il ne peut pas ouvrir de fichier (Erreur)
                        Pres = ppt.Presentations.Open(Filename:=My.Application.Info.DirectoryPath & "\" & Textname.Text & ".pps")
                    Case MsgBoxResult.No

                End Select
            End If
        End If

    End Sub
#End Region    
#Region " Cadre et sonorisation"
    Private Sub cmdsound_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdsound.Click
        'on cherche le chemin
        Dim dlg As New OpenFileDialog
        If dlg.ShowDialog = Windows.Forms.DialogResult.OK Then
            TextBoxsound.Text = dlg.FileName
        End If
        CheckBox2.Visible = True
    End Sub
    Private Sub cmdcolor_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdcolor.Click
        Dim result As COULEUR
        CommonDialog1Color.ShowDialog()
        'A False empêche l'utilisateur de choisir une couleur personnalisée.
        CommonDialog1Color.AllowFullOpen = True
        'Permet à l'utilisateur de recevoir l'aide. (Le défaut est faux.)
        CommonDialog1Color.ShowHelp = True
        result = calcolor(System.Drawing.ColorTranslator.ToOle(CommonDialog1Color.Color))
        Label6.Text = result.red
        Label7.Text = result.green
        Label8.Text = result.blue
        cmdcolor.BackColor = CommonDialog1Color.Color
        RadioButton20.Checked = True
    End Sub
    Private Sub cmddegrade_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmddegrade.Click
        Dim result As COULEUR
        CommonDialog1Color.ShowDialog()
        'A False empêche l'utilisateur de choisir une couleur personnalisée.
        CommonDialog1Color.AllowFullOpen = True
        'Permet à l'utilisateur de recevoir l'aide. (Le défaut est faux.)
        CommonDialog1Color.ShowHelp = True
        result = calcolor(System.Drawing.ColorTranslator.ToOle(CommonDialog1Color.Color))
        Label11.Text = result.red
        Label12.Text = result.green
        Label13.Text = result.blue
        cmddegrade.BackColor = CommonDialog1Color.Color
        RadioButton20.Checked = True
    End Sub
    Private Sub RadioButton26_CheckedChanged(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles RadioButton26.CheckedChanged
        cmddegrade.Visible = False
    End Sub
    Private Sub RadioButton27_CheckedChanged(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles RadioButton27.CheckedChanged
        cmddegrade.Visible = True
    End Sub
    Private Sub RadioButton28_CheckedChanged(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles RadioButton28.CheckedChanged
        cmddegrade.Visible = True
    End Sub
    Private Sub RadioButton29_CheckedChanged(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles RadioButton29.CheckedChanged
        cmddegrade.Visible = True
    End Sub
    Private Function calcolor(ByVal col As Integer) As COULEUR
        Dim cl As Object
        Dim coul As COULEUR 'Type personnalisé
        If col < 256 Then 'Ne possède que du rouge
            coul.red = col
            coul.green = 0
            coul.blue = 0
        ElseIf col < 65536 Then  'Rouge + Vert
            coul.red = col Mod 256
            coul.green = col \ 256
            coul.blue = 0
        Else 'Rouge + Vert + Bleu
            coul.blue = col \ 65536
            cl = col Mod 65536
            coul.red = cl Mod 256
            coul.green = cl \ 256
        End If
        calcolor = coul
    End Function
#End Region
#Region " Aide et fermeture"
    Private Sub btnhelp_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnhelp.Click
        Aide.Show()
    End Sub
    Private Sub cmdQuit_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdQuit.Click
        End
    End Sub
 
#End Region

   
    
   
End Class

Télécharger le zip

01 décembre 2008 09:23:17 :

La source ne s'est pas enregistrée

01 décembre 2008 09:33:59 :

erreur de frappe PPT au lieu de PTT

02 décembre 2008 18:52:38 :

J'ai inversé la liste des fichiers pour que les images soient dans le bon ordre dans la présentation.Avec l'aide de "jmfmarques "que je remercie, dans une question sur le forum.

04 décembre 2008 17:12:48 :

Monter et descendre les fichiers dans la listBox, mais n'oubliez pas que la liste est inversée.Cela sera peut-être utile car je n'ai pas trouver de code en VB2005 sur Up Down dans une listBox.

05 décembre 2008 08:17:14 :

Vous pouvez supprimer les fichiers non désirés, ce qui évite d'avoir des diapos vierges.Mais vous devez ensuite tout sélectionner.

05 décembre 2008 15:25:24 :

Petite erreur, le cmddown ne se mettait pas False quand on cliquez sur le dernier fichier.

26 février 2009 12:33:22 :

Cadre de couleur avec motifs et textures Ajout des options Transitions:Effets, vitesses et délai

03 mars 2009 18:19:08 :

Mise à l'échelle et centrage de l'image en mode portrait. Option: Diapo en continu jusqu'à échap.

11 mars 2009 17:42:32 :

Ajout de couleur en mode portrait dans la version sans cadre.Dégradé de couleurs que vous choisissez.Son en boucle jusqu'au prochain son.