文件目录管理程序，欢迎大家使用。[下载]

whwufanqi

Option Base 1
Option Explicit Dim Fcnt, Rowcnt As Integer
Dim FN(), DN() As String
Dim EN() As Date
Dim lenA As Integer
Dim fs, f, f1, f2, fc As Object
Public Declare Function GetPath Lib "gdi32" (ByVal hdc As Long, lpPoint As POINTAPI, lpTypes As Byte, ByVal nSize As Long) As Long
Public Type POINTAPI
x As Long
y As Long
End Type
'本工程引用以下库文件:
'Visual Basic for Application(VBA)
'MS EXCEL9.0 OBJECT LIABRARY(EXCEL9.0I)
'MS FORMS 2.0 OBJECT LIABRARY(FM20.DLL)
'MS OFFICES 9.0 OBJECT LIABRARY(MSO9.DLL)
'
'






Sub 创建工具栏()

On Error GoTo ERRTEXT
Dim JXMBAR
Dim NewItem


For Each JXMBAR In CommandBars
If JXMBAR.Name = "文件目录工具栏" Then
Application.CommandBars("文件目录工具栏").Delete
End If
Next

Application.CommandBars.Add(Name:="文件目录工具栏").Visible = True
With CommandBars("文件目录工具栏")
.Position = msoBarFloating
End With

Set NewItem = CommandBars("文件目录工具栏").Controls.Add(Type:=msoControlButton)
With NewItem
.BeginGroup = True
.Caption = "生成文件目录管理库"
.FaceId = 66
.OnAction = "生成文件目录"
.Style = msoButtonCaption
End With
Exit Sub
ERRTEXT:
MsgBox Err.Description End Sub
Sub ShowFileList(ByVal folderspec As String)


Dim i, Fcnt, LenArray1 As Integer


' Set fs = CreateObject("Scripting.FileSystemObject")

If fs.FolderExists(folderspec) Then
Set f = fs.GetFolder(folderspec)
Set fc = f.Files

If lenA = 0 Then
LenArray1 = 0
Else
LenArray1 = UBound(FN)
End If

Fcnt = fc.Count

If Fcnt > 0 Then
lenA = 1
End If

ReDim Preserve FN(LenArray1 + Fcnt)
ReDim Preserve DN(LenArray1 + Fcnt)
ReDim Preserve EN(LenArray1 + Fcnt)

i = 1
For Each f1 In fc
FN(LenArray1 + i) = f1.Name
DN(LenArray1 + i) = fs.GetParentFolderName(f1)
EN(LenArray1 + i) = VBA.Format(f1.datecreated, "yyyy-mm-dd")
i = i + 1
Next


Set fc = f.SubFolders
For Each f2 In fc
Call ShowFileList(f2)
Next
End If
End Sub
Sub 生成文件目录() Dim PADir, Drv As String
Dim i As Integer On Error GoTo ERRTEXT

Set fs = CreateObject("Scripting.FileSystemObject")



PADir = fs.GetParentFolderName(SelFileN)

Workbooks.Add

ActiveWorkbook.SaveAs FileName:=SaveXlFile, _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWindow.WindowState = xlMaximized


ActiveSheet.Range("a1").Select

Range("a1").Value = "文件路径"
Range("b1").Value = "文件名"
Range("c1").Value = "文件创建时间"
Range("d1").Value = "文件最后修改时间"

Rowcnt = 1
Drv = VBA.Left(PADir, 1)
ChDrive Drv
lenA = 0


Call ShowFileList(PADir)

Rowcnt = UBound(FN)
For i = 1 To Rowcnt

Cells(i + 1, 1) = DN(i)
ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Cells(i + 1, 2), Address:= _
DN(i) & "\" & FN(i), TextToDisplay:=FN(i)

Cells(i + 1, 3) = VBA.Format(FileDateTime(DN(i) & "\" & FN(i)), "yyyy-mm-dd")
Cells(i + 1, 4) = EN(i)

Next i


Range("a1").CurrentRegion.Select
With Selection
.Font.FontStyle = "宋体"
.Font.Size = "9"
End With
Columns("a:a").ColumnWidth = 25
Columns("b:b").ColumnWidth = 45
Columns("c:c").ColumnWidth = 12
Columns("d:d").ColumnWidth = 12

Range("a1").Select

Exit Sub
ERRTEXT:
MsgBox Err.Description End Sub Function SaveXlFile()
Dim FileSaveN FileSaveN = Application.GetSaveAsFilename( _
fileFilter:="Excel Files (*.xls), *.xls")
If FileSaveN <> False Then
If dir(FileSaveN) <> "" Then
MsgBox "不能与现有文件重名，本程序不支持覆盖"
End
Else
SaveXlFile = FileSaveN

End If
Else
MsgBox "你放弃保存文件,即是退出程序"
End
End If End Function Function SelFileN()
Dim FileToOpen
FileToOpen = Application _
.GetOpenFilename("all Files (*.*), *.*", , "请选取待选目录中任意一个文件(不要选取目录),以便程序取得该文件的父目录", , False) If FileToOpen <> False Then SelFileN = FileToOpen Else
MsgBox "你放弃了选择目录！程序将退出"
End
End If End Function

whwufanqi

工程密码：31HH

gvntw

好，谢谢！

zhwb

在增加多个目录就更好了。

lb5221111

辛苦了蛮好用的，恒久远了

syzl31

收下了，好东东，谢谢楼主！

slhenry

哈哈！现在才发现这个好东东，代码取到了，要多谢ldhyob呢。

劍魔

謝謝！辛苦了，送你一個精華。

mtwjjz

怎么看不到附件，难道要回复？

zhzhang9756

是呀，我也没看到，回复看看