Excel VBAでフォルダ、ファイルの作成と操作について

今回説明したいのは、VBAによってファイルとフォルダーを処理することです。このファイルでは、元のExcel VBAコマンドは完全ではありませんが、Scripting.FilesystemObject及びオリジナルのツールを使用して、そのコマンドを補うことができます。

システムにあるファイルおよびフォルダーの管理に関わる構文：

• MkDir フォルダを作成します。
• RmDir 既存のディレクトリまたはフォルダを削除します。
• FileCopy ファイルをコピーします。
• Kill ディスクからファイルを削除します。
• Name ファイル、ディレクトリ、またはフォルダの名前を変更します。

次には自オリジナルのプログラムを紹介します。

• OpenFolder フォルダーを開き、フォルダーを表示するかどうかを選択できます。
• OpenFolder2 フォルダーを開き、Shellを使用して処理します。
• MakeDir フォルダーを作成します。複数のレイヤーがある場合は、MkDirを置き換えるために作成することもできます。
• FolderExist フォルダーが存在するかどうかを確認します。
• FileExists ファイルが存在するかどうかを確認します。
• AppendFiles テキストファイルの増分。
• DeleteFile ファイルを削除します。ファイル属性を全般に設定し、それを削除してからKillを置き換えます。
• DeleteFolder サブディレクトリを含むフォルダーを削除して、RmDirを置き換えます。

新しいサブプログラムコードは次のとおりです。

Public Function OpenFolder(strPath, bnExplorer As Boolean)
'************************************************
' File:    Shell1.vbs (WSH sample in VBScript)'
' 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
'複数のレイヤがあっても、フォルダーが作成できます。
'関数を提供します。パスが渡されている限り、パスが存在するかどうかを自動的に判断し、存在しない場合は自動的に作成します。
'これより、VBによって提供されるMkdir()関数が一回に1レイヤのディレクトリしかチェックまたは作成できないという欠点を回避できます。
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)
'サブフォルダーとファイルを含むフォルダーを削除します。
'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 Folder_and_File_processing_test()
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

[Folder_and_File_processing_test()]サブプログラムを使用する場合は、F8を使用して順序に従って実行し、コードの実行結果を確認することにやさしいです。最後に、テストフォルダに占有されるデータがあるため、[DeleteFolder]を実行した後、完全に削除することはできませんが、.xlsmファイルを閉じて再度開き、[DeleteFolder]を再実行してフォルダを削除すると、正常に削除できます。プログラムが実行する初期で[DeleteFolder]を使用してフォルダを削除し、bnSilent = Trueでエラーメッセージを閉じます。これより、ユーザーはエラーメッセージを受信しなくなります。これにより、古いデータによる新しいデータを作成する時引き起こされるエラーを回避できます。