5/5 (13 avis)
Vue 13 606 fois - Téléchargée 1 195 fois
' Télécharger le zip c'est mieux parce qu'il y a un groupe de projet avec un exemple d'utilisation ' Sinon voici le source du contrôle ' Balancez ça dans notepad et enregistrer "FileListView.ctl" VERSION 5.00 Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX" Begin VB.UserControl FileListView ClientHeight = 3630 ClientLeft = 0 ClientTop = 0 ClientWidth = 4815 ScaleHeight = 242 ScaleMode = 3 'Pixel ScaleWidth = 321 Begin VB.PictureBox picIcon Appearance = 0 'Flat AutoRedraw = -1 'True AutoSize = -1 'True BackColor = &H00800080& BorderStyle = 0 'None ForeColor = &H80000008& Height = 240 Left = 3720 ScaleHeight = 256 ScaleMode = 0 'User ScaleWidth = 288 TabIndex = 1 Top = 1440 Visible = 0 'False Width = 240 End Begin MSComctlLib.ImageList ImageFile Left = 3480 Top = 120 _ExtentX = 1005 _ExtentY = 1005 BackColor = -2147483643 MaskColor = 8388736 _Version = 393216 End Begin MSComctlLib.ListView file Height = 3615 Left = 0 TabIndex = 0 Top = 0 Width = 3375 _ExtentX = 5953 _ExtentY = 6376 View = 3 LabelEdit = 1 MultiSelect = -1 'True LabelWrap = -1 'True HideSelection = 0 'False HideColumnHeaders= -1 'True FullRowSelect = -1 'True _Version = 393217 ForeColor = -2147483640 BackColor = -2147483643 BorderStyle = 1 Appearance = 1 NumItems = 1 BeginProperty ColumnHeader(1) {BDD1F052-858B-11D1-B16A-00C0F0283628} Object.Width = 396875 EndProperty End End Attribute VB_Name = "FileListView" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = True Option Explicit Private Const ILD_TRANSPARENT = &H1 'Couleur de la transparence ( je me comprends, essayez de changer pour comprendre ) ' Constantes pour SHFILEINFO Private Const SHGFI_DISPLAYNAME = &H200 Private Const SHGFI_EXETYPE = &H2000 Private Const SHGFI_SYSICONINDEX = &H4000 Private Const SHGFI_LARGEICON = &H0 Private Const SHGFI_SMALLICON = &H1 Private Const SHGFI_SHELLICONSIZE = &H4 Private Const SHGFI_TYPENAME = &H400 Private Const BASIC_SHGFI_FLAGS = SHGFI_TYPENAME _ Or SHGFI_SHELLICONSIZE _ Or SHGFI_SYSICONINDEX _ Or SHGFI_DISPLAYNAME _ Or SHGFI_EXETYPE 'Constantes combinnées ( grâce à l'opératuer "or" )le plus souvent utilisées lors de l'extraction d'une icône 'Combinez cette constante basique à une des constanctes SHGFI_LARGEICON ou SHGFI_SMALLICON grâce à "or" pour 'extraire les icônes avec la taille qui vous interresse Private Type SHFILEINFO hIcon As Long iIcon As Long dwAttributes As Long szDisplayName As String * 260 szTypeName As String * 80 End Type ' API utilisée pour extraire l'icône associé à un fichier ' Renvoie un nombre ( long ) qui représente le handle d'un icône ( qui varie à chaque sollicitation ) Private Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" _ (ByVal pszPath As String, _ ByVal dwFileAttributes As Long, _ psfi As SHFILEINFO, _ ByVal cbSizeFileInfo As Long, _ ByVal uFlags As Long) As Long ' API utilisée pour dessiner dans un pictureBox une icône grâce à son Handle ( extrait avec l'API SHGetFileInfo ) Private Declare Function ImageList_Draw Lib "comctl32.dll" _ (ByVal himl&, _ ByVal i&, _ ByVal hDCDest&, _ ByVal x&, _ ByVal y&, _ ByVal flags&) As Long Dim ShInfo As SHFILEINFO Dim Ctrl_Path As String ' Variable dans laquelle est stocké le chemin du dossier où se trouvent les fichiers listés Dim Ctrl_Pattern As String ' Variable dans laquelle est stocké le Pattern des fichiers à lister Event Click() Event DblClick() Event MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single) Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single) Event KeyDown(KeyCode As Integer, Shift As Integer) Event KeyPress(KeyAscii As Integer) Event KeyUp(KeyCode As Integer, Shift As Integer) Event ItemClick(ByVal Item As MSComctlLib.ListItem) Event SelectFile(FileName As String, Fullpath As String) Event PathChange(New_Path As String, Old_Path As String) Private Sub file_Click() RaiseEvent Click End Sub Private Sub file_DblClick() RaiseEvent DblClick End Sub Private Sub file_ItemClick(ByVal Item As MSComctlLib.ListItem) MsgBox Item.SmallIcon RaiseEvent ItemClick(Item) RaiseEvent SelectFile(Item.Text, Item.Key) End Sub Private Sub UserControl_Initialize() loadFileList App.Path, Ctrl_Pattern End Sub '************************************************************************************ ' Charge la liste des fichiers du répertoire "Path" selon les conditions du "Pattern" '************************************************************************************ Private Sub loadFileList(Path As String, Pattern As String) On Error GoTo error Dim listeFichier As String Dim itemx As ListItem Dim fichier As String Dim ShInfo As SHFILEINFO Dim hIcon As Long Dim imgx As ListImage Dim fso As Variant Dim extension As String Dim WasSorted As Boolean WasSorted = file.Sorted file.Sorted = False Set fso = CreateObject("Scripting.FileSystemObject") file.ListItems.Clear file.Refresh file.SmallIcons = Nothing ImageFile.ListImages.Clear If Not Right(Path, 1) = "\" Then Path = Path & "\" Ctrl_Path = Path listeFichier = Dir(Path & Pattern, vbReadOnly + vbNormal + vbHidden + vbArchive + vbSystem) Do Until listeFichier = "" fichier = Path & listeFichier Set itemx = file.ListItems.Add(, fichier, listeFichier) itemx.Selected = False listeFichier = Dir extension = UCase(fso.GetExtensionName(fichier)) Select Case extension Case "EXE" hIcon = SHGetFileInfo(fichier, 0&, ShInfo, Len(ShInfo), _ BASIC_SHGFI_FLAGS Or SHGFI_SMALLICON) picIcon.Picture = Nothing ImageList_Draw hIcon, ShInfo.iIcon, picIcon.hDC, 0, 0, ILD_TRANSPARENT Set imgx = ImageFile.ListImages.Add(, fichier, picIcon.Image) Case "ICO" hIcon = SHGetFileInfo(fichier, 0&, ShInfo, Len(ShInfo), _ BASIC_SHGFI_FLAGS Or SHGFI_SMALLICON) picIcon.Picture = Nothing ImageList_Draw hIcon, ShInfo.iIcon, picIcon.hDC, 0, 0, ILD_TRANSPARENT Set imgx = ImageFile.ListImages.Add(, fichier, picIcon.Image) Case "CUR" hIcon = SHGetFileInfo(fichier, 0&, ShInfo, Len(ShInfo), _ BASIC_SHGFI_FLAGS Or SHGFI_SMALLICON) picIcon.Picture = Nothing ImageList_Draw hIcon, ShInfo.iIcon, picIcon.hDC, 0, 0, ILD_TRANSPARENT Set imgx = ImageFile.ListImages.Add(, fichier, picIcon.Image) Case "BMP" hIcon = SHGetFileInfo(fichier, 0&, ShInfo, Len(ShInfo), _ BASIC_SHGFI_FLAGS Or SHGFI_SMALLICON) picIcon.Picture = Nothing ImageList_Draw hIcon, ShInfo.iIcon, picIcon.hDC, 0, 0, ILD_TRANSPARENT Set imgx = ImageFile.ListImages.Add(, fichier, picIcon.Image) Case "LNK" hIcon = SHGetFileInfo(fichier, 0&, ShInfo, Len(ShInfo), _ BASIC_SHGFI_FLAGS Or SHGFI_SMALLICON) picIcon.Picture = Nothing ImageList_Draw hIcon, ShInfo.iIcon, picIcon.hDC, 0, 0, ILD_TRANSPARENT Set imgx = ImageFile.ListImages.Add(, fichier, picIcon.Image) Case vbNullString hIcon = SHGetFileInfo(fichier, 0&, ShInfo, Len(ShInfo), _ BASIC_SHGFI_FLAGS Or SHGFI_SMALLICON) picIcon.Picture = Nothing ImageList_Draw hIcon, ShInfo.iIcon, picIcon.hDC, 0, 0, ILD_TRANSPARENT Set imgx = ImageFile.ListImages.Add(, fichier, picIcon.Image) Case Else addIcon extension, fichier End Select Loop If file.ListItems.Count = 0 Then Exit Sub file.SmallIcons = ImageFile For Each itemx In file.ListItems fichier = itemx.Key extension = UCase(fso.GetExtensionName(fichier)) If extension = "EXE" Or _ extension = "ICO" Or _ extension = "BMP" Or _ extension = vbNullString Or _ extension = "LNK" Then file.ListItems.Item(fichier).SmallIcon = fichier Else file.ListItems.Item(fichier).SmallIcon = extension End If Next file.Sorted = WasSorted Exit Sub error: If Err.Number = 7 Or Err.Number = 35600 Then Resume Next 'Survient lorsque la capacité de l'imagelist est dépassé ( environ 400 images ) If Err.Number = 35601 Then Resume Next ' survient après la correction d'un key numérique If Err.Number = 35603 Then ' survient lorsque la key est numérique ( exemple si le fichier s'appelle chaipas.123) extension = "KEY_NEED2BE_A_STRING" & extension hIcon = SHGetFileInfo(fichier, 0&, ShInfo, Len(ShInfo), _ BASIC_SHGFI_FLAGS Or SHGFI_SMALLICON) picIcon.Picture = Nothing ImageList_Draw hIcon, ShInfo.iIcon, picIcon.hDC, 0, 0, ILD_TRANSPARENT Set imgx = ImageFile.ListImages.Add(, extension, picIcon.Image) file.SmallIcons = ImageFile itemx.SmallIcon = extension Err.Clear Resume Next Else MsgBox "Une erreur inattendue est survenue." & vbCrLf & vbCrLf & "Numéro de l'erreur : " & vbCrLf & Err.Number & vbCrLf & vbCrLf & "Description de l'erreur : " & vbCrLf & Err.Description, vbExclamation, "Erreur..." Err.Clear Resume Next End If End Sub '********************************************************************************* ' Lors de la procédure LoadFileList qui liste les fichiers d'un répertoire, ' si l'extension du fichier ajouté est différente des fichiers à icones variables ' ( .ico par exemple )pour ne pas surcharger l'ImageList, et pour gagner du temps, ' on évite d'extraire plusieurs fois la même icône associée à une extension ' 'En gros et vu de loin, si l'îcone associé à "Extension" n'est pas trouvé 'dans l'ImageList, l'erreur 35601 '********************************************************************************* Private Sub addIcon(extension As String, fichier As String) On Error GoTo error Dim r As Variant Dim hIcon As Long Dim imgx As ListImage r = ImageFile.ListImages.Item(extension).Index Exit Sub error: If Err.Number = 35601 Then 'survient lorsque la key n'est pas trouvé hIcon = SHGetFileInfo(fichier, 0&, ShInfo, Len(ShInfo), _ BASIC_SHGFI_FLAGS Or SHGFI_SMALLICON) picIcon.Picture = Nothing ImageList_Draw hIcon, ShInfo.iIcon, picIcon.hDC, 0, 0, ILD_TRANSPARENT Set imgx = ImageFile.ListImages.Add(, extension, picIcon.Image) Err.Clear Resume Next Else MsgBox "Une erreur inattendue est survenue." & vbCrLf & vbCrLf & "Numéro de l'erreur : " & vbCrLf & Err.Number & vbCrLf & vbCrLf & "Description de l'erreur : " & vbCrLf & Err.Description, vbExclamation, "Erreur..." Err.Clear Resume Next End If End Sub Private Sub File_KeyDown(KeyCode As Integer, Shift As Integer) RaiseEvent KeyDown(KeyCode, Shift) End Sub Private Sub File_KeyPress(KeyAscii As Integer) RaiseEvent KeyPress(KeyAscii) End Sub Private Sub File_KeyUp(KeyCode As Integer, Shift As Integer) RaiseEvent KeyUp(KeyCode, Shift) RaiseEvent SelectFile(file.SelectedItem.Text, file.SelectedItem.Key) RaiseEvent Click End Sub Private Sub File_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) RaiseEvent MouseDown(Button, Shift, x, y) End Sub Private Sub File_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single) RaiseEvent MouseMove(Button, Shift, x, y) End Sub Private Sub File_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single) RaiseEvent MouseUp(Button, Shift, x, y) End Sub Private Sub UserControl_Resize() file.Width = UserControl.ScaleWidth file.Height = UserControl.ScaleHeight - file.Top file.ColumnHeaders(1).Width = file.Width - 5 End Sub Public Property Get Path() As String Path = Ctrl_Path End Property Public Property Let Path(ByVal New_Path As String) loadFileList New_Path, Ctrl_Pattern PropertyChanged "Path" End Property '************************************* 'Renvoie le nom du fichier selectionné '************************************* Public Property Get FileName() As String FileName = file.SelectedItem.Text End Property '************************************ 'Selectionne un fichier dans la liste '************************************ Public Property Let FileName(New_FileName As String) Dim i As Integer If Not New_FileName = "" Then For i = 1 To file.ListItems.Count If file.ListItems.Item(i).Text = New_FileName Then file.ListItems.Item(i).Selected = True Exit For End If Next i Else For i = 1 To file.ListItems.Count file.ListItems.Item(i).Selected = False Next i End If End Property Public Property Get Pattern() As String Pattern = Ctrl_Pattern End Property Public Property Let Pattern(ByVal New_Pattern As String) Ctrl_Pattern = New_Pattern loadFileList Ctrl_Path, New_Pattern PropertyChanged "Pattern" End Property Public Property Get ListCount() As Integer ListCount = file.ListItems.Count End Property Public Property Get ListIndex() As Integer ListIndex = file.SelectedItem.Index End Property Public Property Let ListIndex(New_ListIndex As Integer) file.ListItems.Item(New_ListIndex).Selected = True End Property Public Property Get Sorted() As Boolean Sorted = file.Sorted End Property Public Property Let Sorted(New_State As Boolean) file.Sorted = New_State End Property Public Sub Refresh() loadFileList Ctrl_Path, Ctrl_Pattern End Sub Public Sub RemoveItem(fichier As String) file.ListItems.Remove (fichier) End Sub Public Function HitTest(x As Single, y As Single) On Error GoTo error: HitTest = file.HitTest(x, y) Exit Function error: HitTest = "" End Function Public Sub Selected(Item As Integer, State As Boolean) file.ListItems.Item(Item).Selected = State End Sub Public Sub Clear() file.ListItems.Clear End Sub
28 avril 2006 à 13:12
27 avril 2006 à 19:59
Ce code est déjà paru en 1999, dans un tutotial
Alors je doute que tes méninges ait bien fonctionné. Par contre c'est bien de l'avoir mi sur ce site.
Il faut rendre à César ....
5 nov. 2003 à 21:41
5 nov. 2003 à 10:01
14 juil. 2003 à 00:54
C'à me fait gagner un temp fou.
10
Salut. et merci encore
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.