Contrôle activex shell icônes

Télécharger le projet
Commenter

Description

Permet d'obtenir les icônes associées aux types de fichiers de Windows pour créer des explorateurs de fichiers. C'est à dire, lors de la génèse de listes de fichiers, obtenir la petite ou la grande icône qui est associée à son type ou qui lui est propre.
Le contrôle est compilé (.ocx). Il n'y a donc pas la source. Mais son utilisation et ses contraintes sont détaillées dans sa fenêtre "A propos de".

Programmé en VB6, ce contrôle comble une des nombreuses lacunes du VB6. Entre autre, dans l'utilisation des contrôles "TreeView" et "ListView" du composant "Microsoft Common Controls 6.0 (SP4)".

Je pense qu'il sera utile à plus d'un.

NOTE IMPORTANTE :
Cet OCX est basé en parti sur une source d'ici intétulée "FileToIcone". Et ne me demandez pas de détails sur l'utilisation des API car je serais bien incapable de vous en fournir. Pour moi c'est compliqué, trop compliqué. "Pouquoi faire simple lors qu'on peut fair super compliqué" telle est la devise de l'informatique à la Microsoft et Intel. Ils font des trucs bien, mais alors putain, pourquoi les faire aussi compliqué alors que c'est si simple de faire simple ??? Comme d'habitude, c'est l'utilisateur qui trinque. L'intelligence passe par l'adaptation. Avis à tous ceux dont le QI dépasse 110.

Ma devise, dans la vie, c'est :
"Il ne faut pas vivre à la hauteur de ses moyens mais à la hauteur des ses besoins"
A méditez...

Si je n'ai pas mis le code c'est qu'il est peu intéressant tant du point de vue pédagogique que du point de vue technique. Il fait juste appel à des API...

C'est pour cela que je ne garantie aucunement que son fonctionnement sera parfait et sans "bugs".

Eclatez-vous bien avec ce petit joujou

Source / Exemple : 


'---------------------------------------------------------------------------
'---------------------------------------------------------------------------
'--- CONTROLE ACTIVE X  Shell Icônes ---------------------------------------
'---------------------------------------------------------------------------
'---------------------------------------------------------------------------
Option Explicit

Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal varHicone As Long) As Long
Private Declare Function SHGetFileInfo Lib "shell32" Alias "SHGetFileInfoA" (ByVal pszPath As Any, ByVal dwFileAttributes As Long, psfi As typShellFichierInfos, ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpsz As Any, pclsid As typGuID) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (lptypDescriptionImage As typDescriptionImage, riid As typGuID, ByVal fPictureOwnsHandle As Long, ipic As IPicture) As Long
'---------------------------------------------------------------------------
Public Enum typTailleIcone
 vbPetiteIcone = False
 vbGrandeIcone = True
End Enum
'---------------------------------------------------------------------------
Private Type typGuID
 varGuIDdataA As Long
 varGuIDdataB As Integer
 varGuIDdataC As Integer
 varGuIDdataD(7) As Byte
End Type

Private Type typDescriptionImage
 varTaille As Long
 varType As Long
 varImageH As Long
 varX As Long
 varY As Long
End Type

Private Type typShellFichierInfos
 varHicone As Long
 varIicone As Long
 varAttributAffichage As Long
 varTailleNomAffichage As String * 260
 varTailleTypeAffichage As String * 80
End Type
'---------------------------------------------------------------------------
Private Const cstIDicone As String = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"
Private Const cstFichierAttributNormal As Long = 128
Private Const cstShellGfiUseFichierAttributs As Long = 16
Private Const cstShellGfiNomDeAffichage As Long = 512
Private Const cstShellGfiNomDuType As Long = 1024
Private Const cstShellGfiPetiteIcone As Long = 1
Private Const cstShellGfiGrandeIcone As Long = 0
Private Const cstShellGfvarIiconee As Long = 256
'---------------------------------------------------------------------------
Private varLocImage As IPicture
Private varLocShellFichierInfos As typShellFichierInfos
Private varLocAttributs As Long
Private varLocDescriptionImage As typDescriptionImage
Private varLocDonneesGuID As typGuID
Private varLocTypeDeFichier As String

Private varLocCheminDuFichier As String
Private varLocTailleIcone As typTailleIcone
Private varLocNumeroIcone As String

'---------------------------------------------------------------------------
'--- Fonctions -------------------------------------------------------------
'---------------------------------------------------------------------------
Private Sub procGetInfos()
 ctrPictureBox.Cls
 Set varLocImage = procIconeDuFichier(varLocCheminDuFichier, varLocTypeDeFichier, varLocTailleIcone)
 If Not varLocImage Is Nothing Then DrawIcon ctrPictureBox.hdc, 0, 0, varLocImage.Handle
End Sub

Private Function procIconeDuFichier(ByVal varProcNomDuFichier As String, Optional ByRef varProcNomDuType As String, Optional ByVal varProcGrandOuiNon As Boolean = True) As IPicture
 If varProcGrandOuiNon = True Then
  varLocAttributs = cstShellGfiGrandeIcone Or cstShellGfvarIiconee Or cstShellGfiUseFichierAttributs Or cstShellGfiNomDuType
 Else
  varLocAttributs = cstShellGfiPetiteIcone Or cstShellGfvarIiconee Or cstShellGfiUseFichierAttributs Or cstShellGfiNomDuType
 End If
 SHGetFileInfo varProcNomDuFichier, cstFichierAttributNormal, varLocShellFichierInfos, Len(varLocShellFichierInfos), varLocAttributs
 If Not IsMissing(varProcNomDuType) Then varProcNomDuType = Left$(varLocShellFichierInfos.varTailleTypeAffichage, lstrlen(varLocShellFichierInfos.varTailleTypeAffichage))
 Set procIconeDuFichier = procIconeEnImage(varLocShellFichierInfos.varHicone)
End Function

Private Function procIconeEnImage(ByVal varHicone As Long) As IPicture
 If varHicone = 0 Then Exit Function
 With varLocDescriptionImage
  .varType = vbPicTypeIcon
  .varTaille = Len(varLocDescriptionImage)
  .varImageH = varHicone
 End With
 If CLSIDFromString(StrPtr(cstIDicone), varLocDonneesGuID) = 0 Then OleCreatePictureIndirect varLocDescriptionImage, varLocDonneesGuID, True, procIconeEnImage
End Function

'---------------------------------------------------------------------------
'--- User Control ----------------------------------------------------------
'---------------------------------------------------------------------------
Private Sub UserControl_Resize()
 UserControl.Width = 510  '32 + 2
 UserControl.Height = 600 '38 + 2
End Sub
'---------------------------------------------------------------------------
Private Sub UserControl_Initialize()
 UserControl.Width = 510  '32 + 2
 UserControl.Height = 600 '38 + 2
 varLocCheminDuFichier = ""
 varLocTailleIcone = vbPetiteIcone
 varLocTypeDeFichier = ""
End Sub

'---------------------------------------------------------------------------
'--- Méthodes --------------------------------------------------------------
'---------------------------------------------------------------------------
Public Function GetGrandeIcone(ByVal varpath As String) As Object
 varLocCheminDuFichier = varpath
 varLocTailleIcone = vbGrandeIcone
 ctrPictureBox.Picture = LoadPicture("")
 
 If Len(varLocCheminDuFichier) = 1 And varLocCheminDuFichier = "\" Then
  Set GetGrandeIcone = ctrDossierGr.Picture
  Exit Function
 End If
 If Len(varLocCheminDuFichier) = 2 And varLocCheminDuFichier = "\+" Then
  Set GetGrandeIcone = ctrDossierOpenGr.Picture
  Exit Function
 End If
 If Len(varLocCheminDuFichier) = 2 And varLocCheminDuFichier = "\-" Then
  Set GetGrandeIcone = ctrDossierUpGr.Picture
  Exit Function
 End If
 
 Call procGetInfos
 ctrPictureBox.Picture = ctrPictureBox.Image
 ctrPictureBox.PaintPicture ctrPictureBox.Picture, 0, 0, 32, 32
 Set GetGrandeIcone = ctrPictureBox.Picture
End Function
'---------------------------------------------------------------------------
Public Function GetPetiteIcone(ByVal varpath As String) As Object
 varLocCheminDuFichier = varpath
 varLocTailleIcone = vbPetiteIcone
 ctrPictureBox.Picture = LoadPicture("")
 
 If Len(varLocCheminDuFichier) = 1 And varLocCheminDuFichier = "\" Then
  Set GetPetiteIcone = ctrDossierPt.Picture
  Exit Function
 End If
 If Len(varLocCheminDuFichier) = 2 And varLocCheminDuFichier = "\+" Then
  Set GetPetiteIcone = ctrDossierOpenPt.Picture
  Exit Function
 End If
 If Len(varLocCheminDuFichier) = 2 And varLocCheminDuFichier = "\-" Then
  Set GetPetiteIcone = ctrDossierUpPt.Picture
  Exit Function
 End If
 
 Call procGetInfos
 ctrPictureBox.Picture = ctrPictureBox.Image
 ctrPictureBox.PaintPicture ctrPictureBox.Picture, 0, 0, 16, 16
 Set GetPetiteIcone = ctrPictureBox.Picture
End Function
'---------------------------------------------------------------------------
Public Function GetTypeDeFichier(ByVal varpath As String) As String
 varLocCheminDuFichier = varpath
 varLocTailleIcone = vbGrandeIcone
 ctrPictureBox.Picture = LoadPicture("")
 
 If Len(varLocCheminDuFichier) = 1 And varLocCheminDuFichier = "\" Then
  GetTypeDeFichier = "Dossier"
  Exit Function
 End If
 If Len(varLocCheminDuFichier) = 2 And varLocCheminDuFichier = "\+" Then
  GetTypeDeFichier = "Dossier Ouvert"
  Exit Function
 End If
 If Len(varLocCheminDuFichier) = 2 And varLocCheminDuFichier = "\-" Then
  GetTypeDeFichier = "Dossier Parent"
  Exit Function
 End If
 
 Call procGetInfos
 GetTypeDeFichier = varLocTypeDeFichier
End Function
'---------------------------------------------------------------------------
'---------------------------------------------------------------------------
Public Sub ShowAboutBox()
 fenAproposDe.Show vbModal
 Unload fenAproposDe
 Set fenAproposDe = Nothing
End Sub

'---------------------------------------------------------------------------
'---------------------------------------------------------------------------
'---------------------------------------------------------------------------
'---------------------------------------------------------------------------
'---------------------------------------------------------------------------

Conclusion :


Pour reproduire cette source il vous faut :

1 "UserControl" nommé "ctrShellIcone" contenant une image d'arrière plan de 510 twips par 600 twips avec dessus :

1 Contrôle Picture nomé "ctrPictureBox"

6 Contrôles Image nommés respectivements :
ctrDossierGr : Contenant l'image de la Grande icône des dossiers
ctrDossierPt : Contenant l'image de la Petite icône des dossiers
ctrDossierOpenGr : Contenant l'image de la Grande icône des dossiers Ouverts
ctrDossierOpenPt : Contenant l'image de la Petite icône des dossiers Ouverts
ctrDossierUpGr : Contenant l'image de la Grande icône de "Dossier Parent"
ctrDossierUpPt : Contenant l'image de la Petite icône de "Dossier Parent"

ainsi qu'une fenêtre "A propos de" nomée "fenAproposDe" qui aura l'attribut de procédure "AboutBox" [mnu OUTILS => ATTRIBUTS DE PROCEDURE => AVANCÉ]

Ce n'est pas super bien codé, je vous l'accorde. A vous de l'améliorer à votre jus.

Nottez cependant que ce contrôle ne se doit que d'être utile. Son analyse n'a aucun intéret...
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 (ScSami)