|
|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
Option Base 1
Option Explicit
Dim Fcnt, Rowcnt As Integer
Dim FN(), DN(), FNINSTEAD() As String
Dim EN() As Date
Dim lenA As Integer
Dim fs, f, f1, f2, fc As Object
Dim ColSubject As Variant
Dim UpdateRow() As Integer
Dim PADir, Drv As String
'----------------------------------------------
'本程序由江门建行蒋小明于20021105制作，版权所有
' 在EXCEL2000以上宿主程序上运行
'本工程引用以下库文件:
'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 As CommandBar
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
Set NewItem = CommandBars("文件目录工具栏").Controls.Add(Type:=msoControlButton)
With NewItem
.BeginGroup = True
.Caption = "执行批量改名"
.FaceId = 66
.OnAction = "批量改名"
.Style = msoButtonCaption
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) = 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 i As Integer
Dim TempDate As Date
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
ActiveSheet.Name = "文件目录"
Range("a1").Value = "文件路径"
Range("b1").Value = "文件名"
Range("c1").Value = "文件创建时间"
Range("d1").Value = "文件最后修改时间"
Rowcnt = 1
Drv = Left(PADir, 1)
ChDrive Drv
lenA = 0
Call ShowFileList(PADir)
Rowcnt = UBound(FN)
ReDim FNINSTEAD(Rowcnt)
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)
TempDate = FileDateTime(DN(i) & "\" & FN(i))
TempDate = IIf(TempDate < EN(i), TempDate, EN(i))
Cells(i + 1, 3) = Format(TempDate, "yyyy-mm-dd")
Cells(i + 1, 4) = Format(FileDateTime(DN(i) & "\" & FN(i)), "yyyy-mm-dd")
FNINSTEAD(i) = FN(i)
Next i
ActiveWorkbook.Worksheets(3).Activate
ActiveSheet.Name = "批量更名"
Range("a1").Value = "文件路径"
Range("b1").Value = "文件名"
Range("c1").Value = "更改后文件名"
For i = 1 To Rowcnt
Cells(i + 1, 1) = DN(i)
Cells(i + 1, 2) = FN(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 = 35
Columns("c:c").ColumnWidth = 10
Columns("d:d").ColumnWidth = 10
Range("a1").Select
Set fs = Nothing
Call 生成查询表
ActiveWorkbook.Worksheets("文件目录").Activate
Range("a1").CurrentRegion.Select
With Selection
.Font.FontStyle = "宋体"
.Font.Size = "9"
End With
Columns("a:a").ColumnWidth = 25
Columns("b:b").ColumnWidth = 35
Columns("c:c").ColumnWidth = 10
Columns("d:d").ColumnWidth = 10
Range("a1").Select
Exit Sub
ERRTEXT:
MsgBox Err.Description
End Sub
Sub 批量改名()
Dim i, j As Integer
Dim fss
ColSubject = Array("文件路径", "文件名", "文件创建时间", "文件最后修改时间")
On Error GoTo ERRTEXT
If Windows.Count = 0 Then
MsgBox "没有当前工作表"
Exit Sub
Else
For i = 1 To 4
If ActiveWorkbook.Worksheets("文件目录").Cells(1, i) <> ColSubject(i) Then
MsgBox "本程序只适用于自已生成的文件链接清单"
End
End If
Next i
Worksheets("批量更名").Activate
Set fss = CreateObject("Scripting.FileSystemObject")
j = 0
With ActiveSheet
For i = 1 To Rowcnt
If .Cells(i + 1, 3) <> "" Then
fss.GetFile(DN(i) & "\" & FN(i)).Name = Trim(.Cells(i + 1, 3))
FNINSTEAD(i) = Trim(.Cells(i + 1, 3))
.Cells(i + 1, 2) = Trim(.Cells(i + 1, 3))
.Cells(i + 1, 3) = ""
'最好是采用队列结构，储存已修改文件行。
j = j + 1
End If
Next i
End With
If j = 0 Then
MsgBox "请到'批量更名'工作表上指定文件的新名称"
Else
ActiveWorkbook.Worksheets("文件目录").Activate
For i = 1 To Rowcnt
If FNINSTEAD(i) <> FN(i) Then
FN(i) = FNINSTEAD(i)
ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Cells(i + 1, 2), Address:= _
DN(i) & "\" & FN(i), TextToDisplay:=FN(i)
ActiveSheet.Cells(i + 1, 3) = EN(i)
ActiveSheet.Cells(i + 1, 4) = Format(FileDateTime(DN(i) & "\" & FN(i)), "yyyy-mm-dd")
End If
Next i
MsgBox "更名成功,共更改了" & j & "个文件名"
Range("a1").Select
End If
End If
Set fss = Nothing
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 |
|
楼主: JXM
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2013-7-28 09:51
