推 windknife18:加你程式本來 DisplayAlerts, ScreenUpdating的設定 05/08 10:14
→ JieJuen:太酷了! 快很多~ 非常感謝!! ^^ 05/08 16:46
※ 編輯: JieJuen 來自: 218.164.57.110 (05/08 16:54)
→ windknife18:^^ 05/08 18:45
#1A0ppV_c
軟體:Excel
版本:2003
要寫一個檔案列表，想包含 "標題", "註解" 等內容
手動的話，不用開啟檔案 按右鍵內容可觀看與編輯"標題"與"註解"
VBA查到的方法--BuiltinDocumentProperties--要OPEN，運作起來有些慢
Option Explicit
Sub GetInfo()
Dim path As String, aName As String
Dim obApp As New Excel.Application
Dim myFso: Set myFso = CreateObject("Scripting.FileSystemObject")
Dim i, myfile, dp, wbNew
'要處理的目錄
path = ThisWorkbook.path & Application.PathSeparator
obApp.DisplayAlerts = False
obApp.ScreenUpdating = False
Dim myfiles: Set myfiles = myFso.GetFolder(path).Files
i = 1
For Each myfile In myfiles
aName = myfile.Name
ActiveSheet.Hyperlinks.Add Anchor:=Range(Cells(i, 1), Cells(i, 1)),_
Address:=aName, TextToDisplay:=aName
Cells(i, 2) = Round(myfile.Size / 1024, 0)
Cells(i, 3) = "KB"
Cells(i, 4) = FileDateTime(myfile)
'開始讀取標題與註解
Set wbNew = obApp.Workbooks.Open(path & myfile.Name)
Set dp = wbNew.BuiltinDocumentProperties
Cells(i, 5) = dp("Title")
Cells(i, 6) = dp("Comments")
Set wbNew = Nothing
Set dp = Nothing
i = i + 1
Next
obApp.ScreenUpdating = True
obApp.DisplayAlerts = True
Set obApp = Nothing
End Sub
跑起來不是很快，
估計是open的問題?
有看過windknife18大貼過的
http://www.developerfusion.com/code/5093/retrieving-the-summary-properties-of-a-file/
(也要open)不過好像不是vba 不太能用(?)
如果一定要open 一定這麼慢
嗯...那就要再想辦法檢查有更動過的檔案再運作
似乎不是很簡單
原本動作是無腦把全部檔案的名稱 修改日期等列出
再照修改日期排序(還沒寫) (這部分比較快 無腦沒關係)
若要比較檔案的增減與更新
是否有建議做法?
網頁想要放在 http://drivehq.com，但目前還沒發現如何在上面用php
檔案列表自己寫好像...但也沒找到現成的
用 http://drivehq.com 是因為它活的夠久 現在要因應google page creator關閉...
另外 放檔案後網址夠短 很久沒登入也不會消失 等等
當然如果有上述3個優點的php網站 也請推荐!
(那就要再開始研究php寫法了..)
非常感謝~
===========================================================================
以下是 http://chijanzen.net/wp/?p=173 的代碼
其中開頭的 Dim arrHeaders(34) 應該是沒用到
結尾的"高度"放偏了稍作修改
選桌面好像就跳出
那裡看不太懂~..
不用open 速度快很多 好物!
---------------------------------------------------------------------------
Sub ListDetails()
' Dim arrHeaders(34)
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "請選取資料夾", 0, 0)
If (Not objFolder Is Nothing) Then
'假如選桌面時........
On Error Resume Next
If IsError(objFolder.items.Item.Path) Then Exit Sub
On Error GoTo 0
ShellFolderName = objFolder.items.Item.Path
sFullPath = objFolder.items.Item.Path
Debug.Print sFullPath
Else
MsgBox "未選取資料夾": Exit Sub
End If
Set objFolder = objShell.Namespace(sFullPath)
Debug.Print objFolder
For i = 0 To 33
Cells(1, i + 1) = objFolder.GetDetailsOf(objFolder.items, i)
Next
j = 1
For Each strFileName In objFolder.items
j = j + 1
For i = 0 To 33
Cells(j, i + 1) = objFolder.GetDetailsOf(strFileName, i)
Next
Next
Range("AB1") = "寬度"
Range("AC1") = "高度"
End Sub
--
※ 發信站: 批踢踢實業坊(ptt.cc)
◆ From: 218.164.57.110
※ 編輯: JieJuen 來自: 218.164.57.110 (05/08 04:57)