今天要分享的是，透過VBA來處理檔案與資料夾，這個部份結合的檔案系統，原始的Access VBA指令並不完整，但透過Scripting.FilesystemObject以及一些自製的工具，可以補足原有的不全。
系統原有的檔案與資料夾管理相關語法:
今天我們再分享一些自製程式：
新增的子程式程式碼如下，如果從網路上參考的，我會保留原有作者的注記
Public Function OpenFolder(strPath, bnExplorer As Boolean)
'************************************************
' File: Shell1.vbs (WSH sample in VBScript)
' Author: (c) G. Born
'
' Accessing the Windows shell and opening a
' folder window
'************************************************
'開啟資料夾,可選擇是否顯示左側的樹狀結構
'但有時始用後會變的無法繼續使用
If Len(strPath) < 3 Then Exit Function
Dim ShellObj As Object
' Create Windows shell Application object.
Set ShellObj = CreateObject("Shell.Application")
If bnExplorer = True Then
' This runs Explorer with the folder tree rooted at the path specified
' (same as wsh.Run "explorer.exe /e,/root," & path).
ShellObj.Explore strPath
Else
' Show folder in a shell window.
ShellObj.Open strPath
End If
End Function
Function OpenFolder2(strPath As String, Optional bnRoot As Boolean = False)
'開啟資料夾,另一種比較點單的方式
If bnRoot = True Then
strRoot = "/root,"
Else
strRoot = ""
End If
Call Shell("explorer.exe" & " " & strRoot & strPath, vbNormalFocus)
End Function
Public Function MakeDir(tDir As String) As Boolean
'建立資料夾,若有多層也可建立
'http://www.programmer-club.com.tw/ShowSameTitleN/vb/8586.html
'提供一個函數 , 只要傳入路徑, 他會自行判斷路徑是否存在, 若不存在則自動建立
'這可以避免原本VB提供的Mkdir()函數一次只能檢查或建立一層目錄的缺點
Dim aryPath As Variant
Dim DirDeep As Integer
Dim i As Integer
Dim CheckPath As String
On Error GoTo ERROR_HANDLE
aryPath = Split(tDir, "\") '路徑陣列
DirDeep = UBound(aryPath) + 1 '路徑深度
CheckPath = ""
For i = 1 To DirDeep
If CheckPath = "" Then
CheckPath = aryPath(i - 1)
Else
CheckPath = CheckPath & "\" & aryPath(i - 1)
If Dir(CheckPath, vbDirectory) = "" Then '目錄不存在時
MkDir (CheckPath) '建立目錄
End If
End If
Next i
OK:
MakeDir = True
Exit Function
ERROR_HANDLE:
Debug.Print Err.Number & ": " & Err.Description
If Err.Number = 75 Then
Resume Next
End If
MakeDir = False
End Function
Function FileExists(ByVal strFile As String) As Boolean
'檢查檔案是否存在
FileExists = (Dir(strFile) <> "")
End Function
Function FolderExist(ByVal strFolder As String) As Boolean
'檢查資料夾是否存在
FolderExist = (Dir(strFolder, vbDirectory) <> "")
End Function
Sub DeleteFile(ByVal FileToDelete As String)
'刪除檔案 會設定檔案屬性為一般後再刪除
If FileExists(FileToDelete) Then 'See above
SetAttr FileToDelete, vbNormal
Kill FileToDelete
End If
End Sub
Sub AppendFiles(strSrcs As String, strDsc As String, Optional bnDelDsc As Boolean = False)
'多文字檔案遞增
'strSrcs 來源檔案，可使用多個來源檔案，可使用「;」分開個別檔案
'strDsc 目的檔案
'bnDelDsc 是否先刪除目的檔案
Dim strSrc() As String
Dim i As Integer
Dim SourceNum As Integer
Dim DestNum As Integer
Dim Temp As String
On Error GoTo ErrHandler
If bnDelDsc = True Then
Kill strDsc
End If
DestNum = FreeFile()
Open strDsc For Append As DestNum
SourceNum = FreeFile()
strSrc = Split(strSrcs, ";")
For i = 0 To UBound(strSrc)
Open strSrc(i) For Input As SourceNum
Do While Not EOF(SourceNum)
Line Input #SourceNum, Temp
Print #DestNum, Temp
Loop
Close #SourceNum
Next
CloseFiles:
Close #DestNum
Exit Sub
ErrHandler:
' Debug.Print Err.Number
If Err.Number = 53 Then
Resume Next
Else
MsgBox "Error # " & Err & ": " & Error(Err)
Resume CloseFiles
End If
End Sub
Sub DeleteFolder(strFolder As String, Optional bnSilent As Boolean = False)
'刪除資料夾含子資料夾與檔案
'http://www.rondebruin.nl/win/s4/win004.htm
'Delete all files and subfolders
'Be sure that no file is open in the folder
Dim FSO As Object
Dim MyPath As String
Set FSO = CreateObject("scripting.filesystemobject")
If Right(strFolder, 1) = "\" Then
MyPath = Left(strFolder, Len(strFolder) - 1)
End If
If FSO.FolderExists(strFolder) = False Then
If bnSilent = False Then
MsgBox strFolder & " 此資料夾不存在!"
End If
Exit Sub
End If
On Error Resume Next
'Delete files
'刪掉資料夾內的檔案
FSO.DeleteFile strFolder & "\*.*", True
'Delete subfolders
'刪掉子資料夾
FSO.DeleteFolder strFolder & "\*.*", True
'最後再刪掉該資料夾
RmDir strFolder
On Error GoTo 0
End Sub
Sub資料夾與檔案的處理_測試()
Dim strFile As String, strFolder As String
Dim strFile2 As String, strFolder2 As String
Dim strFile3 As String, strFolder3 As String
Dim strFile4 As String, strFolder4 As String
'基層資料夾用TEMP資料夾
strBase = Environ("TEMP")
'測試資料夾
strFolder = strBase & "\TEST"
'測試資料夾內再放3層資料夾
strFolder2 = strBase & "\TEST\TEST"
strFolder3 = strBase & "\TEST\TEST\TEST"
strFolder4 = strBase & "\TEST\TEST\TEST\TEST"
'測試檔案4個放在不同路徑
strFile = strFolder & "\TestFile.txt"
strFile2 = strFolder2 & "\TestFile2.txt"
strFile3 = strFolder3 & "\TestFile3.txt"
strFile4 = strFolder4 & "\TestFile4.txt"
'DeleteFolder 刪除資料夾包含子目錄
DeleteFolder strFolder
'MkDir 建立資料夾
MkDir strFolder
'OpenFolder 開啟資料夾,可選擇是否顯示左側的樹狀結構
'Call OpenFolder(strFolder, False)
'Call OpenFolder(strFolder, True)
'OpenFolder2 開啟資料夾,使用Shell方式處理,bnRoot可設定該資料夾是否當root
'Call OpenFolder2(strFolder, True)
'MakeDir 建立資料夾,若有多層也可建立
MakeDir strFolder4
'FolderExist 檢查資料夾是否存在
MsgBox FolderExist(strFolder2)
'建立測試檔案
Open strFile For Output As #1
Print #1, "測試檔案"
Close #1
'FileExists 檢查檔案是否存在
MsgBox FileExists(strFile)
'FileCopy 複製一個檔案。
FileCopy strFile, strFile2
'AppendFiles 文字檔案遞增
Call AppendFiles(strFile & ";" & strFile2, strFile3)
'Name 重新命名一個檔案、目錄、或檔案夾。
Name strFile3 As strFile4
'Kill 從磁碟中刪除檔案。
Kill strFile4
'DeleteFile 刪除檔案 會設定檔案屬性為一般後再刪除
DeleteFile strFile2
'RmDir 刪除一個現有的目錄或檔案夾。
RmDir strFolder4
'DeleteFolder 刪除資料夾包含子目錄
DeleteFolder strFolder
End Sub
使用「資料夾與檔案的處理_測試()」子程式時，建議用F8來逐步執行，以便觀察程式碼執行後的結果，最後會發現於test資料夾內有被佔用的資料，導致「DeleteFolder」執行後無法完全刪除，但關閉.mdb檔案後，再重新開啟，重新執行「DeleteFolder」來刪除該資料夾，則可正常刪除，所以有時會建議在程式執行初期，先使用「DeleteFolder」來刪除該資料夾，然後配合bnSilent=True的方式將錯誤訊息關閉，讓user不會因此收到錯誤訊息，這樣可以避免舊資料存在而新資料產生時造成錯誤的問題。
iThome鐵人賽
看影片追技術