ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
楼主: JXM

[下载]喜讯:文件目录管理加载宏一升再升,免费下载[下载]

[复制链接]

TA的精华主题

TA的得分主题

发表于 2013-7-28 09:51 | 显示全部楼层
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

TA的精华主题

TA的得分主题

发表于 2013-7-28 09:52 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
上面是模块一代码

TA的精华主题

TA的得分主题

发表于 2018-7-19 18:55 | 显示全部楼层
这个加载宏,一直用着的,上周通过远程帮同事的电脑加载了这个宏以后,就不能用了,有的文件夹里出现了附件中的两种情况 ,有的文件夹里又能用,卸载重新加载后问题还是存在,不知道 什么原因,求解。
微信图片_20180719110628.png
微信图片_20180719110740.png

TA的精华主题

TA的得分主题

发表于 2019-1-31 11:39 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
如何下载你的成果

TA的精华主题

TA的得分主题

发表于 2019-1-31 15:02 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2019-3-1 21:23 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2020-7-30 15:55 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-28 21:39 , Processed in 0.052845 second(s), 8 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表