2个回答
展开全部
查找某目录下所有 文件 及 子文件夹
试一试不用 FileSystemObject 对象,只用基本控件的代码。
'例子需控件:Command1,List1,List2,File1,Dir1,都采用默认属性。
'例如,查找 C:\ ,带 '** 的语可修改
Dim ctFind As Boolean
Private Sub Form_Load()
Me.Caption = "查找所有文件及文件夹"
Command1.Caption = "查找"
List2.Visible = False: File1.Visible = False: Dir1.Visible = False
Label1.Caption = "就绪"
End Sub
Private Sub Form_Unload(Cancel As Integer)
End
End Sub
Private Sub Form_Resize()
Dim W As Long
On Error Resume Next
W = 720
List1.Move 0, 0, Me.ScaleWidth - W - 120, Me.ScaleHeight - 300
Command1.Move Me.ScaleWidth - W - 60, 300, W
Label1.Move 90, Me.ScaleHeight - 255, Screen.Width, 255
End Sub
Private Sub Command1_Click()
ctFind = Not ctFind
If ctFind Then
Command1.Caption = "取消"
Call FindDirFile("C:") '**查找 C:\ 下的所有文件和目录,或 C:\Windows 等
Command1.Caption = "查找"
Else
Command1.Caption = "查找"
End If
End Sub
Private Sub FindDirFile(ByVal nPath As String)
Dim I As Long, nDir As String, Ci As Long
ctFind = True
List1.Clear: List2.Clear
If Right(nPath, 1) <> "\" Then nPath = nPath & "\"
List1.AddItem "查找 " & nPath: List2.AddItem nPath
File1.Pattern = "*"
File1.System = True: File1.Hidden = True: File1.ReadOnly = True
On Error GoTo Cuo
Dir1.Path = nPath
On Error GoTo 0
Do
If List2.ListCount = 0 Then Exit Do
nPath = List2.List(0)
List2.RemoveItem 0
Dir1.Path = nPath
For I = 0 To Dir1.ListCount - 1
GoSub ShowGe
nDir = Dir1.List(I)
If Right(nDir, 1) <> "\" Then nDir = nDir & "\"
List1.AddItem "■" & nDir
List2.AddItem nDir
Next
File1.Path = nPath
For I = 0 To File1.ListCount - 1
GoSub ShowGe
List1.AddItem " " & nPath & File1.List(I)
Next
Loop
Label1.Caption = "查找完毕,共找到 " & List1.ListCount & " 个条目"
ctFind = False
Exit Sub
Cuo:
List1.AddItem "起始目录不存在:" & nPath
ctFind = False
Exit Sub
ShowGe:
Ci = Ci + 1
If Ci < 99 Then Return
Ci = 0
Label1.Caption = "已找到 " & List1.ListCount & " 个:" & nPath
DoEvents
If ctFind Then Return
End Sub
试一试不用 FileSystemObject 对象,只用基本控件的代码。
'例子需控件:Command1,List1,List2,File1,Dir1,都采用默认属性。
'例如,查找 C:\ ,带 '** 的语可修改
Dim ctFind As Boolean
Private Sub Form_Load()
Me.Caption = "查找所有文件及文件夹"
Command1.Caption = "查找"
List2.Visible = False: File1.Visible = False: Dir1.Visible = False
Label1.Caption = "就绪"
End Sub
Private Sub Form_Unload(Cancel As Integer)
End
End Sub
Private Sub Form_Resize()
Dim W As Long
On Error Resume Next
W = 720
List1.Move 0, 0, Me.ScaleWidth - W - 120, Me.ScaleHeight - 300
Command1.Move Me.ScaleWidth - W - 60, 300, W
Label1.Move 90, Me.ScaleHeight - 255, Screen.Width, 255
End Sub
Private Sub Command1_Click()
ctFind = Not ctFind
If ctFind Then
Command1.Caption = "取消"
Call FindDirFile("C:") '**查找 C:\ 下的所有文件和目录,或 C:\Windows 等
Command1.Caption = "查找"
Else
Command1.Caption = "查找"
End If
End Sub
Private Sub FindDirFile(ByVal nPath As String)
Dim I As Long, nDir As String, Ci As Long
ctFind = True
List1.Clear: List2.Clear
If Right(nPath, 1) <> "\" Then nPath = nPath & "\"
List1.AddItem "查找 " & nPath: List2.AddItem nPath
File1.Pattern = "*"
File1.System = True: File1.Hidden = True: File1.ReadOnly = True
On Error GoTo Cuo
Dir1.Path = nPath
On Error GoTo 0
Do
If List2.ListCount = 0 Then Exit Do
nPath = List2.List(0)
List2.RemoveItem 0
Dir1.Path = nPath
For I = 0 To Dir1.ListCount - 1
GoSub ShowGe
nDir = Dir1.List(I)
If Right(nDir, 1) <> "\" Then nDir = nDir & "\"
List1.AddItem "■" & nDir
List2.AddItem nDir
Next
File1.Path = nPath
For I = 0 To File1.ListCount - 1
GoSub ShowGe
List1.AddItem " " & nPath & File1.List(I)
Next
Loop
Label1.Caption = "查找完毕,共找到 " & List1.ListCount & " 个条目"
ctFind = False
Exit Sub
Cuo:
List1.AddItem "起始目录不存在:" & nPath
ctFind = False
Exit Sub
ShowGe:
Ci = Ci + 1
If Ci < 99 Then Return
Ci = 0
Label1.Caption = "已找到 " & List1.ListCount & " 个:" & nPath
DoEvents
If ctFind Then Return
End Sub
展开全部
首先点击 工程——引用 勾选 microsoft scripting runtime
添加一个cmd按钮和 一个listbox,复制以下代码
Private Sub Command1_Click()
Findfolder "f:\" '设置搜索路径
End Sub
Private Sub Findfolder(ByVal mypath As String)
Dim fso As New FileSystemObject
Dim myfolder As Folder
Dim Item
mypath = IIf(Right(mypath, 1) = "\", mypath, mypath & "\")
Set myfolder = fso.GetFolder(mypath)
If myfolder.Files.Count > 0 Then
For Each Item In myfolder.Files
List1.AddItem fso.GetBaseName(Item)
DoEvents
Next
End If
If myfolder.SubFolders.Count > 0 Then
For Each Item In myfolder.SubFolders
List1.AddItem fso.GetBaseName(Item) '只获取文件夹名称,注意:如果文件夹名称包括若干个"."的话,只能获取最后一个点前面的字符
Call Findfolder(Item) '比如文件夹名为“11.22.33”那么读取出来就是"11.22"
DoEvents
Next
End If
End Sub
添加一个cmd按钮和 一个listbox,复制以下代码
Private Sub Command1_Click()
Findfolder "f:\" '设置搜索路径
End Sub
Private Sub Findfolder(ByVal mypath As String)
Dim fso As New FileSystemObject
Dim myfolder As Folder
Dim Item
mypath = IIf(Right(mypath, 1) = "\", mypath, mypath & "\")
Set myfolder = fso.GetFolder(mypath)
If myfolder.Files.Count > 0 Then
For Each Item In myfolder.Files
List1.AddItem fso.GetBaseName(Item)
DoEvents
Next
End If
If myfolder.SubFolders.Count > 0 Then
For Each Item In myfolder.SubFolders
List1.AddItem fso.GetBaseName(Item) '只获取文件夹名称,注意:如果文件夹名称包括若干个"."的话,只能获取最后一个点前面的字符
Call Findfolder(Item) '比如文件夹名为“11.22.33”那么读取出来就是"11.22"
DoEvents
Next
End If
End Sub
已赞过
已踩过<
评论
收起
你对这个回答的评价是?
推荐律师服务:
若未解决您的问题,请您详细描述您的问题,通过百度律临进行免费专业咨询