hi, put this in form1
Option Explicit
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Declare Function PathFileExists Lib "shlwapi.dll" Alias "PathFileExistsA" (ByVal pszPath As String) As Long
Private Declare Function GetLogicalDrives Lib "kernel32" () As Long
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long
Private Declare Function SHGetFileInfo Lib "shell32" Alias "SHGetFileInfoA" (ByVal pszPath As Any, ByVal dwFileAttributes As Long, psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "shell32" (ByVal hwndOwner As Long, ByVal nFolder As Long, ByRef pidl As Any) As Long
Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long)
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function FileTimeToSystemTime Lib "kernel32.dll" (ByRef lpFileTime As FILETIME, ByRef lpSystemTime As SYSTEMTIME) As Long
Private Declare Function FileTimeToLocalFileTime Lib "kernel32.dll" (ByRef lpFileTime As FILETIME, ByRef lpLocalFileTime As FILETIME) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Const MAX_PATH As Long = 260
Private Const INVALID_HANDLE_VALUE As Long = -1
Private Const FILE_ATTRIBUTE_ARCHIVE As Long = &H20
Private Const FILE_ATTRIBUTE_DIRECTORY As Long = &H10
Private Const FILE_ATTRIBUTE_HIDDEN As Long = &H2
Private Const FILE_ATTRIBUTE_NORMAL As Long = &H80
Private Const FILE_ATTRIBUTE_READONLY As Long = &H1
Private Const FILE_ATTRIBUTE_SYSTEM As Long = &H4
Private Const FILE_ATTRIBUTE_TEMPORARY As Long = &H100
Private Const FILE_ATTRIBUTE_RODIRECTORY As Long = FILE_ATTRIBUTE_DIRECTORY + FILE_ATTRIBUTE_READONLY
Private Const CSIDL_DESKTOP As Long = &H0
Private Const CSIDL_INTERNET As Long = &H1
Private Const CSIDL_PROGRAMS As Long = &H2
Private Const CSIDL_CONTROLS As Long = &H3
Private Const CSIDL_PRINTERS As Long = &H4
Private Const CSIDL_PERSONAL As Long = &H5
Private Const CSIDL_FAVORITES As Long = &H6
Private Const CSIDL_STARTUP As Long = &H7
Private Const CSIDL_RECENT As Long = &H8
Private Const CSIDL_SENDTO As Long = &H9
Private Const CSIDL_BITBUCKET As Long = &HA
Private Const CSIDL_STARTMENU As Long = &HB
Private Const CSIDL_DESKTOPDIRECTORY As Long = &H10
Private Const CSIDL_DRIVES As Long = &H11
Private Const CSIDL_NETWORK As Long = &H12
Private Const CSIDL_NETHOOD As Long = &H13
Private Const CSIDL_FONTS As Long = &H14
Private Const CSIDL_TEMPLATES As Long = &H15
Private Const CSIDL_COMMON_STARTMENU As Long = &H16
Private Const CSIDL_COMMON_PROGRAMS As Long = &H17
Private Const CSIDL_COMMON_STARTUP As Long = &H18
Private Const CSIDL_COMMON_DESKTOPDIRECTORY As Long = &H19
Private Const CSIDL_APPDATA As Long = &H1A
Private Const CSIDL_PRINTHOOD As Long = &H1B
Private Const CSIDL_ALTSTARTUP As Long = &H1D
Private Const CSIDL_COMMON_ALTSTARTUP As Long = &H1E
Private Const CSIDL_COMMON_FAVORITES As Long = &H1F
Private Const CSIDL_INTERNET_CACHE As Long = &H20
Private Const CSIDL_COOKIES As Long = &H21
Private Const CSIDL_HISTORY As Long = &H22
Private Const SHGFI_LARGEICON As Long = &H0
Private Const SHGFI_SMALLICON As Long = &H1
Private Const SHGFI_OPENICON As Long = &H2
Private Const SHGFI_SHELLICONSIZE As Long = &H4
Private Const SHGFI_PIDL As Long = &H8
Private Const SHGFI_USEFILEATTRIBUTES As Long = &H10
Private Const SHGFI_ICON As Long = &H100
Private Const SHGFI_DISPLAYNAME As Long = &H200
Private Const SHGFI_TYPENAME As Long = &H400
Private Const SHGFI_ATTRIBUTES As Long = &H800
Private Const SHGFI_ICONLOCATION As Long = &H1000
Private Const SHGFI_EXETYPE As Long = &H2000
Private Const SHGFI_SYSICONINDEX As Long = &H4000
Private Const SHGFI_LINKOVERLAY As Long = &H8000
Private Const SHGFI_SELECTED As Long = &H10000
Private Const SHGFI_ATTR_SPECIFIED As Long = &H20000
Private Const SI_FOLDER_CLOSED As Long = &H3
Private Const SI_FOLDER_OPEN As Long = &H4
Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Private Type LARGE_INTEGER
LowPart As Long
HighPart As Long
End Type
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Private Type SHFILEINFO
hicon As Long
iIcon As Long
dwAttributes As Long
szDisplayName As String * MAX_PATH
szTypeName As String * 80
End Type
Private Type SHITEMID
cb As Long
abID As Byte
End Type
Private Type ITEMIDLIST
mkid As SHITEMID
End Type
Dim IsClickCombo As Boolean
Dim SysImageListSmall As Long
Public Enum SHIL_FLAG
SHIL_LARGE = &H0 ' The image size is normally 32x32 pixels. However, if the Use large icons option is selected from the Effects section of the Appearance tab in Display Properties, the image is 48x48 pixels.
SHIL_SMALL = &H1 ' These images are the Shell standard small icon size of 16x16, but the size can be customized by the user.
SHIL_EXTRALARGE = &H2 ' These images are the Shell standard extra-large icon size. This is typically 48x48, but the size can be customized by the user.
SHIL_SYSSMALL = &H3 ' These images are the size specified by GetSystemMetrics called with SM_CXSMICON and GetSystemMetrics called with SM_CYSMICON.
SHIL_JUMBO = &H4 ' Windows Vista and later. The image is normally 256x256 pixels.
End Enum
Private Declare Function SetWindowTheme Lib "uxtheme.dll" (ByVal hwnd As Long, ByVal pszSubAppName As Long, ByVal pszSubIdList As Long) As Long
Private Declare Function GetVersion Lib "kernel32" () As Long
Private Declare Sub InitCommonControls Lib "comctl32.dll" ()
Private OS_Version As Long
Private cListViewPaths As Collection
Private Sub ListPath(ByVal sPath As String)
Dim uSHFI As SHFILEINFO
Dim uWFD As WIN32_FIND_DATA
Dim lParam As Long
Dim lNextIdx As Long
Dim sName As String
Dim lFolders As Long
Dim hSearch As Long
Dim hNext As Long
Dim lRet As Long
Dim lCount As Long
Dim FolderPos As Long
Screen.MousePointer = vbHourglass
Set cListViewPaths = New Collection
ucListView1.Clear
NormalizePath sPath
hNext = 1
hSearch = FindFirstFile(sPath & "*" & vbNullChar, uWFD)
If (hSearch <> INVALID_HANDLE_VALUE) Then
Do While hNext
sName = StripNulls(uWFD.cFileName)
If (sName <> "." And sName <> "..") Then
lRet = SHGetFileInfo(sPath & sName, 0, uSHFI, Len(uSHFI), SHGFI_DISPLAYNAME Or SHGFI_SYSICONINDEX Or SHGFI_TYPENAME)
If (uWFD.dwFileAttributes = FILE_ATTRIBUTE_DIRECTORY Or uWFD.dwFileAttributes = FILE_ATTRIBUTE_RODIRECTORY) Then
ucListView1.ItemAdd FolderPos, uSHFI.szDisplayName, 0, uSHFI.iIcon, lCount
ucListView1.SubItemText(FolderPos, 2) = uSHFI.szDisplayName
ucListView1.SubItemText(FolderPos, 3) = uSHFI.szTypeName
ucListView1.SubItemText(FolderPos, 4) = FileTimeToVBDate(uWFD.ftLastWriteTime)
ucListView1.SubItemText(FolderPos, 5) = GetFileAttString(uWFD.dwFileAttributes)
FolderPos = FolderPos + 1
Else
ucListView1.ItemAdd lCount, uSHFI.szDisplayName, 0, uSHFI.iIcon, lCount
ucListView1.SubItemText(lCount, 1) = GetFormatSizeFile(LargeIntToCurrency(uWFD.nFileSizeLow, uWFD.nFileSizeHigh))
ucListView1.SubItemText(lCount, 2) = uSHFI.szDisplayName
ucListView1.SubItemText(lCount, 3) = uSHFI.szTypeName
ucListView1.SubItemText(lCount, 4) = FileTimeToVBDate(uWFD.ftLastWriteTime)
ucListView1.SubItemText(lCount, 5) = GetFileAttString(uWFD.dwFileAttributes)
End If
cListViewPaths.Add sPath & sName, CStr(lCount)
lCount = lCount + 1
End If
hNext = FindNextFile(hSearch, uWFD)
Loop
hNext = FindClose(hSearch)
End If
Screen.MousePointer = vbDefault
End Sub
Private Sub NormalizePath(sData As String)
sData = IIf(Right$(sData, 1) = "\", sData, sData & "\")
End Sub
Private Function FileTimeToVBDate(FT As FILETIME) As Date
Dim LFT As FILETIME
Dim ST As SYSTEMTIME
FileTimeToLocalFileTime FT, LFT
FileTimeToSystemTime LFT, ST
FileTimeToVBDate = DateSerial(ST.wYear, ST.wMonth, ST.wDay) + TimeSerial(ST.wHour, ST.wMinute, ST.wSecond) '+ (ST.wMilliseconds / 86400000)
End Function
Private Function LargeIntToCurrency(Low As Long, High As Long) As Currency
Dim LI As LARGE_INTEGER
LI.LowPart = Low: LI.HighPart = High
CopyMemory LargeIntToCurrency, LI, LenB(LI)
LargeIntToCurrency = LargeIntToCurrency * 10000
End Function
Private Function GetFormatSizeFile(ByVal Bytes As Currency) As String
If Bytes >= 1024 Then
If Bytes >= 1073741824 Then
GetFormatSizeFile = Format((Bytes / 1073741824), "##,###,##0.00") & " GB"
Else
If Bytes >= 1048576 Then
GetFormatSizeFile = Format((Bytes / 1048576), "##,###,##0.00") & " MB"
Else
GetFormatSizeFile = Format((Bytes \ 1024), "##,###,##0") & " KB"
End If
End If
Else
GetFormatSizeFile = Format(Bytes, "##,###,##0") & " Bytes"
End If
End Function
Private Function GetFileAttString(ByVal hAttr As Long) As String
If (hAttr And vbReadOnly) = vbReadOnly Then GetFileAttString = "R"
If (hAttr And vbHidden) = vbHidden Then GetFileAttString = GetFileAttString & "H"
If (hAttr And vbSystem) = vbSystem Then GetFileAttString = GetFileAttString & "S"
If (hAttr And vbArchive) = vbArchive Then GetFileAttString = GetFileAttString & "A"
If (hAttr And &H800) = &H800 Then GetFileAttString = GetFileAttString & "C"
End Function
Private Function GetPathName(ByVal sPath As String) As String
Dim lRet As Long
lRet = InStrRev(sPath, "\")
If lRet Then GetPathName = Right(sPath, Len(sPath) - lRet)
End Function
Private Sub ComboBoxEx1_ItemClick(Index As Long)
ListPath ComboBoxEx1.GetItemTag(Index)
End Sub
Private Sub ucListView1_ItemDblClick(Item As Long)
Dim sPath As String
sPath = cListViewPaths(CStr(ucListView1.ItemData(Item)))
If ucListView1.SubItemText(Item, 1) = vbNullString Then ' <- is folder
ListPath sPath
ComboBoxEx1.Text = GetPathName(sPath)
Else
MsgBox sPath
End If
End Sub
Private Sub Form_Initialize()
Call InitCommonControls
OS_Version = (GetVersion And &HFF)
If OS_Version < 5 Then
MsgBox "Systema Operativo no soportado", vbCritical
End
End If
Call InitCommonControls
End Sub
Private Sub Form_Load()
ComboBoxEx1.hImageList = GetSystemImageList(SHGFI_SMALLICON)
SysImageListSmall = GetSystemImageList(SHIL_SMALL)
With ucListView1
.Initialize
.hSmallImgList = SysImageListSmall
.ViewMode = vmDetails
.FullRowSelect = True
Call .ColumnAdd(0, "Name", 200)
Call .ColumnAdd(1, "Size", 100, caRight)
Call .ColumnAdd(2, "Type", 100)
Call .ColumnAdd(3, "Modified", 100)
Call .ColumnAdd(4, "Attributes", 100)
If OS_Version > 5 Then Call SetWindowTheme(.hwnd, StrPtr("explorer"), 0)
End With
SetDefaultPath
ComboBoxEx1.SelectedItem = 0
End Sub
Private Sub Form_Unload(Cancel As Integer)
ucListView1.hSmallImgList = 0
End Sub
Private Sub SetDefaultPath()
ComboBoxEx1.ListItemClear
AddSpecialFolder CSIDL_DESKTOP, 0
AddSpecialFolder CSIDL_PERSONAL, 1
AddSpecialFolder CSIDL_DRIVES, 1
ListDrives
ListFolders GetSpecialFolder(CSIDL_DESKTOP) & "\"
ListPath GetSpecialFolder(CSIDL_DESKTOP)
End Sub
Private Function GetSystemImageList(ByVal uSize As Long) As Long
Dim uSHFI As SHFILEINFO
GetSystemImageList = SHGetFileInfo("C:\", 0, uSHFI, Len(uSHFI), SHGFI_SYSICONINDEX Or uSize)
End Function
Private Function AddSpecialFolder(CSIDL As Long, Ident As Long) As String
Dim r As Long
Dim Path As String
Dim IDL As ITEMIDLIST
Dim uSHFI As SHFILEINFO
r = SHGetSpecialFolderLocation(100, CSIDL, IDL)
If r = 0 Then
Path$ = Space$(512)
r = SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal Path$)
Call SHGetFileInfo(ByVal IDL.mkid.cb, 0, uSHFI, Len(uSHFI), SHGFI_PIDL Or SHGFI_DISPLAYNAME Or SHGFI_SYSICONINDEX)
ComboBoxEx1.AddItem , uSHFI.szDisplayName, StripNulls(Path) & "\", uSHFI.iIcon, , Ident, IDL.mkid.cb
End If
End Function
Private Function GetSpecialFolder(CSIDL As Long) As String
Dim r As Long
Dim IDL As ITEMIDLIST
Dim Path As String * 512
If SHGetSpecialFolderLocation(100, CSIDL, IDL) = 0 Then
Call SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal Path$)
GetSpecialFolder = StripNulls(Path$)
End If
End Function
Private Function StripNulls(ByVal sString As String) As String
Dim lPos As Long
lPos = InStr(sString, vbNullChar)
If lPos > 1 Then
StripNulls = Left$(sString, lPos - 1)
Else
StripNulls = sString
End If
End Function
Private Sub ListDrives()
Dim uSHFI As SHFILEINFO
Dim lPIDL As Long
Dim sBuffer As String * MAX_PATH
Dim lDrivesBitMask As Long
Dim lMaxPwr As Long
Dim lPwr As Long
Dim sText As String
Dim Serial As Long
lDrivesBitMask = GetLogicalDrives()
If (lDrivesBitMask) Then
lMaxPwr = Int(Log(lDrivesBitMask) / Log(2))
For lPwr = 0 To lMaxPwr
If (2 ^ lPwr And lDrivesBitMask) Then
sText = Chr$(65 + lPwr) & ":\"
Serial = 0
Call SHGetFileInfo(sText, 0, uSHFI, Len(uSHFI), SHGFI_DISPLAYNAME Or SHGFI_SYSICONINDEX)
GetVolumeInformation sText, vbNullString, 0, Serial, 0, 0, vbNullString, 0
ComboBoxEx1.AddItem , uSHFI.szDisplayName, sText, uSHFI.iIcon, , 2, Serial
End If
Next lPwr
End If
End Sub
Private Sub ListFolders(ByVal sPath As String)
Dim uSHFI As SHFILEINFO
Dim uWFD As WIN32_FIND_DATA
Dim lParam As Long
Dim lNextIdx As Long
Dim sFolderName As String
Dim lFolders As Long
Dim hSearch As Long
Dim hNext As Long
Dim lRet As Long
Screen.MousePointer = vbHourglass
hNext = 1
hSearch = FindFirstFile(sPath & "*." & vbNullChar, uWFD)
If (hSearch <> INVALID_HANDLE_VALUE) Then
Do While hNext
sFolderName = StripNulls(uWFD.cFileName)
If (sFolderName <> "." And sFolderName <> "..") Then
If (uWFD.dwFileAttributes = FILE_ATTRIBUTE_DIRECTORY Or uWFD.dwFileAttributes = FILE_ATTRIBUTE_RODIRECTORY) Then
lRet = SHGetFileInfo(sPath & sFolderName & "\", 0, uSHFI, Len(uSHFI), SHGFI_DISPLAYNAME Or SHGFI_SYSICONINDEX)
ComboBoxEx1.AddItem , uSHFI.szDisplayName, sPath & sFolderName & "\", uSHFI.iIcon, , 1
End If
End If
hNext = FindNextFile(hSearch, uWFD)
Loop
hNext = FindClose(hSearch)
End If
Screen.MousePointer = vbDefault
End Sub
