Saberexcel - o site das macros

Esse exemplo de planilha do Aplicativo Microsoft Excel VBA(Visual Basic Application), usando um objeto ListView,  lista os arquivos de determinados diretório, incluindo os ícones de sua extenção, exemplo, excel, pdf, doc, txt, etc..
'procedimentos do objeto listview.

Private Sub UserForm_Initialize()
Dim objShell As Object, objFolder As Object
Dim x As Integer, vNumArquivos As Integer, SecuriteSlash As Integer
Dim vTabela() As String
Dim vDirecao As String, Executable As String

'*****************
Set objShell = CreateObject("Shell.Application") 'procura pelo dir
Set objFolder = objShell.BrowseForFolder(&H0&, "Procurar por um Diretório", &H1&)
On Error Resume Next
vCaminho = objFolder.ParentFolder.ParseName(objFolder.Title).Path
If objFolder.Title = "" Then vCaminho = ""
SecuriteSlash = InStr(objFolder.Title, ":")
If SecuriteSlash > 0 Then vCaminho = Mid(objFolder.Title, SecuriteSlash - 1, 2) & ""

If vCaminho = "" Then Exit Sub
'*****************
'listando os arquivos do diretorio
vDirecao = Dir(vCaminho & "\*.*")

Do While Len(vDirecao) > 0
vNumArquivos = vNumArquivos + 1
ReDim Preserve vTabela(1 To vNumArquivos)
vTabela(vNumArquivos) = vDirecao
vDirecao = Dir()
Loop
'*****************
ImageList1.ListImages.Clear

If vNumArquivos > 0 Then

For x = 1 To vNumArquivos
    Executable = FindExecutable(vCaminho & "\" & vTabela(x)) 'procura executavel associado ao arquivo
    ImageList1.ListImages.Add , "A" & x, GetIconFromFile(Executable, 0, False) 'inserindo o icone
Next x

ListView1.SmallIcons = ImageList1

With ListView1
    With .ColumnHeaders
        .Clear
        .Add , , "Nom fichier", 220
        .Add , , "taille", 70
        .Add , , "Date", 70
    End With

For x = 1 To vNumArquivos
.ListItems.Add , , vTabela(x)
.ListItems(x).ListSubItems.Add , , FileLen(vCaminho & "\" & vTabela(x)) & " Bytes"
.ListItems(x).ListSubItems.Add , , Format(FileDateTime(vCaminho & "\" & vTabela(x)), "DD/MM/YYYY")
.ListItems(x).SmallIcon = "A" & x
Next
End With

End If

ListView1.View = 3
Label1 = vCaminho
End Sub

 
DECLARAÇÕES NECESSÁRIAS EM UM MODULO COMUM

Option Explicit

Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" (ByVal pszPath As Any, ByVal dwFileAttributes As Long, psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long
 
Public Declare Function FindExecutableA Lib "shell32.dll" (ByVal lpFile As String, ByVal lpdirectory As String, ByVal lpResult As String) As Long
Public Const MAX_FILENAME_LEN = 256
 
Public Declare Function OleCreatePictureIndirect _
Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
 
Public Type PicBmp
   Size As Long
   tType As Long
   hBmp As Long
   hPal As Long
   Reserved As Long
End Type
 
Public Type GUID
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(7) As Byte
End Type
 
Public Type SHFILEINFO
  hicon As Long
  iIcon As Long
  dwAttributes As Long
  szDisplayName As String * 260
  szTypeName As String * 80
End Type

Public Function GetIconFromFile(FileName As String, IconIndex As Long, UseLargeIcon As Boolean) As IPicture
'*************************************
'Necessita da referencia standard OLE Types
'**************************************
Dim b As SHFILEINFO
Dim retval As Long
Dim pic As PicBmp
Dim IPic As IPicture
Dim IID_IDispatch As GUID
 
retval = SHGetFileInfo(FileName, 0, b, Len(b), &H100)
 
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
 
With pic
.Size = Len(b)
.tType = 3 'vbPicTypeIcon
.hBmp = b.hicon
End With
 
Call OleCreatePictureIndirect(pic, IID_IDispatch, 1, IPic)
Set GetIconFromFile = IPic
 
End Function
 
Public Function FindExecutable(S As String) As String
Dim i As Integer
Dim S2 As String

S2 = String(MAX_FILENAME_LEN, 32) & Chr$(0)
i = FindExecutableA(S & Chr$(0), vbNullString, S2)
If i > 32 Then
   FindExecutable = Left$(S2, InStr(S2, Chr$(0)) - 1)
Else
   FindExecutable = ""
End If
    
End Function




 Aprenda tudo sobre o Aplicativo Microsoft Excel VBA(Visual Basic Application), sozinho, com baixo custo, praticando com os produtos didáticos Saberexcel



  DOWNLOAD LIVRE PARA REGISTRADOS
---- Baixe o exemplo de planilha contendo declarações e procedimentos acima
Excel planilha vba diretorio usf listview lista arquivos com icones (71.19 KB)