goodman2681
سه شنبه 07 مهر 1388, 19:52 عصر
سلام
من این برنامه رو که از همین سایت گرفتم
و میخواستم دوستان زحمت تحلیلشو بکشن چون من تازه واردم و سر در نیوردم
Option Explicit
Dim AA As Integer
Dim a As Integer
Private Const FILE_ATTRIBUTE_READONLY = &H1
Private Const FILE_ATTRIBUTE_HIDDEN = &H2
Private Const FILE_ATTRIBUTE_SYSTEM = &H4
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const FILE_ATTRIBUTE_ARCHIVE = &H20
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_ATTRIBUTE_TEMPORARY = &H100
Private Const FILE_ATTRIBUTE_COMPRESSED = &H800
Private Const MAX_PATH = 260
Dim file_obj As New FileSystemObject
Dim selected_boll As Boolean
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 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 pbMessage As Boolean
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As Any, ByVal lpWindowName As Any) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" _
(ByVal lpLibFileName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, _
ByVal lpProcName As String) As Long
Private Declare Function CreateThread Lib "kernel32" (lpThreadAttributes As Any, _
ByVal dwStackSize As Long, ByVal lpStartAddress As Long, ByVal lParameter As Long, _
ByVal dwCreationFlags As Long, lpThreadID As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, _
ByVal dwMilliseconds As Long) As Long
Private Declare Function GetExitCodeThread Lib "kernel32" (ByVal hThread As Long, _
lpExitCode As Long) As Long
Private Declare Sub ExitThread Lib "kernel32" (ByVal dwExitCode As Long)
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Dim Reg As String, Success As Long
Dim mresult
Public Sub getfiles(Path As String, SubFolder As Boolean, Optional Pattern As String = "*.*")
'AA = 1
'Label4.Caption = "Searching ..."
Dim WFD As WIN32_FIND_DATA
Dim hFile As Long, fPath As String, fName As String
fPath = AddBackslash(Path)
Dim sPattern As String
sPattern = Pattern
fName = fPath & sPattern
hFile = FindFirstFile(fName, WFD)
If (hFile > 0) And ((WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> FILE_ATTRIBUTE_DIRECTORY) Then
lstFl.AddItem (fPath & StripNulls(WFD.cFileName))
End If
If hFile > 0 Then
While FindNextFile(hFile, WFD)
If AA = 1 Then
Label4.Caption = "Searching ..."
Label7.Caption = lstFl.ListCount
DoEvents
If ((WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> FILE_ATTRIBUTE_DIRECTORY) Then
lstFl.AddItem (fPath & StripNulls(WFD.cFileName))
End If
End If
Wend
End If
If SubFolder Then
hFile = FindFirstFile(fPath & "*.*", WFD)
If (hFile > 0) And ((WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY) And _
StripNulls(WFD.cFileName) <> "." And StripNulls(WFD.cFileName) <> ".." Then
getfiles fPath & StripNulls(WFD.cFileName), True, sPattern
End If
While FindNextFile(hFile, WFD)
If AA = 1 Then
If ((WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY) And _
StripNulls(WFD.cFileName) <> "." And StripNulls(WFD.cFileName) <> ".." Then
getfiles fPath & StripNulls(WFD.cFileName), True, sPattern
End If
End If
Wend
End If
FindClose hFile
End Sub
Private Function StripNulls(f As String) As String
StripNulls = Left$(f, InStr(1, f, Chr$(0)) - 1)
End Function
Private Function AddBackslash(S As String) As String
If Len(S) Then
If Right$(S, 1) <> "\" Then
AddBackslash = S & "\"
Else
AddBackslash = S
End If
Else
AddBackslash = "\"
End If
End Function
Function get_file_name(temp As String)
get_file_name = Right(temp, Len(temp) - InStrRev(temp, "\", Len(temp)))
End Function
Private Sub cmd_search_Click()
a = a + 1
If a = 1 Then
cmd_search.Caption = "&Stop"
AA = 1
Label4.Caption = "Searching ..."
Dim ar As Variant
Dim k As Integer
Dim temp As String
ar = Split(txt_patern.Text, ";", , vbTextCompare)
lstFl.Clear
For k = 0 To UBound(ar)
temp = ar(k)
If chk_sub_dir.Value = 1 Then
Call getfiles(Dir1.Path, True, temp)
Else
Call getfiles(Dir1.Path, False, temp)
End If
Next k
If AA = 1 And Label4.Caption <> "Searching Stopped" And Label4.Caption = "Searching ..." Then
Label4.Caption = "Search Completed."
cmd_search.Caption = "&Search"
a = 0
End If
ElseIf a = 2 Then
cmd_search.Caption = "&Search"
AA = 0
Label4.Caption = "Searching Stopped"
a = 0
End If
End Sub
Private Sub cmdDeleteall_Click()
Dim i As Long
On Error Resume Next
Me.MousePointer = 11
For i = 0 To lstFl.ListCount - 1
Kill lstFl.List(i)
Next i
lstFl.Clear
Me.MousePointer = 0
End Sub
Private Sub cmdnew_Click()
txt_patern.Text = "autoply.exe"
End Sub
Private Sub Command1_Click()
Dim a As Long
On Error Resume Next
Kill (lstFl.Text)
lstFl.RemoveItem (lstFl.ListIndex)
End Sub
Private Sub Command2_Click()
Shell "sfc.exe /scannow", vbNormalFocus
End Sub
Private Sub Dir1_Change()
File1.Path = Dir1.Path
End Sub
Private Sub Drive1_Change()
On Error GoTo errorH
If file_obj.DriveExists(Mid(Drive1.Drive, 1, 1)) Then
Dir1.Path = Drive1.Drive
End If
Exit Sub
errorH:
If Err.Number = 68 Then
MsgBox "Insert disk into " & Drive1.Drive & "\ drive", vbCritical, "Drive empty"
Drive1.Drive = "C:"
Dir1.Path = Drive1.Drive
Exit Sub
End If
MsgBox Err.Description & " #" & Err.Number
End Sub
Private Sub Form_Load()
AA = 1
End Sub
من این برنامه رو که از همین سایت گرفتم
و میخواستم دوستان زحمت تحلیلشو بکشن چون من تازه واردم و سر در نیوردم
Option Explicit
Dim AA As Integer
Dim a As Integer
Private Const FILE_ATTRIBUTE_READONLY = &H1
Private Const FILE_ATTRIBUTE_HIDDEN = &H2
Private Const FILE_ATTRIBUTE_SYSTEM = &H4
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const FILE_ATTRIBUTE_ARCHIVE = &H20
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_ATTRIBUTE_TEMPORARY = &H100
Private Const FILE_ATTRIBUTE_COMPRESSED = &H800
Private Const MAX_PATH = 260
Dim file_obj As New FileSystemObject
Dim selected_boll As Boolean
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 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 pbMessage As Boolean
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As Any, ByVal lpWindowName As Any) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" _
(ByVal lpLibFileName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, _
ByVal lpProcName As String) As Long
Private Declare Function CreateThread Lib "kernel32" (lpThreadAttributes As Any, _
ByVal dwStackSize As Long, ByVal lpStartAddress As Long, ByVal lParameter As Long, _
ByVal dwCreationFlags As Long, lpThreadID As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, _
ByVal dwMilliseconds As Long) As Long
Private Declare Function GetExitCodeThread Lib "kernel32" (ByVal hThread As Long, _
lpExitCode As Long) As Long
Private Declare Sub ExitThread Lib "kernel32" (ByVal dwExitCode As Long)
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Dim Reg As String, Success As Long
Dim mresult
Public Sub getfiles(Path As String, SubFolder As Boolean, Optional Pattern As String = "*.*")
'AA = 1
'Label4.Caption = "Searching ..."
Dim WFD As WIN32_FIND_DATA
Dim hFile As Long, fPath As String, fName As String
fPath = AddBackslash(Path)
Dim sPattern As String
sPattern = Pattern
fName = fPath & sPattern
hFile = FindFirstFile(fName, WFD)
If (hFile > 0) And ((WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> FILE_ATTRIBUTE_DIRECTORY) Then
lstFl.AddItem (fPath & StripNulls(WFD.cFileName))
End If
If hFile > 0 Then
While FindNextFile(hFile, WFD)
If AA = 1 Then
Label4.Caption = "Searching ..."
Label7.Caption = lstFl.ListCount
DoEvents
If ((WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> FILE_ATTRIBUTE_DIRECTORY) Then
lstFl.AddItem (fPath & StripNulls(WFD.cFileName))
End If
End If
Wend
End If
If SubFolder Then
hFile = FindFirstFile(fPath & "*.*", WFD)
If (hFile > 0) And ((WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY) And _
StripNulls(WFD.cFileName) <> "." And StripNulls(WFD.cFileName) <> ".." Then
getfiles fPath & StripNulls(WFD.cFileName), True, sPattern
End If
While FindNextFile(hFile, WFD)
If AA = 1 Then
If ((WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY) And _
StripNulls(WFD.cFileName) <> "." And StripNulls(WFD.cFileName) <> ".." Then
getfiles fPath & StripNulls(WFD.cFileName), True, sPattern
End If
End If
Wend
End If
FindClose hFile
End Sub
Private Function StripNulls(f As String) As String
StripNulls = Left$(f, InStr(1, f, Chr$(0)) - 1)
End Function
Private Function AddBackslash(S As String) As String
If Len(S) Then
If Right$(S, 1) <> "\" Then
AddBackslash = S & "\"
Else
AddBackslash = S
End If
Else
AddBackslash = "\"
End If
End Function
Function get_file_name(temp As String)
get_file_name = Right(temp, Len(temp) - InStrRev(temp, "\", Len(temp)))
End Function
Private Sub cmd_search_Click()
a = a + 1
If a = 1 Then
cmd_search.Caption = "&Stop"
AA = 1
Label4.Caption = "Searching ..."
Dim ar As Variant
Dim k As Integer
Dim temp As String
ar = Split(txt_patern.Text, ";", , vbTextCompare)
lstFl.Clear
For k = 0 To UBound(ar)
temp = ar(k)
If chk_sub_dir.Value = 1 Then
Call getfiles(Dir1.Path, True, temp)
Else
Call getfiles(Dir1.Path, False, temp)
End If
Next k
If AA = 1 And Label4.Caption <> "Searching Stopped" And Label4.Caption = "Searching ..." Then
Label4.Caption = "Search Completed."
cmd_search.Caption = "&Search"
a = 0
End If
ElseIf a = 2 Then
cmd_search.Caption = "&Search"
AA = 0
Label4.Caption = "Searching Stopped"
a = 0
End If
End Sub
Private Sub cmdDeleteall_Click()
Dim i As Long
On Error Resume Next
Me.MousePointer = 11
For i = 0 To lstFl.ListCount - 1
Kill lstFl.List(i)
Next i
lstFl.Clear
Me.MousePointer = 0
End Sub
Private Sub cmdnew_Click()
txt_patern.Text = "autoply.exe"
End Sub
Private Sub Command1_Click()
Dim a As Long
On Error Resume Next
Kill (lstFl.Text)
lstFl.RemoveItem (lstFl.ListIndex)
End Sub
Private Sub Command2_Click()
Shell "sfc.exe /scannow", vbNormalFocus
End Sub
Private Sub Dir1_Change()
File1.Path = Dir1.Path
End Sub
Private Sub Drive1_Change()
On Error GoTo errorH
If file_obj.DriveExists(Mid(Drive1.Drive, 1, 1)) Then
Dir1.Path = Drive1.Drive
End If
Exit Sub
errorH:
If Err.Number = 68 Then
MsgBox "Insert disk into " & Drive1.Drive & "\ drive", vbCritical, "Drive empty"
Drive1.Drive = "C:"
Dir1.Path = Drive1.Drive
Exit Sub
End If
MsgBox Err.Description & " #" & Err.Number
End Sub
Private Sub Form_Load()
AA = 1
End Sub