1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124
| Dim nowpath Dim arr(1000, 20), n
On Error Resume Next
Set ExcelApp = GetObject(, "Excel.Application") If ExcelApp Is Nothing Then Set ExcelApp = GetObject(, "KET.Application") If ExcelApp Is Nothing Then Set ExcelApp = GetObject(, "et.Application") If ExcelApp Is Nothing Then MsgBox "Run Excel or Kingsoft ET first.", vbInformation, "Information" WScript.Quit End If End If End If
Dim Workbook, ActiveSheet Set Workbook = ExcelApp.ActiveWorkbook Set ActiveSheet = Workbook.ActiveSheet
Dim MaxRow, MaxCol n=0 nowpath = SelectFolder(ExcelApp,Workbook) arr(0,0)="文件名称" arr(0,1)="文件相对路径" arr(0,2)="文件绝对路径" arr(0,3)="文件夹绝对路径" arr(0,4)="文件夹相对路径" arr(0,5)="文件名" arr(0,6)="修改时间" arr(0,7)="大小(kb)" arr(0,8)="扩展名"
Call Getfd(nowpath, nowpath, arr, n)
excelapp.activecell.resize(n+1,UBound(arr,2))=arr Function Getfd(pth, RelativePath, arr, n) Dim Fso Dim ff Dim f, fd Dim RelativePathLen, rpos, xdlj, arrResult, i Set Fso = CreateObject("scripting.filesystemobject") Set ff = Fso.GetFolder(pth) RelativePathLen = Len(RelativePath) Dim ii, j For Each f In ff.Files rpos = Mid(f, RelativePathLen + 2, Len(f) - RelativePathLen - 1) xdlj = "" arrResult = Split(rpos, "\") n = n + 1 For i = LBound(arrResult) To UBound(arrResult) - 1 arr(n, i + 8) = Trim(arrResult(i)) arr(o,i+8)=i+1 & "层目录" xdlj = xdlj & Trim(arrResult(i)) & "\" Next arr(n, 0) = Left(f.Name, InStrRev(f.Name, ".") - 1) arr(n, 1) = xdlj &f.Name arr(n, 2) = f arr(n, 3)=pth & "\" arr(n, 4) = xdlj arr(n, 5) = f.Name arr(n, 6) = Format_Time(f.DateLastModified, 4) arr(n, 7) = Int(f.Size / 1024) arr(n, 8) = Mid(f.Name, InStrRev(f.Name, ".") + 1, Len(f.Name)) Next For Each fd In ff.subfolders Call Getfd(fd, RelativePath, arr, n) Next End Function
Function SelectFolder(ExcelApp,Workbook) Dim aa With ExcelApp.FileDialog(4) .InitialFileName = Workbook.Path & "\" If .Show = -1 Then SelectFolder = .SelectedItems(1) End If End With End Function
Function Format_Time(s_Time, n_Flag) Dim y, m, d, h, mi, s Format_Time = "" If IsDate(s_Time) = False Then Exit Function y = cstr(year(s_Time)) m = cstr(month(s_Time)) If len(m) = 1 Then m = "0" & m d = cstr(day(s_Time)) If len(d) = 1 Then d = "0" & d h = cstr(hour(s_Time)) If len(h) = 1 Then h = "0" & h mi = cstr(minute(s_Time)) If len(mi) = 1 Then mi = "0" & mi s = cstr(second(s_Time)) If len(s) = 1 Then s = "0" & s Select Case n_Flag Case 1 Format_Time = y & "-" & m & "-" & d & " "& h &":" & mi &":" & s Case 2 Format_Time = y & "-" & m & "-" & d Case 3 Format_Time = h & ":" & mi & ":" & s Case 4 Format_Time = y & "年" & m & "月" & d & "日" Case 5 Format_Time = y & m & d End Select End Function
|