|
Вот когда-то писал я модуль... судя по дате года два назад  Кажется он работает...
Option Explicit
'********************************************************************
'* Написано 2002 году (Team HomeWork) *
'* e-mail: sne_pro@mail.ru *
'******************************************************************** Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long Public Enum AtributConst
FILE_ATTRIBUTE_ARCHIVE = &H20
FILE_ATTRIBUTE_COMPRESSED = &H800
FILE_ATTRIBUTE_DIRECTORY = &H10
'FILE_ATTRIBUTE_ENCRYPTED=???
FILE_ATTRIBUTE_HIDDEN = &H2
FILE_ATTRIBUTE_NORMAL = &H80
'FILE_ATTRIBUTE_OFFLINE=???
FILE_ATTRIBUTE_READONLY = &H1
'FILE_ATTRIBUTE_REPARSE_POINT=???
'FILE_ATTRIBUTE_SPARSE_FILE=???
FILE_ATTRIBUTE_SYSTEM = &H4
FILE_ATTRIBUTE_TEMPORARY = &H100
End Enum
Public Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Public Type WIN32_FIND_DATA
dwFileAttributes As AtributConst
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * 260
cAlternate As String * 14
End Type
Private Const INVALID_HANDLE_VALUE = -1 'Возникает при отсутствии файла Public Sub StartFind(ByVal sFilter As String, ByRef FindArray() As WIN32_FIND_DATA)
Dim lngHandle As Long 'Хандл открытого файла
Dim TempData As WIN32_FIND_DATA 'Временная переменная
lngHandle = FindFirstFile(sFilter & vbNullChar, TempData) 'Находим хэндл If lngHandle = INVALID_HANDLE_VALUE Then Exit Sub 'Если ничего нет, уходим
ReDim FindArray(0) 'Ресайзим массив под 1-й файл (директорию)
FindArray(0) = TempData 'Присваеваем информацию о файле
Do Until FindNextFile(lngHandle, TempData) = 0 'Продолжаем поиск, пока не ошибемся
DoEvents 'Не зависаем
ReDim Preserve FindArray(UBound(FindArray) + 1) 'Ресайзим массив на 1 больше прежнего
FindArray(UBound(FindArray)) = TempData 'Присвоение очередной порции информации
Loop Call FindClose(lngHandle) 'Побаловались да и хватит...
End Sub Public Sub ScanForFiles(ByVal StartPath As String, Pattern As String, Files() As String)
Dim i_s As Long, Dir1() As String, File1() As String, File As Long
File = UboundS(Files()) + 1 If Not Right$(StartPath, 1) = "\" Then StartPath = StartPath + "\"
DirBoxEmu StartPath, Dir1()
FileBoxEmu StartPath, File1(), Pattern
For i_s = 0 To UboundS(File1())
ReDim Preserve Files(i_s + File)
Files(i_s + File) = StartPath + File1(i_s)
DoEvents
Next
For i_s = 0 To UboundS(Dir1())
ScanForFiles StartPath + Dir1(i_s), Pattern, Files()
DoEvents
Next
End Sub Private Sub DirBoxEmu(ByVal sPath As String, sDir() As String)
Dim Data() As WIN32_FIND_DATA, i_d As Long, Counter As Long, TempName As String
Counter = -1 If Not Right$(sPath, 1) = "\" Then sPath = sPath + "\"
StartFind sPath + "*", Data() For i_d = 0 To UboundFind(Data())
TempName = Left(Data(i_d).cFileName, InStr(1, Data(i_d).cFileName, vbNullChar) - 1)
If Not TempName = "." And Not TempName = ".." Then
If IsFolder(Data(i_d).dwFileAttributes) Then
Counter = Counter + 1
ReDim Preserve sDir(Counter)
sDir(Counter) = TempName
End If
End If
DoEvents
Next
End Sub Private Sub FileBoxEmu(ByVal sPath As String, sFile() As String, Optional sFilter As String)
Dim Data() As WIN32_FIND_DATA, Repeat As Long, i_f As Long, j_f As Long, Counter As Long, Filters() As String, TempName As String
Counter = -1 If Not Right$(sPath, 1) = "\" Then sPath = sPath + "\" If Len(sFilter) = 0 Then
Repeat = 0
ReDim Filters(0): Filters(0) = "*"
Else
Filters() = Split(sFilter, ";")
Repeat = UboundS(Filters())
End If For j_f = 0 To Repeat
Erase Data()
StartFind sPath & Filters(j_f), Data() For i_f = 0 To UboundFind(Data())
TempName = Left(Data(i_f).cFileName, InStr(1, Data(i_f).cFileName, vbNullChar) - 1) If Not TempName = "." And Not TempName = ".." Then
If Not IsFolder(Data(i_f).dwFileAttributes) Then
Counter = Counter + 1 ReDim Preserve sFile(Counter)
sFile(Counter) = TempName
End If
End If
DoEvents
Next
Next
End Sub Private Function IsFolder(dwAttributes As Long) As Boolean
If (dwAttributes And &H10) = &H10 Then IsFolder = True
End Function Public Function UboundFind(Data() As WIN32_FIND_DATA) As Long
On Error GoTo Handler:
UboundFind = UBound(Data())
Exit Function
Handler:
UboundFind = -1
End Function Public Function UboundS(Data() As String) As Long
On Error GoTo Handler:
UboundS = UBound(Data())
Exit Function
Handler:
UboundS = -1
End Function
Ответить
|
__Сергей__
sne
__Сергей__
__Сергей__