HTML: <%'服务器超时设置 Response.Buffer = False Server.ScriptTimeOut = 9999 ' 错误处理 On error Resume next %> <html> <head> <title>::. 硬盘目录罗列脚本 .::</title> <meta http-equiv="Content-Type" content="text/html; charset=GB2312" /> <STYLE type=text/css> Body {FONT-SIZE: 12px; FONT-FAMILY: "Verdana", "Arial", "Helvetica", "sans-serif"} A {COLOR: #000000; TEXT-DECORATION: none} </STYLE> </head> <body> <form action="?" method="post"> 目录: <input type="text" name="ListPath" size="20">比如:d:/WEB(注意目录是否存在,可以跨盘符)<br> 类型: <input type="text" name="FileType" size="20">.asp(注意不要忘记.)<br> 层数: <input type="text" name="Depth" size="20">(1 2 3 这样的数字)<br> 参数: <input type="checkbox" name="Param" value="file" checked> 列文件 <input type="checkbox" name="Param1" value="txtlog" checked> 生成txt <input type="checkbox" name="Param2" value="scrout" checked> 屏幕输出<br> <input type="submit" value=" 发 送 "> </form> <script language="JavaScript"> <!-- window.status = "目录罗列脚本" function document.onstop(){ window.status = "罗列目录中断!" window.setTimeout("window.clearInterval(Timer);", 1000); } //--> </script> <% Dim ListPath, Depth, CurDepth ListPath = Replace(Request.Form("ListPath"), "/", "\") If Not ListPath = Empty Then %> <script language="JavaScript"> <!-- window.status = "服务器正在列目录,请稍候 ..." Timer = window.setInterval("window.scroll(0, document.body.scrollHeight);", 50); //--> </script> <% If Right(ListPath, 1) <> "\" Then ListPath = ListPath & "\" If Not Request.Form("Depth") = "" Then Depth = Int(Request.Form("Depth")) FileType = LCase(Request.Form("FileType")) Param = Request.Form("Param") Param1 = Request.Form("Param1") Param2 = Request.Form("Param2") Set ListParentObject = Server.CreateObject("Scripting.FileSystemObject") If Len(ListPath) <= 4 Then '检查路径d:/ 最少不能小于4,检查驱动器路径 If ListParentObject.DriveExists(ListPath) Then Set ListDriveObject = ListParentObject.GetDrive(ListPath) If ListDriveObject.IsReady = True Then Set ListPathObject = ListDriveObject.RootFolder Else errmsg = "<br>对不起,当前驱动器未准备就绪!" ErrOccur(errmsg) Response.End End If Else errmsg = "<br>对不起,当前驱动器不存在!" ErrOccur(errmsg) Response.End End If Else '检查路径是否存在 If ListParentObject.FolderExists(ListPath) Then Set ListPathObject = ListParentObject.GetFolder(ListPath) Else errmsg = "<br>对不起,当前路径不存在!" ErrOccur(errmsg) Response.End End If End If If Param1 = "txtlog" Then '如果写入txt,被选上的话,生成txt的文件列表 'txt将放在list目录下,如果不存在改目录,请手工建立 'txt的命名将由搜索的路径决定 Set FSO = Server.CreateObject("Scripting.FileSystemObject") Set FO = FSO.CreateTextFile(Server.MapPath("list/" & Replace(Replace(ListPath, "\", "-"), ":", "-") & ".txt")) End If Response.Write "<font color=""brown"">▊</font> 目录 " Response.Write "<font color=""green"">▊</font> 文件<br><br>" Response.Write "<b><font color=""red"">[" & ListPath & "]</font></b><br>" If Param1 = "txtlog" Then FO.Write(ListPath) & VbCrLf Call ListAllPath(ListPath, "0", False) Response.Write "<br><br><b><font color=""red"">目录罗列完毕!</font></b>" %> <script language="JavaScript"> <!-- window.status = "目录罗列完毕!" window.setTimeout("window.clearInterval(Timer);", 1000); //--> </script> <% '关闭FSO If Param1 = "txtlog" Then Set FO = Nothing Set FSO = Nothing End If End If %> </body> </html> <% '建立目录树的函数 Function ListAllPath(byval CurPath, byval Symbol, byval LastFolder) Dim CurFolderIndex CurFolderIndex = 0 CurDepth = CurDepth + 1 If LastFolder = True Then Symbol = Symbol & "1" Else Symbol = Symbol & "2" End If If Depth <> "" Then If CurDepth >= Depth + 1 Then Exit Function End If If Len(ListPath) <= 4 Then Set ListDriveObject = ListParentObject.GetDrive(CurPath) Set ListPathObject = ListDriveObject.RootFolder Else Set ListPathObject = ListParentObject.GetFolder(CurPath) End If If InStr(Param, "file") > 0 Then Call ListAllFile(CurPath, Symbol, LastFolder) TotalFolderNum = ListPathObject.SubFolders.Count For Each ListPath In ListPathObject.SubFolders CurFolderIndex = CurFolderIndex + 1 If ListPath.Attributes <> 22 Then If ListPath.Size <= 1024 Then PathSize = 1 Else PathSize = FormatNumber(ListPath.Size/1024,0) End If StrTemp = Nums2Symbols(Mid(Symbol, 3)) '判断三个条件各自存在的情形 If Param2 = "scrout" Then Response.Write StrTemp If Param1 = "txtlog" Then FO.Write(StrTemp) If CurFolderIndex = TotalFolderNum Then If Param2 = "scrout" Then Response.Write("└─") If Param1 = "txtlog" Then FO.Write("└─") LastFolder1 = True Else If Param2 = "scrout" Then Response.Write("├─") If Param1 = "txtlog" Then FO.Write("├─") LastFolder1 = False End If If Param2 = "scrout" Then Response.Write("<font color=""brown"">" & ListPath.Name & " " & PathSize & "KB</font><br>") If Param1 = "txtlog" Then FO.Write(ListPath.Name & " " & PathSize & "KB" & VbCrLf) Call ListAllPath(ListPath, Symbol, LastFolder1) CurDepth = CurDepth - 1 Else If CurFolderIndex = TotalFolderNum Then If Param2 = "scrout" Then Response.Write("└─") If Param1 = "txtlog" Then FO.Write("└─") LastFolder1 = True Else If Param2 = "scrout" Then Response.Write("├─") If Param1 = "txtlog" Then FO.Write("├─") LastFolder1 = False End If '判断是否为系统文件夹 If Param2 = "scrout" Then Response.Write("<font color=""brown"">" & ListPath.Name & " 系统文件夹</font><br>") If Param1 = "txtlog" Then FO.Write(ListPath.Name & " 系统文件夹" & VbCrLf) End If Next End Function '罗列目录 Function ListAllFile(byval CurPath, byval Symbol, byval LastFolder) Set ListFileObject = ListParentObject.GetFolder(CurPath) TotalFolderNum = ListFileObject.SubFolders.Count For Each ListFile In ListFileObject.Files If ListFile.Size <= 1024 Then FileSize = 1 Else FileSize = FormatNumber(ListFile.Size/1024,0) End If If InStr(ListFile.Name, ".") Then FType = ListParentObject.GetExtensionName(ListFile.Name)'Mid(ListFile.Name, InstrRev(ListFile.Name, ".")) End If If Instr(FileType, LCase(FType)) > 0 Or FileType = "" Then StrTemp = Nums2Symbols(Mid(Symbol, 3)) If Param2 = "scrout" Then Response.Write(StrTemp) If Param1 = "txtlog" Then FO.Write(StrTemp) If TotalFolderNum = 0 Then If Param2 = "scrout" Then Response.Write("") If Param1 = "txtlog" Then FO.Write("") Else If Param2 = "scrout" Then Response.Write("│") If Param1 = "txtlog" Then FO.Write("│") End If '将下一级的目录加上颜色区别 If Param2 = "scrout" Then Response.Write("<font color=""green"">" & ListFile.Name & " " & FileSize & "KB</font><br>") If Param1 = "txtlog" Then FO.Write(ListFile.Name & " " & FileSize & "KB" & VbCrLf) End If Next End Function '生成分隔条 Function Num2Symbol(byval Num) Select Case Num Case 0 Num2Symbol = " " Case 1 Num2Symbol = "" Case 2 Num2Symbol = "│" End Select End Function Function Nums2Symbols(byval Num) i = Len(Num) While i > 0 Nums2Symbols = Nums2Symbols & Num2Symbol(Left(Num, 1)) Num = Mid(Num, 2) i = i - 1 Wend End Function '错误提示 Sub ErrOccur(byval errmsg) If Param2 = "scrout" Then Response.Write "<font color=""red"">" & errmsg & "</font>" %> <script language="JavaScript"> <!-- window.status = "罗列目录出错!" window.setTimeout("window.clearInterval(Timer);", 1000); //--> </script> </body> </html> <% End Sub%>