Gadget diaporama

Soyez le premier à donner votre avis sur cette source.

Vue 9 291 fois - Téléchargée 610 fois

Description

Pour ceux qui n'ont pas Vista, voici le programme qu'il vous faut! Un "Gadget" qui se place en haut à gauche de votre écran. Diaporama en boucle de vos fichiers images,réglage des intervalles entre les images.Playlist musicale des fichiers sons: MP3,WMA et Wav. Quand tous les réglages sont fait vous pouvez "Minimiser" pour n'avoir que l'image. Deplacement par drag and drop. Option de transparence de l'arrière plan. Possibilité de défilement manuel et d'agrandissement de l'image.Medley musicale de 1, 2 ou 3 minutes.Le Diapo et le Medley peut se faire d'une façon aléatoire.

Source / Exemple :


Option Strict Off
Option Explicit On
Imports Microsoft.Win32
Imports System.IO
Imports System.Drawing.Imaging
Public Class Form1
    Inherits System.Windows.Forms.Form
    'Déplacez le form.
    Private myFormDragging As Boolean = False
    Private myPointClicked As Point
     'Lancer au démarrage
    Private o_ClefRegistre As RegistryKey = Registry.CurrentUser.OpenSubKey("Software\Microsoft\Windows\CurrentVersion\Run", True)
    Private o_CR As Object = o_ClefRegistre.GetValue("Gadget_Diaporama")
    Private Const CS_NOCLOSE As Integer = &H200
    ' ouvrir dans programme par défaut
    Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Integer, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Integer) As Integer
    Dim fichier As String
#Region "Ouverture"
    Private Sub cmdopen_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdopen.Click
        Dim a As New FolderBrowserDialog
        Textsource.Text = "" 'effacement du chemin
        FileListBox1.Items.Clear() 'effacement de la liste 
        'On arrête le diapo
        tmrImage.Enabled = False
        tmrImage.Stop()
        cmdstart.Text = "&Start"
        If a.ShowDialog = Windows.Forms.DialogResult.OK Then
            On Error Resume Next
            Textsource.Text = "" & a.SelectedPath & "\"
            FileListBox1.Pattern = ComboBox1.Text
            FileListBox1.Path = Textsource.Text
        End If
        If Textsource.Text = "" Then Exit Sub
        FileListBox1.SelectedIndex = 0 'on sélectionne la 1ère image
        LblImage.Text = FileListBox1.Items.Count 'on compte les fichiers
        afficher_image()
    End Sub
    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
        ComboBox1.Text = "*.jpg"
        ComboBox2.Text = "*.mp3"
        RadioButton4.Checked = True
        RadioButton7.Checked = True
        'Check si la clef de registre "Gadget_Diaporama" existe dans le run
        ToolStripMenuItemdemarrage.Checked = (o_CR IsNot Nothing)
        'on empêche le formulaire principal d'aller dans la barre de tâche
        Me.Hide()
        NotifyIcon1.Visible = True
    End Sub
    ' Ouvrir programme par défaut 
    Public Function OpenFile(ByRef File As String, Optional ByRef Parametres As String = "") As Object
        ShellExecute(Handle.ToInt32, "Open", File, Parametres, My.Application.Info.DirectoryPath, 1)
        OpenFile = 1
    End Function
    Private Sub PictureBox1_DoubleClick(ByVal sender As Object, ByVal e As System.EventArgs) Handles PictureBox1.DoubleClick
        If Textsource.Text = "" Then
            MsgBox("Il n'y a pas d'image!")
            Exit Sub
        End If
        fichier = Textsource.Text & FileListBox1.Text
        Try
            'Ouvre le fichier dans son programme par défaut
            OpenFile(fichier)
        Catch ex As Exception
        End Try
    End Sub
#End Region
#Region "Diapo et Medley"
    'images
    Private Sub tmrImage_Tick(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles tmrImage.Tick
        On Error Resume Next
        cmdstart.Enabled = True
        If RadioButton1.Checked = True Then
            tmrImage.Interval = 2000 '2 secondes
        ElseIf RadioButton2.Checked = True Then
            tmrImage.Interval = 3000
        ElseIf RadioButton3.Checked = True Then
            tmrImage.Interval = 4000
        ElseIf RadioButton4.Checked = True Then
            tmrImage.Interval = 5000
        ElseIf RadioButton5.Checked = True Then
            tmrImage.Interval = 6000
        ElseIf RadioButton6.Checked = True Then
            tmrImage.Interval = 7000
        End If
        'Mode Aléatoire
        Dim i As Integer = LblImage.Text 'nombre de fichiers
        If CheckBox1.Checked = True Then
            Randomize()
            i = (LblImage.Text * Rnd() + 1) 'choix du fichier au hazard
            FileListBox1.SelectedIndex = (i) 'on sélectionne le fichier
        Else
            'Mode normal
            CheckBox1.Checked = False
            Dim int As Integer = FileListBox1.SelectedIndex
            If FileListBox1.SelectedItems.Count = 0 Then Exit Sub
            int = FileListBox1.SelectedIndex + 1
            Dim item As String = FileListBox1.SelectedItem
            If FileListBox1.SelectedIndex = "" Then 'après la dernière image
                FileListBox1.SetSelected(int, False)
                FileListBox1.SelectedIndex = 0 'on redemarre à la 1ère image
                FileListBox1.SetSelected(int, True)
            End If
        End If
        afficher_image()
    End Sub
    Private Sub cmdstart_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdstart.Click
        'On démarre le diapo
        If tmrImage.Enabled = True Then
            cmdstart.Text = "&Start"
            tmrImage.Stop()
        Else
            cmdstart.Text = "&Stop"
            tmrImage.Start()
        End If
    End Sub
    Private Sub afficher_image()
        PictureBox1.Image = New System.Drawing.Bitmap(Textsource.Text & FileListBox1.Text)
        PictureBox1.SizeMode = PictureBoxSizeMode.Zoom
    End Sub
    'Sons
    Private Sub Timer_Medley_Tick(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Timer_Medley.Tick
        On Error Resume Next
        Timer_Medley.Enabled = True
        If RadioButton7.Checked = True Then
            Timer_Medley.Interval = 60000 '1 minute
        ElseIf RadioButton8.Checked = True Then
            Timer_Medley.Interval = 120000
        ElseIf RadioButton9.Checked = True Then
            Timer_Medley.Interval = 180000
        End If
        'Mode Aléatoire
        Dim i As Integer = LblSon.Text 'nombre de fichiers
        If CheckBox2.Checked = True Then
            Randomize()
            i = (LblSon.Text * Rnd() + 1) 'choix du fichier au hazard
            FileListBox2.SelectedIndex = (i) 'on sélectionne le fichier
        Else
            'Mode normal
            CheckBox2.Checked = False
            Dim int As Integer = FileListBox2.SelectedIndex
            If FileListBox2.SelectedItems.Count = 0 Then Exit Sub
            int = FileListBox2.SelectedIndex + 1
            Dim item As String = FileListBox2.SelectedItem
            If FileListBox2.SelectedIndex = "" Then 'après le dernier fichier
                FileListBox2.SetSelected(int, False)
                FileListBox2.SelectedIndex = 0 'on redemarre au 1er fichier
                FileListBox2.SetSelected(int, True)
            End If
        End If
        'Joue le son
        jouer_son()
        Call Open()
        Call Play()
    End Sub
    Private Sub cmdmedley_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdmedley.Click
        'On démarre le medley
        If Timer_Medley.Enabled = True Then
            cmdmedley.Text = "&Medley"
            Timer_Medley.Stop()
        Else
            cmdmedley.Text = "&Stop"
            Timer_Medley.Start()
        End If
    End Sub
#End Region
#Region "FileListBox et ComboBox"
    Private Sub ComboBox1_SelectedIndexChanged(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles ComboBox1.SelectedIndexChanged
        On Error Resume Next
        FileListBox1.Pattern = ComboBox1.Text
    End Sub
    Private Sub ComboBox2_SelectedIndexChanged(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles ComboBox2.SelectedIndexChanged
        On Error Resume Next
        FileListBox2.Pattern = ComboBox2.Text
    End Sub
    Private Sub FileListBox1_SelectedIndexChanged(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles FileListBox1.SelectedIndexChanged
        If FileListBox1.SelectedIndex <> -1 Then
            'Ça ne sert à rien de vouloir monter si l'entrée est déjà tout en haut.
            If FileListBox1.SelectedIndex > 0 Then cmdUp.Enabled = True Else cmdUp.Enabled = False
            'Idem, inutile de vouloir descendre si on est déjà tout en bas.
            If FileListBox1.SelectedIndex < FileListBox1.Items.Count - 1 Then cmdDown.Enabled = True Else cmdDown.Enabled = False
        End If
    End Sub
    Private Sub FileListBox2_Click(ByVal sender As Object, ByVal e As System.EventArgs) Handles FileListBox2.Click
        If FileListBox2.Text = "" Then
            MsgBox("Il n'y a pas de fichier!")
            Exit Sub
        End If
        jouer_son()
        Call Open()
        Call Play()
        Timer_Medley.Enabled = True
    End Sub
    Private Sub FileListBox2_SelectedIndexChanged(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles FileListBox2.SelectedIndexChanged
        If FileListBox2.SelectedIndex <> -1 Then
            'Ça ne sert à rien de vouloir monter si l'entrée est déjà tout en haut.
            If FileListBox2.SelectedIndex > 0 Then cmdmonter.Enabled = True Else cmdmonter.Enabled = False
            'Idem, inutile de vouloir descendre si on est déjà tout en bas.
            If FileListBox2.SelectedIndex < FileListBox2.Items.Count - 1 Then cmddescendre.Enabled = True Else cmddescendre.Enabled = False
        End If
    End Sub
#End Region
#Region "UP and Down image et son"
    'image
    Private Sub cmdUp_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdUp.Click
        Dim int As Integer = FileListBox1.SelectedIndex
        If FileListBox1.SelectedItems.Count = 0 Then Exit Sub
        int = FileListBox1.SelectedIndex - 1
        Dim item As String = FileListBox1.SelectedItem
        FileListBox1.SetSelected(int, True)
        afficher_image()
    End Sub
    'image
    Private Sub cmdDown_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdDown.Click
        Dim int As Integer = FileListBox1.SelectedIndex
        If FileListBox1.SelectedItems.Count = 0 Then Exit Sub
        int = FileListBox1.SelectedIndex + 1
        Dim item As String = FileListBox1.SelectedItem
        FileListBox1.SetSelected(int, True)
        afficher_image()
    End Sub
    'son
    Private Sub cmdmonter_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdmonter.Click
        Dim int As Integer = FileListBox2.SelectedIndex
        If FileListBox2.SelectedItems.Count = 0 Then Exit Sub
        int = FileListBox2.SelectedIndex - 1
        Dim item As String = FileListBox2.SelectedItem
        FileListBox2.SetSelected(int, True)
        'Joue le son
        jouer_son()
        Call Open()
        Call Play()
    End Sub
    'son
    Private Sub cmddescendre_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmddescendre.Click
        Dim int As Integer = FileListBox2.SelectedIndex
        If FileListBox2.SelectedItems.Count = 0 Then Exit Sub
        int = FileListBox2.SelectedIndex + 1
        Dim item As String = FileListBox2.SelectedItem
        FileListBox2.SetSelected(int, True)
        'Joue le son
        jouer_son()
        Call Open()
        Call Play()
    End Sub
#End Region
#Region "Son"
    Private Sub cmdson_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdson.Click
        Dim b As New FolderBrowserDialog
        On Error GoTo erropen
        If bPlaying Then
            Call Pause()
            Timer_Medley.Enabled = False
            Timer_Medley.Stop()
            cmdmedley.Text = "&Medley"
        End If
        T_Chemin.Text = "" 'effacement du chemin
        FileListBox2.Items.Clear() 'effacement de la liste 
        If b.ShowDialog = Windows.Forms.DialogResult.OK Then
            On Error Resume Next
            T_Chemin.Text = "" & b.SelectedPath & "\"
            FileListBox2.Pattern = ComboBox2.Text
            FileListBox2.Path = T_Chemin.Text
        End If
        If T_Chemin.Text = "" Then Exit Sub
        FileListBox2.SelectedIndex = 0 'on sélectionne le 1er fichier
        LblSon.Text = FileListBox2.Items.Count 'on compte les fichiers
        jouer_son()
        Call Open()
        Call Play()

erropen:
    End Sub
    Private Sub jouer_son()
        Call Pause()
        strFileToPlay = T_Chemin.Text & FileListBox2.SelectedItem
        strFileToPlay = """" & strFileToPlay & """"
    End Sub
    Private Sub cmdstopmusic_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdstopmusic.Click
        'Arrete la lecture du son
        Call Pause()
        Timer_Medley.Enabled = False
        Timer_Medley.Stop()
        cmdmedley.Text = "&Medley"
    End Sub
#End Region
#Region "Drag Drop"
    Private Sub Form1_MouseDown(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles Me.MouseDown
        myFormDragging = True
        myPointClicked = New Point(e.X, e.Y)
    End Sub
    Private Sub Form1_MouseMove(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles Me.MouseMove
        If myFormDragging Then
            Dim aMoveToPoint As Point
            'Utilisez la position de souris actuelle pour trouver l'endroit prévu.
            aMoveToPoint = Me.PointToScreen(New Point(e.X, e.Y))
            'Réglez la position basée sur où vous avez commencé.
            aMoveToPoint.Offset(myPointClicked.X * -1, _
                (myPointClicked.Y + SystemInformation.CaptionHeight + _
               SystemInformation.BorderSize.Height) * -1)
            'Déplacez le form.
            Me.Location = aMoveToPoint
        End If
    End Sub
    Private Sub Form1_MouseUp(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles Me.MouseUp
        myFormDragging = False
    End Sub
#End Region
#Region "Lancer au démarrage"
    Private Sub ToolStripMenuItemopen_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles ToolStripMenuItemopen.Click
        Me.Show()
    End Sub
    Private Sub ToolStripMenuItemclose_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles ToolStripMenuItemclose.Click
        ' on enlève l'icône de la zone de notification
        NotifyIcon1.Visible = False
        'On arrête le diapo
        tmrImage.Enabled = False
        tmrImage.Stop()
        'On arrête le son
        Call Pause()
        Timer_Medley.Stop()
        Timer_Medley.Enabled = False
        End
    End Sub
    Private Sub ToolStripMenuItemdemarrage_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles ToolStripMenuItemdemarrage.Click
        If ToolStripMenuItemdemarrage.Checked Then
            ToolStripMenuItemdemarrage.Checked = False
            If o_CR IsNot Nothing Then
                o_ClefRegistre.DeleteValue("Gadget_Diaporama")
                o_CR = Nothing
            End If
        Else
            o_ClefRegistre.SetValue("Gadget_Diaporama", My.Application.Info.DirectoryPath & "\Gadget_Diaporama.exe")
            o_CR = o_ClefRegistre.GetValue("Gadget_Diaporama")
            ToolStripMenuItemdemarrage.Checked = True
        End If
    End Sub
#End Region
#Region "Minimiser, Transparence et Quitter"
    Private Sub cmdminimiser_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdminimiser.Click
        If cmdminimiser.Text = "2" Then
            cmdminimiser.Text = "1"
            Me.Width = 160
            Me.Height = 160
        Else
            cmdminimiser.Text = "2"
            Me.Width = 350
            Me.Height = 300
        End If
    End Sub
    Private Sub cmdquitter_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdquitter.Click
        'On arrête le diapo
        tmrImage.Enabled = False
        tmrImage.Stop()
        cmdstart.Text = "&Start"
        'On arrête le son
        Call Pause()
        Timer_Medley.Enabled = False
        Timer_Medley.Stop()
        cmdmedley.Text = "&Medley"
        Me.Hide()
    End Sub
    Private Sub cmdtransparence_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdtransparence.Click
        If PictureBox1.BackColor = Color.Gainsboro Then
            cmdtransparence.Text = "&Opacité"
            PictureBox1.BackColor = Color.Yellow
        Else
            cmdtransparence.Text = "&Transparence"
            PictureBox1.BackColor = Color.Gainsboro
        End If
    End Sub
#End Region

    
End Class

Conclusion :


Je remercie: http://frederic.sigonneau.free.fr/
pour ses modules en VBA Excel
Le code du lancer au démarrage de Windows est de Kyliox que je remercie.

Codes Sources

A voir également

Ajouter un commentaire

Commentaires

cs_Le Pivert
Messages postés
6155
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
14 août 2019
83 -
Un oubli:
On ferme l'userForm avec un double clic sur l'image
@+ Le Pivert
athol89
Messages postés
9
Date d'inscription
mardi 20 mai 2008
Statut
Membre
Dernière intervention
16 mai 2009
-
Bonjour,

Voilà je voudrais créer un gadget qui ressemblerait à celui-ci.
Les seules différences sont que je voudrais afficher des informations contenus dans mon fichier excel à la place des photos et je voudrais que ce gadget se lance lorsque je réduis m'ont fichier excel. Donc je voudrais savoir ce qu'il faut m'odifier dans votre code pour arriver à faire celà (en sachant que je débute en vba).

J'espère que c'est ici que je peux poser mes questions? Sinon dites moi où le faire.
Merci d'avance
cs_Le Pivert
Messages postés
6155
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
14 août 2019
83 -
Bonjour,
Mettre dans un UserForm un Bouton avec ce code:
Private Sub CommandButton1_Click()
Application.Visible = True 'rendre Excel visible
End
End Sub
Mettre la propriété de l'UserForm: ShowModal:False
Mettre dans ThisWorkbook le code:
Option Explicit
Private Sub Workbook_Open()
UserForm1.Show
Application.Visible = False 'rendre Excel invisible
End Sub
Pour comprendre VBA Excel voir le site cité plus haut ainsi que
http://ftp-developpez.com/silkyroad/VBA/ ,il y en a de nombreux sur le Web.
PS: pour les questions il y a le Forum.
J'espère avoir répondu aux questions
@+ Le Pivert
athol89
Messages postés
9
Date d'inscription
mardi 20 mai 2008
Statut
Membre
Dernière intervention
16 mai 2009
-
Merci beaucoupr toutes ces informations et pour avoir pris le temps de m'avoir répondu je vais essayer sa tout de suite.

Merci encore
cs_Le Pivert
Messages postés
6155
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
14 août 2019
83 -
J'ai oublié de notifier qu'il faut empêcher l'utilisateur de se servir de la croix de fermeture, sinon Excel ne redeviendra pas visible.
@+ 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.