Contrôle activex shell icônes

0/5 (4 avis)

Vue 2 964 fois - Téléchargée 221 fois

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

Codes Sources

A voir également

Ajouter un commentaire

Commentaires

Messages postés
1411
Date d'inscription
mercredi 6 août 2003
Statut
Membre
Dernière intervention
3 mars 2019
1
oui c'est un bon debut. detrompe toi certaines parties du code peuvent etre assez interressantes.

je rappel qd meme le principe du site qui est un site de partage. Donc ou bien tu partage la source complete ou tu ne partage rien. Tu te trouve sur un site ou les utilisateurs sont qd meme assez respectueux du travail effectué par les autres. j'entend par la que l'on ne va pas modifier ta fenetre about. Cela serait une forme d'irespect envers ton travail. Sans ce respect ce site ne serait plus la depuis bien lgtp.

tu aura tjrs 2 ou 3 brebis galeuses pour faire autrement mais cela reste sans importance.

Cela te fais plaisir quand tu trouve une source qui t'interresse et que tu peut repiquer un bout de code, donc fais en autant partage.

Enfin bon je ne fais pas ton proces, loin de là mais c'est juste pour expliquer le principe du partage de sources.
Messages postés
1488
Date d'inscription
mercredi 5 février 2003
Statut
Membre
Dernière intervention
3 décembre 2007
22
Ok les gars, vous avez gangés. Je vais la mettre cette foutue source à deux balles.

Mais je vous aurais prévenu, y'a rien d'intéressant à voir.

De plus, je vous rappele qu'avec Windows, ce qui est censé être sûr ne l'est pas forcément ! Et je ne dis ça par expérience.

Je balance la source mais pas les fichiers originaux histoire de conserver mon oxc intacte (je tiens à la fenêtre "A propos de"... égocentrisme oblige ;)
Messages postés
124
Date d'inscription
vendredi 25 avril 2003
Statut
Membre
Dernière intervention
31 mai 2008

Salut tlm !

Je suis d'accord avec bouv et MoiOlivier car on ne sait pas d'où vient cet OCX :

N'EXECUTER PAS DE FICHIER EXE, DLL, OCX ECT... QUI POURRAIENT ÊTRE DANS LE FICHIER ZIP SANS AVOIR UN ANTI-VIRUS À JOUR DE LANCÉ SUR VOTRE MACHINE !
DE PRÉFÉRENCE OUVREZ LES FICHIERS SOURCES PLUTÔT QU'UN EXE !

Envoies la source sinon ça ne peut pas aider à progresser, moi je prends que les OCX certifiés Microsoft ou bien quand il y a la source.

@+, Lebarn
Messages postés
1411
Date d'inscription
mercredi 6 août 2003
Statut
Membre
Dernière intervention
3 mars 2019
1
OK avec MoiOlivier, aucun interet sans les sources.

Comment savoir si ton ocx est fiable sans avoir les sources ?
Je te le dis on ne sais pas.

Quand tu te sera fais un nom comme EB, Reinfield et qq autres (désolé si je ne les sites pas tous), on pourra télécharger tes ocx les yeux fermés, mais pour l'instant on ne sais pas ce que cela vaut.

Je suis assez cool dans mon commentaire, attention certain seront bien plus durs.

Je ne regarde même pas l'ocx s'il n'y a pas de sources.

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.