Creer diaporama ppt
Description
Créer un diaporama sur PowerPoint.Vous ouvrez un dossier images, vous sélectionnez les images,vous pouvez supprimer, monter ou descendre les fichiers.Cadre de couleur autour des images avec dégradé de couleurs, motifs et textures.Options Transitions: Effets, vitesse et délai.Diapo en continu jusquà échap, Son en boucle jusqu'au prochain son. Vous mettez le titre de la présentation, vous choisissez l'extension d'enregistrement et vous cliquez sur "Creer Diaporama". Un message vous indique l'emplacement de votre présentation (dossier source). Prendre connaissance de l'aide avant de démarrer le programme.
Merci à molo molo pour sa source:
http://www.vbfrance.com/code.aspx?ID=38374
Merci à Schlangan pour son code couleur RGB
http://vbfrance.com/code.aspx?ID=31374
Source / Exemple :
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
Conclusion :
Merci à molo molo pour sa source:
http://www.vbfrance.com/code.aspx?ID=38374
Merci à Schlangan pour son code couleur RGB
http://vbfrance.com/code.aspx?ID=31374
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.