'****************开始******************
Option Explicit
Public fso, CurrentName, CurrentPath, Extension
Dim Response, Answer, Result, Begin, Over


'-----初始化常量
Set fso=CreateObject("Scripting.FileSystemObject")
CurrentName=WScript.ScriptFullName    '获取FileList.vbs当前完整路径名称
CurrentPath=Left(CurrentName,InstrRev(CurrentName,"\"))    '获取当前所在完整文件夹名称
Extension=":iso:bin:zip:exe:"      '预定被搜索文件的后缀名
Result=";文件列手(FileLister)v0.1(2005-01-09)由'MBE Player'制作。版权所有，免费使用。" & vbCrLf & ";" & vbCrLf


'-----询问是否还要添加其他后缀名,并处理返回的信息：重新输入或退出程序
Do
Do
  Extension=InputBox("●默认搜索 .iso,.bin,.exe,.zip 文件。" & vbCrLf & "●可以在下栏中更改和添加后缀名。" & vbCrLf & "●注意用英文冒号“:”分隔各后缀名。" & vbCrLf & "●不支持通配符，但可以用一个英文“*”指示搜索所有文件。" & vbCrLf & "●错误的输入将造成无法预料的后果，不过在执行之前你还有机会回到这里重新输入。","输入欲搜索的后缀名","iso:bin:exe:zip:img:rar")
  If Extension="" Then
    Response=MsgBox ("没有指定后缀名" & vbCrLf & "你是想重新输入还是想退出洗手不干？",vbRetryCancel or vbCritical or vbDefaultButton2,"错误：没有指定后缀名！")
    If Response=vbCancel Then
      GameOver
    End If
  End If
Loop While Extension="" and Response=vbRetry
Extension=":" & Extension

'-----在执行操作之前的最后一次确认
Response=MsgBox ("将列出：" & Replace(Extension,":"," .",vbTextCompare) & " 文件。" & vbCrLf & vbCrLf & Space(8) & "是 ===> 继续" & vbCrLf & Space(8) & "否 ===> 重新输入" & vbCrLf & Space(6) & "取消 ===> 退出程序",3 Or 32,"准备好了吗")
If Response=2 Then    'vbCacel不继续就停止
  GameOver
End If
Loop While Response=7   'vbRetry则返回重新输入，vbYes(=1)则跳出循环，继续下面。


'-----开始计时
Begin=Time

'-----递归搜索文件并列出相关信息
If InStr(1,Extension,"*",vbTextCompare)>1 Then
  RecurSearchAll fso.GetFolder(CurrentPath)
Else
  RecurSearch fso.GetFolder(CurrentPath)
End If

'-----计算并显示费时
Over=Time
MsgBox "用时：" & TimeSpend(Begin,Over) & vbCrLf & "结果将保存在当前目录下FileList.TxT中。", 64


'-----形成FileList.TXT文件然后打开
SaveResult (Result)

'-----结束
GameOver

'*************主程序结束***************
'
'+++++++++++++过程与函数+++++++++++++++
'
'-----过程：递归搜索子目录并对指定后缀名文件列表
'//先判断文件夹内是否有文件，有则调用List，再判断是否有文件夹，有则调用自身，由此实现递归搜索。
Sub RecurSearch (objFolder)
  Dim SubFolder
  If objFolder.Files.Count>0 Then
    List (objFolder)
  End If
  If objFolder.SubFolders.Count>0 Then
    For Each SubFolder in objFolder.SubFolders
      RecurSearch SubFolder      '调用自身，递归循环
    Next
  End If
End Sub

'-----过程：递归搜索子目录并对所有文件列表
'//先判断文件夹内是否有文件，有则调用ListAll，再判断是否有文件夹，有则调用自身，由此实现递归搜索。
Sub RecurSearchAll (objFolder)
  Dim File, FileSize, Attribute, DateTimeLastModified, SubFolder
  If objFolder.Files.Count>0 Then
    For Each File in objFolder.Files
      FileSize=";" & MaskNumber(File.Size) & Space(3)
      Attribute=CheckAttribs(File.Attributes)
      DateTimeLastModified=Mask(DateValue(File.DateLastModified),"-") & " " & Mask(TimeValue(File.DateLastModified),":")
      Result=Result & FileSize & DateTimeLastModified & Space(3) & Attribute & fso.GetAbsolutePathName(File) & vbCrLf
    Next
  End If
  If objFolder.SubFolders.Count>0 Then
    For Each SubFolder in objFolder.SubFolders
      RecurSearchAll SubFolder
    Next
  End If
End Sub

'-----函数:对目录内文件列表
'//接受一个文件夹对象，对里面符合筛选条件的文件进行详细列表，结果将累积存放在全局变量'Result'里。
Sub List (objFolder)
  Dim File, FileSize, Attribute, DateTimeLastModified
  For Each File in objFolder.Files
    If InStr(1,Extension,fso.GetExtensionName(File),vbTextCompare)>1 Then   '过滤出指定类型的文件再列表
      FileSize=";" & MaskNumber(File.Size) & Space(3)
      Attribute=CheckAttribs(File.Attributes)
      DateTimeLastModified=Mask(DateValue(File.DateLastModified),"-") & " " & Mask(TimeValue(File.DateLastModified),":")
      Result=Result & FileSize & DateTimeLastModified & Space(3) & Attribute & fso.GetAbsolutePathName(File) & vbCrLf
    End If
  Next
End Sub


'-----函数：格式化字节数
'//接受一串数字，从个位起每三位用","分组，串前面填空格直到整串长度为13。
Function MaskNumber(Bytes)
  MaskNumber=FormatNumber(Bytes,0,-1,0,-1)
  Do Until Len(MaskNumber)>13
    MaskNumber=" " & MaskNumber
  Loop
End Function


'-----过程：格式化日期和时间
'//接受短日期或长时间类型变量，接受一个指定的分隔符，将日期时间格式化成：'YY-MM-DD hh:mm:ss' 形式。
Function Mask(DateTime,Delimiter)
  Dim Element
    For Each Element in Split(DateTime,Delimiter)
      If Len(Element)<2 Then
        Do Until Len(Element)=2
          Element="0" & Element
        Loop
      Else
        Element=Right(Element,2)
      End If
      Mask=Mask & Delimiter & Element
    Next
  Mask=Mid(Mask,2)
End Function


'-----函数：检出文件属性
'//接受字节型的文件属性，内部以数组形式定义了各字节的含义，循环地用and逻辑去试。后面填空格使结果的串长度为7。
Function CheckAttribs(Attribute)
  Dim Description, x, Attribs
  Description=Split("R;H;S;Drv;Fld;A;Lnk;128;256;512;1024;Cprs;4096;8192",";")
  For x=0 to 13
    If (Attribute and 2^x) Then
      Attribs=Attribs & UCase(Description(x))
    End If
  Next
  Do While Len(Attribs)<7
    Attribs=Attribs & " "
  Loop
  CheckAttribs=Attribs
End Function


'-----过程：排序
'Sub Sort(Text)

'
'
'End Sub


'-----过程：将列表结果存盘并打开
'//接受全局变量Result中的结果，存为FileList.TxT文件，并打开查看。
Sub SaveResult (Result)
  Dim filelist, openFileList
  Set filelist=fso.CreateTextFile(CurrentPath & "FileList.TxT",True)
  filelist.Write(Result)
  filelist.Close
  Set openFileList=CreateObject("WScript.Shell")
  OpenFileList.Run "FileList.TxT"
  Set openFileList=Nothing
End Sub


'-----函数：计算时间间隔
'//用结束时间Over减起始时间Begin，换算成hh:mm:ss形式，并返回字串到函数值。
Function TimeSpend(Begin,Over)
Dim Start, i, HowLong
Start=Split(Begin,":")
HowLong=Split(Over,":")
For i=0 to 2
  HowLong(i)=HowLong(i)-Start(i)
  If HowLong(i)<0 Then
    HowLong(i)=HowLong(i)+60
    HowLong(i-1)=HowLong(i-1)-1
  End If
'  TimeSpend=TimeSpend & ":" & HowLong(i)
Next
'  TimeSpend=Mid(TimeSpend,2) & Space(6)
''  TimeSpend=HowLong(1) & "′" & HowLong(2) & "″" & Space(9)
  TimeSpend=HowLong(1) & "′" & HowLong(2) & "″" & Space(9)
  TimeSpend=HowLong(1) & "分" & HowLong(2) & "秒" & Space(9)
End Function

'-----过程：结束时善后处理
Sub GameOver
  Set fso=Nothing
  WScript.Quit
End Sub
'+++++++++++过程与函数结束+++++++++++++
本文出自 51CTO.COM技术博客