Extraction d'icônes

Télécharger le projet
Commenter

Description

Petite source sans grande prétention mais qui sera l'une des feuilles de la version bêta de mon créateur d'icône (Nouvelle Icône dont les sources sont disponibles sur ce site dans sa version alpha).

Cette source vous permet d'extraire n'importe quelle icône de n'importe quel fichier (en tout cas, je pense pas qu'une icône lui échappe, mais ca reste possible tout de même ;op)

Dans ce programme, j'utilise des ocx de yomm (que je remercie au passage pour ces superbes contrôles !) pour explorer les disques tout en affichant les icônes.
Ensuite, tout le code est de moi pour tout ce qui est extraction des icônes et affichage dans un ListView.
Comme je l'ai déjà dit, cette source toute seule ne sert pas à grand chose, mais peut-être très pratique pour un éditeur d'icônes par exemple, d'où cette publication.

Le code est abondament commenté, comme à mon habitude, et je pense qu'il est à la portée de tous.

Source / Exemple : 


'==============================================================================================
'UN GRAND MERCI A YOMM POUR CES OCX D'EXPLORATEUR DE FICHIER AVEC ICONES.
'==============================================================================================

'Déclaration des APIs de la feuille
'fonction permettant l'extraction des icônes d'un fichier
Private Declare Function ExtractIconEx Lib "shell32.dll" Alias "ExtractIconExA" ( _
ByVal lpszFile As String, _
ByVal nIconIndex As Long, _
phiconLarge As Long, _
phiconSmall As Long, _
ByVal nIcons As Long) As Long

'fonction permettant l'extraction des icônes d'un fichier
Private Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" ( _
ByVal hInst As Long, _
ByVal lpszExeFileName As String, _
ByVal nIconIndex As Long) As Long

'fonction permettant d'afficher une icône extraite d'un fichier
Private Declare Function DrawIcon Lib "user32" ( _
ByVal hdc As Long, _
ByVal X As Long, _
ByVal Y As Long, _
ByVal hIcon As Long) As Long

'fonction permettant de détruire une icône stockée en mémoire
Private Declare Function DestroyIcon Lib "user32" ( _
ByVal hIcon As Long) As Long

'fonction permettant d'afficher l'icône extraite d'un fichier
Private Declare Function DrawIconEx Lib "user32" ( _
ByVal hdc As Long, _
ByVal xLeft As Long, _
ByVal yTop As Long, _
ByVal hIcon As Long, _
ByVal cxWidth As Long, _
ByVal cyWidth As Long, _
ByVal istepIfAniCur As Long, _
ByVal hbrFlickerFreeDraw As Long, _
ByVal diFlags As Long) As Long

'fonction permettant d'extraire l'icône associée aux fichiers courants de Windows (.doc, .txt, etc)
Private Declare Function ExtractAssociatedIcon Lib "shell32.dll" Alias "ExtractAssociatedIconA" ( _
ByVal hInst As Long, _
ByVal lpIconPath As String, _
lpiIcon As Long) As Long

Private Sub PRO_Extraire_Icones(STR_Chemin_Fichier As String, INT_Index_Liste As Integer, BOL_Transparence As Boolean)

'===============================================================================
'Permet d'extraire un icône d'un fichier exe, dll ou ico
'
'STR_Chemin_Fichier : nom du fichier dont on veux extraire l'icône
'INT_Index_Liste : Index de la liste des icônes à extraire
'BOL_Transparence : Activation ou non de la transparence de l'icône
'===============================================================================

'on active la routine de traitement d'erreur
On Error GoTo erreur0

'déclaration des variables privées
Dim LNG_Grande_Icone As Long 'stocke la grande icone
Dim LNG_Petite_Icone As Long 'stocke la petite icone

    'on définit la couleur de transparence temporaire et on vide la zone de visualisation
    If BOL_Transparence Then
        
        PCT_APERCU.BackColor = vbBlack
    
    Else
    
        PCT_APERCU.BackColor = vbWhite
        
    End If
    
    'on efface la visualisation de l'icône
    PCT_APERCU.Picture = LoadPicture()
    
    'on extrait la grande et la petite icône des fichiers
    ExtractIconEx STR_Chemin_Fichier, INT_Index_Liste, LNG_Grande_Icone, LNG_Petite_Icone, 1
    
    'on affiche la grance icône dans la zone de visualisation
    DrawIconEx PCT_APERCU.hdc, 0, 0, LNG_Grande_Icone, 0, 0, 0, 0, &H3
    
    'on rafraîchit l'affichage de l'icône
    PCT_APERCU.Picture = PCT_APERCU.Image
    Call IML_ICONES.ListImages.Add(, , PCT_APERCU.Picture)

    'on détruit l'icône pour libérer de la mémoire
    DestroyIcon LNG_Grande_Icone
    DestroyIcon LNG_Petite_Icone
    
'la procédure est finie
Exit Sub

'routine de traitement d'erreur
erreur0:
'problème : on n'a pas pu extraire correctement l'icône
'solution : on décharge l'icône de la zone de visualisation, on prévient l'utilisateur et on quitte la procédure

'on décharge l'icone de la zone de visualisation
PCT_APERCU.Picture = LoadPicture()

'on prévient l'utilisateur
MsgBox "Une erreur est apparue lors de l'extraction de l'icône sélectionnée.", vbOKOnly + vbExclamation, "Erreur lors de l'extraction de l'icône"

'on libère la mémoire si les icônes ont été extraites
If LNG_Grande_Icone Then DestroyIcon LNG_Grande_Icone
If LNG_Petite_Icone Then DestroyIcon LNG_Petite_Icone

End Sub

Private Sub PRO_Extraire_Une_Icone(STR_Chemin_Fichier As String, ByVal BOL_Transparence As Boolean)

'===============================================================================
'Permet d'extraire l'icône d'un fichier qui n'en possède qu'une seule
'
'STR_Chemin_Fichier : nom du fichier dont on veux extraire l'icône
'BOL_Transparence : Activation ou non de la transparence de l'icône
'===============================================================================

'on active la routine de traitement d'erreur
'On Error GoTo erreur0

'déclaration des variables privées
Dim LNG_Icone As Long 'stocke l'icone en mémoire

    'on définit la couleur de transparence temporaire et on vide l'ancienne icone affichée
    If BOL_Transparence = True Then
    
        PCT_APERCU.BackColor = vbBlack
        
    Else
    
        PCT_APERCU.BackColor = vbWhite
        
    End If
    
    'on efface la visualisation de l'icône
    PCT_APERCU.Picture = LoadPicture()
        
    'on extrait l'icone associée au fichier
    LNG_Icone = ExtractAssociatedIcon(App.hInstance, STR_Chemin_Fichier, 0)
    
    'on déssine l'icône extaite
    DrawIcon PCT_APERCU.hdc, 0, 0, LNG_Icone
    
    'on définit l'affichage de l'icône
    PCT_APERCU.Picture = PCT_APERCU.Image
    Call IML_ICONES.ListImages.Add(, , PCT_APERCU.Picture)

    'on détruit l'icône pour libérer de la mémoire
    DestroyIcon LNG_Icone
    
'la procédure est finie
Exit Sub

'routine de traitement d'erreur
erreur0:
'problème : on n'a pas pu extraire correctement l'icône
'solution: on efface la zone d'affichage de l'icône, on prévient l'utilisateur, puis on quitte la procédure

'on efface la zone d'affichage
PCT_APERCU.Picture = LoadPicture()

'on libère la mémoire si l'icône a été extraite
If LNG_Icone Then DestroyIcon LNG_Icone

'on prévient l'utilisateur
MsgBox "Une erreur est apparue lors de l'extraction de l'icône sélectionnée.", vbOKOnly + vbExclamation, "Erreur lors de l'extraction de l'icône"

End Sub

Private Sub DRE_Dossiers_Click()

    'on met à jour la liste des fichiers
    FLE_FICHIERS.Path = DRE_Dossiers.Chemin

End Sub

Private Sub FLE_FICHIERS_Click()

'on active la routine de traitement d'erreur
On erreur GoTo erreur0

'déclaration des variables privées
Dim STR_Chemin_Fichier As String    'stocke le chemin d'accès au fichier d'icône
Dim INT_For1 As Integer             'stocke les valeurs de la boucle For->Next
Dim OBJ_For1 As Object              'stocke les objets de la boucle For->Each
Dim INT_Nombre_Icones As Integer    'stocke le nombre d'icône dans le fichier sélectionné

    'on vide la liste des icônes
    LSV_ICONES.Icons = Nothing
    LSV_ICONES.SmallIcons = Nothing
    LSV_ICONES.ListItems.Clear
    IML_ICONES.ListImages.Clear
    IML_ICONES.ImageHeight = 32
    IML_ICONES.ImageWidth = 32

    'on définit le chemin d'accès au fichier d'icône sélectionné
    STR_Chemin_Fichier = DRE_Dossiers.Chemin
        
    If Mid(STR_Chemin_Fichier, Len(STR_Chemin_Fichier), 1) = "\" Then
    
        STR_Chemin_Fichier = Mid(STR_Chemin_Fichier, 1, 2)
        
    End If
    STR_Chemin_Fichier = STR_Chemin_Fichier & "\" & FLE_FICHIERS.SelectedFile
        
    'on calcule le nombre d'icône dans le fichir sélectionné
    INT_Nombre_Icones = ExtractIcon(App.hInstance, STR_Chemin_Fichier, -1)

    'on teste le nombre d'icônes contenues dans le fichier sélectionné
    If INT_Nombre_Icones Then

        'on définit l'affichage de la feuille
        LSV_ICONES.Visible = False

        For INT_For1 = 0 To INT_Nombre_Icones - 1

            'on extrait l'icône
            PRO_Extraire_Icones STR_Chemin_Fichier, INT_For1, False
            DoEvents

        Next INT_For1

        'on lie le listview avec la liste des icônes disponibles
        LSV_ICONES.Icons = IML_ICONES

        For INT_For1 = 0 To INT_Nombre_Icones - 1
        
            'on ajoutte l'icône dans la liste d'icônes
            Call LSV_ICONES.ListItems.Add(, , Mid(FLE_FICHIERS.SelectedFile, 1, Len(FLE_FICHIERS.SelectedFile) - 4) & "_icone" & CStr(INT_For1 + 1), INT_For1 + 1)
            DoEvents
        
        Next INT_For1
        
        'on redéfinit l'affichage de la feuille
        LSV_ICONES.Visible = True

    Else

        'on réextrait l'icône
        PRO_Extraire_Une_Icone STR_Chemin_Fichier, False

        'on lie le listview avec la liste des icônes disponibles
        LSV_ICONES.Icons = IML_ICONES

        'on ajoutte l'icône dans la liste d'icônes
        Call LSV_ICONES.ListItems.Add(, , Mid(FLE_FICHIERS.SelectedFile, 1, Len(FLE_FICHIERS.SelectedFile) - 4) & "_icone1", 1)

    End If
    
'la procédure est finie
Exit Sub

'routine de traitement d'erreur
erreur0:
'problème : on n'a pas pu afficher le nombre total d'icône
'solution : on efface la liste des icônes disponibles, on prévient l'utilisateur, puis on quitte la procédure
    
'on efface la liste des icônes disponibles
'LIS_ICONE.Clear

'on prévient l'utilisateur
MsgBox "Une erreur inattendue a empêché de connaître les icônes contenues dans le fichier sélectionné.", vbOKOnly + vbExclamation, "Erreur lors de la détermination des icônes contenues dans un fichier."

End Sub

Conclusion :


Un grand merci à yomm pour son accord d'utilisation de ces ocx, ils vont bien me servir !
Sinon, je ne pense pas qu'il y ait de bugs, mais cela reste possible, alors n'hésitez pas à me le dire pour que je les corrige.
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

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.

Du même auteur (cs_DARKSIDIOUS)