楼主
nothingwmm |
利用Excel 生成用户指定文件夹下用户指定类型的文件，并可形成自由的超链接，便于查找特定类型的文件或文件整理。程序部分源代码非原创。
------------------------------------------
Thisworkbook里面代码：- Private Sub Workbook_Open()
- Worksheets("sheet1").Visible = True
- Worksheets("sheet2").Visible = True
- Worksheets("sheet3").Visible = True
- Call Menudel
- Call MenuChoose.Show
- End Sub
- '以下代码由 James Zhou @tust2010 创建
- Sub Menudel()
- Dim msg As VbMsgBoxResult
- For Each Sh In ThisWorkbook.Worksheets
- If Sh.Name = "文件清单" Then msg = MsgBox("清单已经存在，是否覆盖", vbYesNo, "请仔细确认是否覆盖清单")
- If msg = vbYes Then
- On Error GoTo 0
- Sheets("文件清单").Cells.Delete
- Else
- Exit For
- End If
- Next
- End Sub
- ' 以上代码由 James Zhou @tust2010 创建
-------------------------------------------
模块里面的代码：- Sub MenubyJamesZhou()
- Dim MyName, Dic, Did, I, T, F, TT, MyFileName
- Dim filestyle1, filestyle2, filetype3, rowscount1, pos1 As Integer
- Dim strtest As String
- Set objShell = CreateObject("Shell.Application")
- If Not objFolder Is Nothing Then lj = objFolder.self.Path & "\"
- Set objFolder = Nothing
- Set objShell = Nothing
- T = Timer
- Set Dic = CreateObject("Scripting.Dictionary")
- Set Did = CreateObject("Scripting.Dictionary")
- Dic.Add (lj), ""
- I = 0
- Do While I < Dic.Count
- Ke = Dic.keys
- MyName = Dir(Ke(I), vbDirectory)
- Do While MyName <> ""
- If MyName <> "." And MyName <> ".." Then
- If (GetAttr(Ke(I) & MyName) And vbDirectory) = vbDirectory Then
- Dic.Add (Ke(I) & MyName & "\"), ""
- End If
- End If
- MyName = Dir
- Loop
- I = I + 1
- Loop
- Did.Add ("文件清单"), ""
- filestyle1 = InputBox("请选择文件类型：" & Chr(10) & " 输入1：(*.*)" _
- & Chr(10) & "输入2：(*.doc) " & Chr(10) & "输入3：(*.xls) " _
- & Chr(10) & "输入4：(*.txt)" & Chr(10) & "输入5：(自定义类型)", "请输入您的文件类型", 1)
- Select Case filestyle1
- Case 1
- filetype2 = "*.*"
- Case 2
- filetype2 = "*.doc"
- Case 3
- filetype2 = "*.xls"
- Case 4
- filetype2 = "*.txt"
- Case 5
- filetype2 = InputBox("请输入您的文件类型", "自定义文件类型", "*.pdf")
- End Select
- For Each Ke In Dic.keys
- MyFileName = Dir(Ke & filetype2)
- Do While MyFileName <> ""
- Did.Add (Ke & MyFileName), ""
- MyFileName = Dir
- Loop
- Next
- For Each Sh In ThisWorkbook.Worksheets
- If Sh.Name = "文件清单" Then
- Sheets("文件清单").Cells.Delete
- F = True
- Exit For
- Else
- F = False
- End If
- Next
- If Not F Then
- Sheets.Add(After:=Sheets(Sheets.Count)).Name = "文件清单"
- Sheets("文件清单").Move Before:=Sheets(1)
- End If
- Sheets("文件清单").[c1].Resize(Did.Count, 1) = WorksheetFunction.Transpose(Did.keys)
- For I = 1 To Did.Count - 1
- Sheets("文件清单").Cells(I + 1, 2) = "No." & I
- Next I
- ActiveWorkbook.Worksheets("文件清单").Sort.SortFields.Clear
- ActiveWorkbook.Worksheets("文件清单").Sort.SortFields.Add Key:=Range("c1"), _
- SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
- With ActiveWorkbook.Worksheets("文件清单").Sort
- .SetRange Range("c1:c" & Did.Count)
- .Header = xlYes
- .MatchCase = False
- .Orientation = xlTopToBottom
- .SortMethod = xlPinYin
- .Apply
- End With
- Columns("c:c").EntireColumn.AutoFit
- With Range("c1")
- .HorizontalAlignment = xlCenter
- .VerticalAlignment = xlCenter
- .WrapText = False
- .Orientation = 0
- .AddIndent = False
- .IndentLevel = 0
- .ShrinkToFit = False
- .ReadingOrder = xlContext
- .MergeCells = False
- End With
- Selection.Font.Bold = True
- For rowscount1 = 2 To Did.Count
- pos1 = InStrRev(Cells(rowscount1, 3), ".")
- Cells(rowscount1, 4) = Mid(Cells(rowscount1, 3), (pos1 + 1), (Len(Cells(rowscount1, 3)) - pos1))
- Next rowscount1
- Cells(1, 4) = "文件类型"
- Cells(1, 2) = "文件编号"
- Columns("b:d").EntireColumn.AutoFit
- Range("B1:D19").Select
- ActiveSheet.ListObjects.Add(xlSrcRange, Range("$B$1:$D$" & Did.Count), , xlYes).Name = _
- "表7"
- Range("表7[#All]").Select
- ActiveSheet.ListObjects("表7").TableStyle = "TableStyleLight12"
- TT = Timer - T
- MsgBox "整个过程耗时:0" & TT & "秒"
- End Sub
代码毕，运行结果如下图
----------------------------------------1.jpg
 2.jpg
 3.JPG
 4.jpg
 5.jpg
 |
不错，学习，不过用时多了点。 
