Поиск файлов с определенным расширением

[Ramzes]

Как найти все файлы в системе с определнным расширением(например *.txt) И засунуть их в ListBox?

[Alexanbar]

Использовать элемент управления FileList. Или использовать функцию Dir и заполнять ListBox самостоятельно.

[Alexanbar]

Уточнение: FileListBox - свойство Pattern

[Ramzes]

Самостоятельно это конечно хорошо, но мне нужно именно так как я написал в вовпросе!

[all]

примерно так:
поочередно перебераешь все файлы в папке или на диске
и заносишь имя каждого файла в переменную например а
далее пишешь:

Код: Выделить всё

If Right(a, 4) = ".txt" Then

    ......
    ......


End If


[A.A.Z.]

Добавь кнопку и ListBox

Код: Выделить всё

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 GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long

Const MAX_PATH = 260
Const MAXDWORD = &HFFFF
Const INVALID_HANDLE_VALUE = -1
Const FILE_ATTRIBUTE_ARCHIVE = &H20
Const FILE_ATTRIBUTE_DIRECTORY = &H10
Const FILE_ATTRIBUTE_HIDDEN = &H2
Const FILE_ATTRIBUTE_NORMAL = &H80
Const FILE_ATTRIBUTE_READONLY = &H1
Const FILE_ATTRIBUTE_SYSTEM = &H4
Const FILE_ATTRIBUTE_TEMPORARY = &H100

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
Function StripNulls(OriginalStr As String) As String
    If (InStr(OriginalStr, Chr(0)) > 0) Then
        OriginalStr = Left(OriginalStr, InStr(OriginalStr, Chr(0)) - 1)
    End If
    StripNulls = OriginalStr
End Function

Function FindFilesAPI(path As String, SearchStr As String, FileCount As Long, DirCount As Long)
    'KPD-Team 1999
    'E-Mail: KPDTeam@Allapi.net
    'URL: http://www.allapi.net/

    Dim FileName As String ' Walking filename variable...
    Dim DirName As String ' SubDirectory Name
    Dim dirNames() As String ' Buffer for directory name entries
    Dim nDir As Integer ' Number of directories in this path
    Dim I As Integer ' For-loop counter...
    Dim hSearch As Long ' Search Handle
    Dim WFD As WIN32_FIND_DATA
    Dim Cont As Integer
    If Right(path, 1) <> "\" Then path = path & "\"
    ' Search for subdirectories.
    nDir = 0
    ReDim dirNames(nDir)
    Cont = True
    hSearch = FindFirstFile(path & "*", WFD)
    If hSearch <> INVALID_HANDLE_VALUE Then
        Do While Cont
        DirName = StripNulls(WFD.cFileName)
        ' Ignore the current and encompassing directories.
        If (DirName <> ".") And (DirName <> "..") Then
            ' Check for directory with bitwise comparison.
            If GetFileAttributes(path & DirName) And FILE_ATTRIBUTE_DIRECTORY Then
                dirNames(nDir) = DirName
                DirCount = DirCount + 1
                nDir = nDir + 1
                ReDim Preserve dirNames(nDir)
            End If
        End If
        Cont = FindNextFile(hSearch, WFD) 'Get next subdirectory.
        Loop
        Cont = FindClose(hSearch)
    End If
    ' Walk through this directory and sum file sizes.
    hSearch = FindFirstFile(path & SearchStr, WFD)
    Cont = True
    If hSearch <> INVALID_HANDLE_VALUE Then
        While Cont
            FileName = StripNulls(WFD.cFileName)
            If (FileName <> ".") And (FileName <> "..") Then
                FindFilesAPI = FindFilesAPI + (WFD.nFileSizeHigh * MAXDWORD) + WFD.nFileSizeLow
                FileCount = FileCount + 1
                List1.AddItem path & FileName
                List1.Refresh
            End If
            Cont = FindNextFile(hSearch, WFD) ' Get next file
        Wend
        Cont = FindClose(hSearch)
    End If
    ' If there are sub-directories...
    If nDir > 0 Then
        ' Recursively walk into them...
        For I = 0 To nDir - 1
            FindFilesAPI = FindFilesAPI + FindFilesAPI(path & dirNames(I) & "\", SearchStr, FileCount, DirCount)
        Next I
    End If
End Function

Sub Command1_Click()
Dim I&, FileSize&, NumFiles&, NumDirs&, SearchPath$, NumFiles2&, NumDirs2&
Screen.MousePointer = vbHourglass
List1.Clear
For I = Asc("A") To Asc("Z")
SearchPath = Chr(I) & ":\"
FileSize = FindFilesAPI(SearchPath, "*.txt", NumFiles, NumDirs)
NumFiles2 = NumFiles2 + NumFiles: NumDirs2 = NumDirs2 + NumDirs
Next
DoEvents
MsgBox "Найдено " & NumFiles2 & " файлов *.txt в " & NumDirs2 + 1 & " папках"
Screen.MousePointer = vbNormal
End Sub

[Ramzes]

примерно так:
поочередно перебераешь все файлы в папке или на диске
и заносишь имя каждого файла в переменную например а
далее пишешь:
Код:

If Right(a, 4) = ".txt" Then

......
......


End If

А вот тут если можно поп подробнне

[A.A.Z.]

Ramzes, мой способ примерно так и делает...
В строчке "FileSize = FindFilesAPI(SearchPath, "*.txt", NumFiles, NumDirs)" просто заменяй *.txt на нужное раширение, и всё!
В принципе, можно использовать ф-цию Dir, если этот способ чем-то не устраивает.

[Ramzes]

Спасибо, буду пробовать ваш код... Может поможет

[Ramzes]

Добавь кнопку и ListBox

Код: Выделить всё

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 GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long

Const MAX_PATH = 260
Const MAXDWORD = &HFFFF
Const INVALID_HANDLE_VALUE = -1
Const FILE_ATTRIBUTE_ARCHIVE = &H20
Const FILE_ATTRIBUTE_DIRECTORY = &H10
Const FILE_ATTRIBUTE_HIDDEN = &H2
Const FILE_ATTRIBUTE_NORMAL = &H80
Const FILE_ATTRIBUTE_READONLY = &H1
Const FILE_ATTRIBUTE_SYSTEM = &H4
Const FILE_ATTRIBUTE_TEMPORARY = &H100

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
Function StripNulls(OriginalStr As String) As String
    If (InStr(OriginalStr, Chr(0)) > 0) Then
        OriginalStr = Left(OriginalStr, InStr(OriginalStr, Chr(0)) - 1)
    End If
    StripNulls = OriginalStr
End Function

Function FindFilesAPI(path As String, SearchStr As String, FileCount As Long, DirCount As Long)
    'KPD-Team 1999
    'E-Mail: KPDTeam@Allapi.net
    'URL: http://www.allapi.net/

    Dim FileName As String ' Walking filename variable...
    Dim DirName As String ' SubDirectory Name
    Dim dirNames() As String ' Buffer for directory name entries
    Dim nDir As Integer ' Number of directories in this path
    Dim I As Integer ' For-loop counter...
    Dim hSearch As Long ' Search Handle
    Dim WFD As WIN32_FIND_DATA
    Dim Cont As Integer
    If Right(path, 1) <> "" Then path = path & ""
    ' Search for subdirectories.
    nDir = 0
    ReDim dirNames(nDir)
    Cont = True
    hSearch = FindFirstFile(path & "*", WFD)
    If hSearch <> INVALID_HANDLE_VALUE Then
        Do While Cont
        DirName = StripNulls(WFD.cFileName)
        ' Ignore the current and encompassing directories.
        If (DirName <> ".") And (DirName <> "..") Then
            ' Check for directory with bitwise comparison.
            If GetFileAttributes(path & DirName) And FILE_ATTRIBUTE_DIRECTORY Then
                dirNames(nDir) = DirName
                DirCount = DirCount + 1
                nDir = nDir + 1
                ReDim Preserve dirNames(nDir)
            End If
        End If
        Cont = FindNextFile(hSearch, WFD) 'Get next subdirectory.
        Loop
        Cont = FindClose(hSearch)
    End If
    ' Walk through this directory and sum file sizes.
    hSearch = FindFirstFile(path & SearchStr, WFD)
    Cont = True
    If hSearch <> INVALID_HANDLE_VALUE Then
        While Cont
            FileName = StripNulls(WFD.cFileName)
            If (FileName <> ".") And (FileName <> "..") Then
                FindFilesAPI = FindFilesAPI + (WFD.nFileSizeHigh * MAXDWORD) + WFD.nFileSizeLow
                FileCount = FileCount + 1
                List1.AddItem path & FileName
                List1.Refresh
            End If
            Cont = FindNextFile(hSearch, WFD) ' Get next file
        Wend
        Cont = FindClose(hSearch)
    End If
    ' If there are sub-directories...
    If nDir > 0 Then
        ' Recursively walk into them...
        For I = 0 To nDir - 1
            FindFilesAPI = FindFilesAPI + FindFilesAPI(path & dirNames(I) & "", SearchStr, FileCount, DirCount)
        Next I
    End If
End Function

Sub Command1_Click()
Dim I&, FileSize&, NumFiles&, NumDirs&, SearchPath$, NumFiles2&, NumDirs2&
Screen.MousePointer = vbHourglass
List1.Clear
For I = Asc("A") To Asc("Z")
SearchPath = Chr(I) & ":"
FileSize = FindFilesAPI(SearchPath, "*.txt", NumFiles, NumDirs)
NumFiles2 = NumFiles2 + NumFiles: NumDirs2 = NumDirs2 + NumDirs
Next
DoEvents
MsgBox "Найдено " & NumFiles2 & " файлов *.txt в " & NumDirs2 + 1 & " папках"
Screen.MousePointer = vbNormal
End Sub

А где тут задавать имя папки?

[A.A.Z.]

Имя папки для поиска?

Убрать строчки "For I = Asc("A") To Asc("Z")" и, чуть ниже, "Next", а затем переменной SearchPath ("SearchPath = Chr(I) & ":\"") присвоить нужное значение.

[Ramzes]

т.е. Если я хочу искать в папке d:\music
то

Код: Выделить всё

SearchPath ("d:\music")


[A.A.Z.]

SearchPath = "D:\Music"

[Saturn.65]

А как сделать, чтоб при нахождении всех файлов с нужным расширением можно было бы применить к ним какое нибудь действие, например удалить?

[tyomitch]

Заменить вызов List1.AddItem на требуемое действие.

[Saturn.65]

Заменить вызов List1.AddItem на требуемое действие.

Мне бы примерчик. Я еще не особо силен.

[Wolfie]

А как сделать, чтоб при нахождении всех файлов с нужным расширением можно было бы применить к ним какое нибудь действие, например удалить?

ну смотря когда применять - можно ведь и сразу во время поиска файл грохать, а можно просто в лист добавлять с путем (я не вчитывался в код, возможно там так и делается) и дальше пребирая лист делать kill каждому элементу для удаления или чего атм еще такого хочется уже после нахождения...
я вроде и не заметил что тут уже 3 поста до меня ...

[Saturn.65]

Кстати, нашел еще пример поиска файлов. Он гораздо проще и тоже работает.

Код: Выделить всё

Private Sub Command1_Click()
SSpat = "D:" & "\" & "*.txt" & RaS
sFile = Dir$(SSpat)
While sFile <> ""
List1.AddItem sFile 'сюда добавит имена файлов
sFile = Dir$
Wend
End Sub


Лучше сперва их найти, а потом и грохнуть. А как сделать перебирание?

[Wolfie]

Код: Выделить всё

for x=0 to List1.ListCount-1
     kill List1.text 'файл уже никогда не вернется...
next x

Насчет дир - способ то прост, тока вот вернет он файлы для этой папки, и все равно придется мудрым способом (как в коде) еще учитывать вложенные папки, чтобы учесть именно все файлы такого-то типа в системе... ну а если и требуется просто найти все файлы в папке, то тут куда разумнее кинуть FileListBox , а не вручную ковыряться...

маленькая рекомендация - вместо "" для пустой строки использовать лучше vbNullString

[Saturn.65]

Код: Выделить всё

for x=0 to List1.ListCount-1
     kill List1.text 'файл уже никогда не вернется...
next x

А вот куда на форме это кинуть?

[Wolfie]

в процедуру кнопки "удалить", или туда где будет такая процедура... еще не забудь про то что Dim X as Integer надо написать перед циклом, и пользователя спросить... короче так вот:

Код: Выделить всё

Dim X as Integer
if msgbox("Правда удалить? ведь не восстановите потом! " _
                ,vbQuestion or vbYesNoCancel or vbdefaultButton3 _
                ,"Удаление...") = vbYes then
     for x=0 to List1.ListCount-1
         kill List1.text 'файл уже никогда не вернется...
     next x
end if

[tyomitch]

маленькая рекомендация - вместо "" для пустой строки использовать лучше vbNullString

Раз уж на то пошло, то сравнивать длину строки с нулём ещё лучше, чем её саму с пустой.

[Wolfie]

tyomitch разве быстрее вызвать функцию чем сравнить? но я тебе верю , учту. ктому же я не о сравнении говорил, а о том что в коде не стоит делать ""

[tyomitch]

Сравнение строк -- тоже вызов функции. Более сложной, чем для взятия длины строки.

[Saturn.65]

:D в процедуру кнопки "удалить", или туда где будет такая процедура... еще не забудь про то что Dim X as Integer надо написать перед циклом, и пользователя спросить... короче так вот:

Код: Выделить всё

Dim X as Integer
if msgbox("Правда удалить? ведь не восстановите потом! " _
                ,vbQuestion or vbYesNoCancel or vbdefaultButton3 _
                ,"Удаление...") = vbYes then
     for x=0 to List1.ListCount-1
         kill List1.text 'файл уже никогда не вернется...
     next x
end if

Пишет ошибку 53. Типа нет файла и показывает на строку:

Код: Выделить всё

kill List1.text 'файл уже никогда не вернется...

Может что в General прописать еще надо?

[alibek]

Нет. Надо List1.Text заменить на List1.List(x).

[Saturn.65]

Нет. Надо List1.Text заменить на List1.List(x).

Туже самую ошибку пишет.

[alibek]

Значит список заполнен неправильно. Кто будет путь указывать?

[Cytron]

ох как по теме. как раз месяц назад такой проект делал. работает без всяких API и довольно быстро. Найду - выложу.

[Saturn.65]

Кстате, о большем коде, который валожен в начале темы. Опробовал. Создал файл.txt и пустил его поиск. Мне нашло 365 этих файлов