CONVERTIR *.ICO --->BMP .VISUALISEUR ET TEXTE DÉROULANT

'"""""""""""""""""""""""""""""""""""""""""""""""""
'"  http://www.chez.com/pitrack1                 "
'"  pitrack1@club-internet.fr                    "
'"  Source crée avec visual basic 5.0            "
'"""""""""""""""""""""""""""""""""""""""""""""""""

Private Sub Command1_Click()
  'Fin du programme
  M$ = "Voulez-vous vraiment quitter le programme de conversion ?"
  Réponse% = MsgBox(M$, vbYesNo + vbQuestion, "Quitter le programme")
  If Réponse% = vbYes Then
    End
  End If
End Sub

Private Sub Command2_Click()
  'Les erreurs sont ignorées
  On Error Resume Next
  'Fichier(s) sélectionné(s) ?
  For X% = 0 To File1.ListCount - 1
    'Mention active sélectionnée ?
    If File1.Selected(X%) Then
      'Par exemple c:iconesitmap	oto.ico
      Fichier$ = Dir1.Path + "" + File1.List(X%)
      'Charger icône
      Image1.Picture = LoadPicture(Fichier$)
      Picture1.Picture = LoadPicture(Fichier$)
      If Option1.Value = True Then
          'Nom défini automatiquement par remplacement de l'extension
          'Pas de changement de localisation!
          Fichier$ = Left$(Fichier$, Len(Fichier$) - 3) + "bmp"
          SavePicture Picture1.Image, Fichier$
        ElseIf Option2.Value = True Then
          'Affectation manuelle du nom de fichier
          'Chemin d'accès personnalisé!
          If Val(Text2.Text) <> 0 Then
              'Pas de 0 dans les noms de fichier
              Fichier$ = Text3.Text + Text1.Text + Text2.Text + ".bmp"
            Else
              'Incrément
              Fichier$ = Text3.Text + Text1.Text + ".bmp"
          End If
          'Enregistrer l'icône en Bitmap
          SavePicture Picture1.Image, Fichier$
          'Augmenter compteur
          Nr% = Val(Text2.Text) + 1
          'Noter nouvelle valeur dans la zone de texte
          Text2.Text = Trim$(Str$(Nr%))
      End If
    End If
  Next X%
End Sub

Private Sub Command3_Click()
'Ouvre la visionneuse
 FormDia.Show vbModal
End Sub

Private Sub Command4_Click()
'Ouvre la boite de dialogue Enregistrer
On Error GoTo TraiteErreur
     Dim Source As String
     Dim Cible As String
     Source = File1.Path
     If Right(Source, 1) <> "" Then Source = Source & ""
     Source = Source & File1.filename
     Dialog.Flags = 2
     Dialog.ShowSave
     Cible = Dialog.filename
     FileCopy Source, Cible
     File1.Refresh
     Exit Sub
TraiteErreur:
     If Err.Number = 32755 Then Exit Sub
     MsgBox Err.Description, 16, "Erreur !"
End Sub

Private Sub Command5_Click()
'Supprime l'image définitivement
On Error GoTo TraiteErreur
    ChDrive Drive1.Drive
    ChDir File1.Path
    Kill (File1.filename)
    File1.Refresh
    Exit Sub
TraiteErreur:
    MsgBox Err.Description, 16, "Erreur !"
End Sub

Private Sub Dir1_Change()
'Chemin du disque
  File1.Path = Dir1.Path
End Sub

Private Sub Drive1_Change()
'Chemin du répertoire
  On Error Resume Next
  Dir1.Path = Drive1.Drive
End Sub

Private Sub File1_Click()
  If File1.filename <> "" Then
    Fichier$ = Dir1.Path + "" + File1.filename
    'Charger l'icône
    Image1.Picture = LoadPicture(Fichier$)
    Picture1.Picture = LoadPicture(Fichier$)
    
    Fichier$ = Path$ + File1.filename
  Label4 = "Aperçu de :" + File1.filename
   End If
     End Sub

Private Sub Form_Load()
  'Chemin de destination = Chemin du programme
  Chemin$ = App.Path
  If Right$(Chemin$, 1) <> "" Then
    Chemin$ = Chemin$ + ""
  End If
  Text3.Text = Chemin$
End Sub

Private Sub mnuapro_Click()
frmDeroule.Show
End Sub

Private Sub mnuenregistre_Click()
'Ouvre la boite de dialogue Enregistrer
On Error GoTo TraiteErreur
     Dim Source As String
     Dim Cible As String
     Source = File1.Path
     If Right(Source, 1) <> "" Then Source = Source & ""
     Source = Source & File1.filename
     Dialog.Flags = 2
     Dialog.ShowSave
     Cible = Dialog.filename
     FileCopy Source, Cible
     File1.Refresh
     Exit Sub
TraiteErreur:
     If Err.Number = 32755 Then Exit Sub
     MsgBox Err.Description, 16, "Erreur !"
End Sub

Private Sub mnuquitte_Click()
 'Fin du programme
  M$ = "Voulez-vous vraiment quitter le programme de conversion et de Visualisation?"
  Réponse% = MsgBox(M$, vbYesNo + vbQuestion, "Quitter le programme")
  If Réponse% = vbYes Then
    End
  End If
End Sub

Private Sub mnusauve_Click()
  'Les erreurs sont ignorées
  On Error Resume Next
  'Fichier(s) sélectionné(s) ?
  For X% = 0 To File1.ListCount - 1
    'Mention active sélectionnée ?
    If File1.Selected(X%) Then
      'Par exemple c:iconesitmap	oto.ico
      Fichier$ = Dir1.Path + "" + File1.List(X%)
      'Charger icône
      Image1.Picture = LoadPicture(Fichier$)
      Picture1.Picture = LoadPicture(Fichier$)
      If Option1.Value = True Then
          'Nom défini automatiquement par remplacement de l'extension
          'Pas de changement de localisation!
          Fichier$ = Left$(Fichier$, Len(Fichier$) - 3) + "bmp"
          SavePicture Picture1.Image, Fichier$
        ElseIf Option2.Value = True Then
          'Affectation manuelle du nom de fichier
          'Chemin d'accès personnalisé!
          If Val(Text2.Text) <> 0 Then
              'Pas de 0 dans les noms de fichier
              Fichier$ = Text3.Text + Text1.Text + Text2.Text + ".bmp"
            Else
              'Incrément
              Fichier$ = Text3.Text + Text1.Text + ".bmp"
          End If
          'Enregistrer l'icône en Bitmap
          SavePicture Picture1.Image, Fichier$
          'Augmenter compteur
          Nr% = Val(Text2.Text) + 1
          'Noter nouvelle valeur dans la zone de texte
          Text2.Text = Trim$(Str$(Nr%))
      End If
    End If
  Next X%
End Sub

Private Sub mnusupprime_Click()
'Supprime l'image définitivement
On Error GoTo TraiteErreur
    ChDrive Drive1.Drive
    ChDir File1.Path
    Kill (File1.filename)
    File1.Refresh
    Exit Sub
TraiteErreur:
    MsgBox Err.Description, 16, "Erreur !"
End Sub

Private Sub mnuvisionne_Click()
'Ouvre la visionneuse
 FormDia.Show vbModal
End Sub

Private Sub opPattern_Click(Index As Integer)
  Select Case Index
    Case 0
      'Affichage des fichiers d'icônes
      File1.Pattern = "*.ico"
      'Conversion possible
      Command2.Enabled = True
      mnusauve.Enabled = True
    Case 1
      'Affichage de fichiers Bitmaps
      File1.Pattern = "*.bmp"
      'Verrouiller la conversion puisque déja en *.bmp
      Command2.Enabled = False
      mnusauve.Enabled = False
   Case 2
      'Affichage des fichiers jpeg
      File1.Pattern = "*.jpg"
      'Verrouiller la conversion
      Command2.Enabled = False
      mnusauve.Enabled = False
   Case 3
      'Affichage des fichiers Gif
      File1.Pattern = "*.Gif"
      'Verrouiller la conversion
      Command2.Enabled = False
      mnusauve.Enabled = False
  End Select
End Sub



Private Sub Text2_KeyPress(KeyAscii As Integer)
  'N'accepter que des chiffres entre 0 et 9
  Permis$ = "0123456789"
  'Toujours autoriser RETOUR ARR.
  Permis$ = Permis$ + Chr$(8)
  If InStr(Permis$, Chr$(KeyAscii)) = 0 Then
    KeyAscii = 0
  End If
End Sub

Private Sub File1_PathChange()
' Affiche le chemin d'accès dans le contrôle Label.
    Label5.Caption = Dir1.Path
    End Sub

-------------------------------------------
Option Explicit
Private Sub Form_Load()
    Dim Fichier As String
    Fichier = Form1.File1.Path
    If Right(Fichier, 1) <> "" Then Fichier = Fichier & ""
    Fichier = Fichier & Form1.File1.filename
    ImageDia.Picture = LoadPicture(Fichier)
    ImageDia.Top = (Screen.Height - ImageDia.Height) / 2
    ImageDia.Left = (Screen.Width - ImageDia.Width) / 2
     
End Sub

Private Sub ImageDia_DblClick()
    Unload Me
End Sub

Private Sub ImageDia_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    On Error Resume Next
    Dim Fichier As String
    Fichier = Form1.File1.Path
    If Right(Fichier, 1) <> "" Then Fichier = Fichier & ""
    Select Case Button
        Case 1
            Form1.File1.ListIndex = Form1.File1.ListIndex - 1
        Case 2
            Form1.File1.ListIndex = Form1.File1.ListIndex + 1
    End Select
    Fichier = Fichier & Form1.File1.filename
    ImageDia.Picture = LoadPicture(Fichier)
    ImageDia.Top = (Screen.Height - ImageDia.Height) / 2
    ImageDia.Left = (Screen.Width - ImageDia.Width) / 2

End Sub
Private Sub Timer1_Timer()
    Dim Fichier As String
    Fichier = Form1.File1.Path
    If Right(Fichier, 1) <> "" Then Fichier = Fichier & ""
    If Form1.File1.ListIndex = Form1.File1.ListCount - 1 Then
        Unload Me
        Exit Sub
    End If
    Form1.File1.ListIndex = Form1.File1.ListIndex + 1
    Fichier = Fichier & Form1.File1.filename
    ImageDia.Picture = LoadPicture(Fichier)
    ImageDia.Top = (Screen.Height - ImageDia.Height) / 2
    ImageDia.Left = (Screen.Width - ImageDia.Width) / 2
    'Lecture du nom de fichier
    Label2 = "" & Form1.File1.filename
End Sub

--------------------------------------------
Private Sub Ferme()
   Unload frmDeroule
End Sub

Private Sub Form_Click()
   Ferme
End Sub

Private Sub Form_Load()
   lblNomLicence = NomUtilisateur
End Sub

'
Private Sub imgImage_Click()
   Ferme
End Sub
'
Private Sub lblLicence_Click()
   Ferme
End Sub

'
Private Sub lblNom_Click()
   Ferme
End Sub

Private Sub lblNomLicence_Click()
   Ferme
End Sub

'
Private Sub lblTitre_Click()
   Ferme
End Sub
'
Private Sub lblVersion_Click()
   Ferme
End Sub
'
Private Sub picTexte_Click()
   Ferme
End Sub
'
Private Sub tmrTexte_Timer()
   If picTexte.Top > -5775 Then
      picTexte.Top = picTexte.Top - 30  ' vitesse de déroulement -100 + rapide; -30 + lent
   Else
      picTexte.Top = 0  ' on recommence
   End If
End Sub
'
Private Sub tmrDepart_Timer()
   tmrTexte.Enabled = True  ' départ du timer qui déclenchera le timer Texte
End Sub
 

Télécharger le zip