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.
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.