麻辣家族討論版版 - Powered by Discuz! Board

Option Explicit
Dim Fs As Object, Sh As Worksheet, d As Object
Sub iMain_Ex()
Dim xlFileDialog As FileDialog
Set xlFileDialog = Application.FileDialog(msoFileDialogFolderPicker) '開啟資料夾的對話框
If xlFileDialog.Show = True Then '對話框: 有按下確定
Application.ScreenUpdating = False
Set Sh = Sheet1
Set Fs = CreateObject("Scripting.FileSystemObject") '系統檔案物件: 提供對電腦檔案系統的存取
Set d = CreateObject("Scripting.dictionary") '字典物件
With Sh.UsedRange
.Clear
.Range("a1").Resize(, 7) = Array("路徑", "文件名", "副檔名", "文件長度", "建檔日期", "存檔日期", "註解")
.Range("A1:F1").Font.Bold = True
.Range("A1:F1").HorizontalAlignment = xlCenter
資料夾_副程式 xlFileDialog.SelectedItems(1)
.Columns("D:D").NumberFormatLocal = "#,### ""KB"""
.Columns("E:F").NumberFormatLocal = "yyyy-mm-dd"
End With
Application.ScreenUpdating = True
End If
End Sub
Private Sub 資料夾_副程式(資料夾 As String)
Dim f As Object
For Each f In Fs.GetFolder(資料夾).Files 'Files(物件):檔案集合
With Sh.[A1].End(xlDown).End(xlDown).End(xlUp).Offset(1)
檔案物件_副程式 f, .Cells
' .Range("a1") = f.ParentFolder
' .Range("b1") = f.Name
' .Hyperlinks.Add Anchor:=.Range("b1"), Address:=f
' .Range("c1") = Fs.GetExtensionName(f) ''Mid(F.Name, InStr(F.Name, ".") + 1)
' .Range("d1") = f.Size / 1024
' .Range("e1") = f.DateCreated
' .Range("F1") = f.DateLastAccessed
字典物件_副程式 f, .Range("b1")
' If d.Exists(F.Name) Then
' Set d(F.Name) = Union(d(F.Name), .Range("b1"))
' d(F.Name).Interior.ColorIndex = 40
' Else
' Set d(F.Name) = .Range("b1")
'End If
End With
Next
'********************************************
'*** 如資料夾下有子資料夾再呼叫這副.程式 ***
'呼叫程式本身的迴圈 ***
'********************************************
For Each f In Fs.GetFolder(資料夾).SubFolders 'SubFolders(物件):資料夾集合
資料夾_副程式 f & ""
Next
End Sub
Private Sub 檔案物件_副程式(f As Object, Rng As Range)
With Rng
.Range("a1") = f.ParentFolder '傳回指定檔案或資料夾的父資料夾物件。
.Range("b1") = f.Name
.Hyperlinks.Add Anchor:=.Range("b1"), Address:=f
.Range("c1") = Fs.GetExtensionName(f) '傳回檔案的副檔名
.Range("d1") = f.Size / 1024
.Range("e1") = f.DateCreated '檔案或資料夾的建立日期和時間
.Range("F1") = f.DateLastAccessed '檔案最後一次存取指定檔案或資料夾的日期和時間
End With
End Sub
Private Sub 字典物件_副程式(f As Object, Rng As Range)
If d.Exists(f.Name) Then
Set d(f.Name) = Union(d(f.Name), Rng)
d(f.Name).Interior.ColorIndex = 40
Else
Set d(f.Name) = Rng
End If
End Sub

複製代碼

Private Sub 檔案物件_副程式(f As Object, Rng As Range)
With Rng
.Range("a1") = f.ParentFolder '傳回指定檔案或資料夾的父資料夾物件。
.Range("b1") = f.Name
'***************************************
If Application.Version = "11.0" Then 'Excel 2003 版本
.Hyperlinks.Add Anchor:=.Range("b1"), Address:=f
ElseIf Application.Version = "12.0" Then 'Excel 2007 版本
'2007 的超連接語法
End If
'***************************************
.Range("c1") = Fs.GetExtensionName(f) '傳回檔案的副檔名
.Range("d1") = f.Size / 1024
.Range("e1") = f.DateCreated '檔案或資料夾的建立日期和時間
.Range("F1") = f.DateLastAccessed '檔案最後一次存取指定檔案或資料夾的日期和時間
End With
End Sub

複製代碼

在2003測試和保存的文件,超鏈接用2007開啟,時時會有問題,又不想改文件(往往是要用才會改),只能改application重新開啟.我是想可不可以用VB控制系統按副檔名決定用2003或2007開啟超鏈接的excel文件.問題似乎有點不合邏輯

複製代碼