DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Declare PtrSafe Function SearchTreeForFile Lib "imagehlp" (ByVal RootPath As String, _
ByVal InputPathName As String, ByVal OutputPathBuffer As String) As Long
'
Sub Test()
' Haluk - 21/10/2022
Dim tempStr As String, strFileName As String, strFile As String, RetVal As Long
Const MAX_PATH = 260
strFileName = "Test5001.xlsm"
tempStr = String(MAX_PATH, 0)
RetVal = SearchTreeForFile("C:\", strFileName, tempStr)
If RetVal <> 0 Then
strFile = Left(tempStr, InStr(1, tempStr, Chr(0)) - 1)
MsgBox "Dosya bu adreste bulundu: " & vbCrLf & vbCrLf & strFile
Kill strFile
MsgBox "Dosya silindi!"
Else
MsgBox "Aranan dosya bulunamadı!"
End If
End SubDeğerli hocam çok çok teşekkür ederim kod gayet iyi çalışıyor. Galiba bundan daha hızlı çalışamıyor.
Const MAX_PATH As Long = 260
Const INVALID_HANDLE_VALUE As Long = -1
Const FILE_ATTRIBUTE_ARCHIVE As Long = &H20
Const FILE_ATTRIBUTE_COMPRESSED As Long = &H800
Const FILE_ATTRIBUTE_DIRECTORY As Long = &H10
Const FILE_ATTRIBUTE_HIDDEN As Long = &H2
Const FILE_ATTRIBUTE_NORMAL As Long = &H80
Const FILE_ATTRIBUTE_READONLY As Long = &H1
Const FILE_ATTRIBUTE_TEMPORARY As Long = &H100
Const FILE_ATTRIBUTE_FLAGS = FILE_ATTRIBUTE_ARCHIVE Or FILE_ATTRIBUTE_HIDDEN Or FILE_ATTRIBUTE_NORMAL Or FILE_ATTRIBUTE_READONLY
Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
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
Declare PtrSafe Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Declare PtrSafe Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Declare PtrSafe Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Declare PtrSafe Function SearchTreeForFile Lib "imagehlp.dll" (ByVal sFileRoot As String, ByVal InputPathName As String, ByVal OutputPathBuffer As String) As Boolean
'
Sub Test2()
Dim arrFoundFiles() As String, i As Long, countFiles As Long
countFiles = FileSearch(arrFoundFiles, "C:\", "Test5001.xlsx", True)
For i = 1 To countFiles
MsgBox "Dosya bu adreste bulundu: " & vbCrLf & vbCrLf & arrFoundFiles(i)
Kill arrFoundFiles(i)
MsgBox "Dosya silindi!"
Next
End Sub
'
Function FileSearch(ByRef asMatchingFiles() As String, ByVal sRootPath As String, sSearchFor As String, Optional bRecursiveSearch As Boolean = True) As Long
Dim tFindFile As WIN32_FIND_DATA
Dim lNumFound As Long, lHwndFile As Long
Dim sItemName As String, sThisPath As String
Dim asDirs() As String, lNumDirs As Long, lThisDir As Long
Static sbRecursion As Boolean
On Error Resume Next
If sbRecursion = False Then
Erase asMatchingFiles
End If
If Right$(sRootPath, 1) <> "\" Then
sRootPath = sRootPath & "\"
End If
lNumFound = UBound(asMatchingFiles)
lHwndFile = FindFirstFile(sRootPath & "*", tFindFile)
If lHwndFile <> INVALID_HANDLE_VALUE Then
Do
If (tFindFile.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then
sItemName = Left$(tFindFile.cFileName, InStr(1, tFindFile.cFileName, vbNullChar) - 1)
If sItemName <> "." And sItemName <> ".." Then
lNumDirs = lNumDirs + 1
If lNumDirs = 1 Then
ReDim asDirs(1 To lNumDirs)
Else
ReDim Preserve asDirs(1 To lNumDirs)
End If
sThisPath = sRootPath & sItemName
asDirs(lNumDirs) = sThisPath
End If
Else
sItemName = Left$(tFindFile.cFileName, InStr(1, tFindFile.cFileName, vbNullChar) - 1)
If sItemName Like sSearchFor Then
lNumFound = lNumFound + 1
If lNumFound = 1 Then
ReDim asMatchingFiles(1 To 1)
Else
ReDim Preserve asMatchingFiles(1 To lNumFound)
End If
asMatchingFiles(lNumFound) = sRootPath & sItemName
End If
End If
Loop While FindNextFile(lHwndFile, tFindFile)
lHwndFile = FindClose(lHwndFile)
If bRecursiveSearch Then
For lThisDir = 1 To lNumDirs
sThisPath = asDirs(lThisDir)
sbRecursion = True
FileSearch asMatchingFiles, sThisPath, sSearchFor, bRecursiveSearch
sbRecursion = False
Next
End If
End If
FileSearch = UBound(asMatchingFiles)
End Function
Haluk hocam tam aradığım kod çok çok teşekkür ederim. Sağ olun var olun.. Aynı kodu kullanarak Test5001 ve Test5002 dosyalarını aratıp silebilir miyiz?
Sub Test3()
Dim arrFoundFiles() As String, i As Long, countFiles As Long
Dim arrFiles()
arrFiles = Array("Test5001.xlsx", "Test5002.xlsx")
For j = LBound(arrFiles) To UBound(arrFiles)
countFiles = FileSearch(arrFoundFiles, "C:\", CStr(arrFiles(j)), True)
For i = 1 To countFiles
MsgBox "Dosya bu adreste bulundu: " & vbCrLf & vbCrLf & arrFoundFiles(i)
Kill arrFoundFiles(i)
MsgBox "Dosya silindi!"
Next
Next
End SubHaluk hocam çok makbule geçti ne kadar sevindiğimi anlatamam. İlgi ve alakanıza çok minnettarım.
hocam özelden mesaj yazsam oradan görüşebilirmiyiz
Haluk hocam şimdi farkettim sadece C sürücüsünü tarıyor. Hem C sürücüsünü hem de D sürücüsünü aynı kodda taraması için ne yapabiliriz
Sub Test4()
Dim arrFoundFiles() As String, i As Long, countFiles As Long
Dim arrFiles(), FSO As Object, DriveCollection As Object
Dim xDrive As Object, myDrive As String
Set FSO = CreateObject("Scripting.FileSystemObject")
Set DriveCollection = FSO.Drives
For Each xDrive In DriveCollection
If FSO.GetDrive(xDrive).DriveType = 2 Then
myDrive = xDrive.DriveLetter & ":\"
' Benzer isimleri de yakalamak icin dosya adinin sonunda "*" kullaniyoruz....
arrFiles = Array("Test5001*.xlsx", "Test5002*.xlsx")
For j = LBound(arrFiles) To UBound(arrFiles)
countFiles = FileSearch(arrFoundFiles, myDrive, CStr(arrFiles(j)), True)
For i = 1 To countFiles
MsgBox "Dosya bu adreste bulundu: " & vbCrLf & vbCrLf & arrFoundFiles(i)
Kill arrFoundFiles(i)
MsgBox "Dosya silindi!"
Next
Next
End If
Next
End Sub
If FSO.GetDrive(xDrive).DriveType = 1 Or FSO.GetDrive(xDrive).DriveType = 2 And FSO.GetDrive(xDrive).IsReady ThenHocam kodlar çok işime yaradı, peki şu şekilde yapılabilse nasıl olur,
Haluk beyin kullandığı kodlamada path uzunluğu 260 karakterdir. Daha uzun path geldiğinde taşma olduğu için uygulamanız çöküyor. Aşağıdaki algoritmayı güvenle kullanabilirsiniz. (Eğer 1000 karakterden uzun path yoksa...
)Option Explicit
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type PartsOfInt64
Low As Long
High As Long
End Type
Private Type Int64
Curr As Currency
End Type
Public Enum FILE_ATTRIBUTES
FA_READONLY = &H1 'A file that is read-only. Applications can read the file, but cannot write to it or delete it. This attribute
'is not honored on directories.
FA_HIDDEN = &H2 'The file or directory is hidden. It is not included in an ordinary directory listing.
FA_SYSTEM = &H4 'A file or directory that the operating system uses a part of, or uses exclusively.
FA_DIRECTORY = &H10 'The handle that identifies a directory.
FA_ARCHIVE = &H20 'A file or directory that is an archive file or directory. Applications typically use this attribute to mark
'files for backup or removal.
FA_NORMAL = &H80 'A file that does not have other attributes set. This attribute is valid only when used alone.
FA_TEMPORARY = &H100 'A file that is being used for temporary storage. File systems avoid writing data back to mass storage if sufficient
'cache memory is available, because typically, an application deletes a temporary file after the handle is closed.
FA_COMPRESSED = &H800 'A file or directory that is compressed. For a file, all of the data in the file is compressed. For a directory,
'compression is the default for newly created files and subdirectories.
End Enum
Public 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 * 1000 'Over 260 chars with '\\?\'
cAlternate As String * 14
End Type
Public 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 Long
End Type
#If Win64 Then
Private Declare PtrSafe Function FindFirstFileA Lib "kernelbase" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As LongLong
Private Declare PtrSafe Function FindNextFileA Lib "kernelbase" (ByVal hFindFile As LongLong, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare PtrSafe Function FindClose Lib "kernelbase" (ByVal hFindFile As LongLong) As Long
#Else
Private Declare Function FindFirstFileA Lib "kernelbase" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFileA Lib "kernelbase" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernelbase" (ByVal hFindFile As Long) As Long
#End If
Private Declare PtrSafe Function FileTimeToSystemTime Lib "kernelbase" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
Private Declare PtrSafe Function FileTimeToLocalFileTime Lib "kernelbase" (lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long
Private retVal As Long, strFileName As String, fileData As WIN32_FIND_DATA
Private dateAndTime As Date, fileSize As Double, sysTime As SYSTEMTIME, localTime As FILETIME
'
Sub Test()
Dim t1 As Single, t2 As Single, results As Collection
t1 = Timer
Set results = FindFiles("D:\", "*.mkv", True)
t2 = Timer
MsgBox Round(t2 - t1, 2) & " seconds and founded count: " & results.Count
End Sub
Public Function FindFiles(ByVal strPath As String, ByVal strPattern As String, Optional ByVal recursive As Boolean = False) As Collection
Dim col As New Collection
PrivateFindFiles col, strPath, strPattern, recursive
Set FindFiles = col
End Function
Private Sub PrivateFindFiles(ByRef findResults As Collection, ByVal strPath As String, ByVal strPattern As String, Optional ByVal recursive As Boolean = False)
' Zeki Gürsoy
' 20.04.2024
'
#If Win64 Then
Dim hFile As LongLong
#Else
Dim hFile As Long
#End If
If Not Right$(strPath, 1) = "\" Then strPath = strPath & "\"
hFile = FindFirstFileA("\\?\" & strPath & strPattern, fileData)
If Not hFile = -1 Then 'INVALID_HANDLE_VALUE
Do
If Not (fileData.dwFileAttributes And FA_DIRECTORY) = FA_DIRECTORY Then
strFileName = Left$(fileData.cFileName, InStr(fileData.cFileName, vbNullChar) - 1)
findResults.Add strPath & strFileName
'***********************************************************************
'Can be add below lines...
'***********************************************************************
'fileSize = ToInt64(fileData.nFileSizeLow, fileData.nFileSizeHigh)
'FileTimeToLocalFileTime fileData.ftCreationTime, localTime
'FileTimeToSystemTime localTime, sysTime
'dateAndTime = DateSerial(sysTime.wYear, sysTime.wMonth, sysTime.wDay) + TimeSerial(sysTime.wHour, sysTime.wMinute, sysTime.wSecond)
'
End If
retVal = FindNextFileA(hFile, fileData)
Loop Until retVal = 0
retVal = FindClose(hFile)
End If
If Not recursive Then Exit Sub
hFile = FindFirstFileA("\\?\" & strPath & "*.*", fileData)
If Not hFile = -1 Then 'INVALID_HANDLE_VALUE
Do
If (fileData.dwFileAttributes And FA_DIRECTORY) = FA_DIRECTORY Then
strFileName = Left$(fileData.cFileName, InStr(fileData.cFileName, vbNullChar) - 1)
If Not strFileName = "." Then
If Not strFileName = ".." Then PrivateFindFiles findResults, strPath & strFileName, strPattern, recursive
End If
End If
retVal = FindNextFileA(hFile, fileData)
Loop Until retVal = 0
retVal = FindClose(hFile)
End If
End Sub
Private Function ToInt64(ByVal inLow As Long, ByVal inHigh As Long) As Double
'Zeki Gürsoy
'
Dim i64 As Int64, partsOf64 As PartsOfInt64
partsOf64.Low = inLow
partsOf64.High = inHigh
LSet i64 = partsOf64
ToInt64 = i64.Curr * 10000
End Function