ファイルシステムオブジェクトは使うのに作るのが面倒くさい

そんなわけで一発でコピペして使えるようにVBA用の関数を作っておきました。
一部はMS公式にあります。それはリンクが示してあります。
しかしMS公式は Nothing処理していないんですよね。
VBA FileSystemObject ファイル操作の基礎 -TipsFound
Office VBA リファレンス VBA 言語リファレンス FileSystemObject オブジェクト

Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile("c:\testfile.txt", True)
a.WriteLine("This is a test.")
a.Close

こんな感じでないのです。

参照設定

Home » FileSystemObjectの使い方 » FileSystemObjectの参照設定を行う - Relief
Microsoft Scripting Runtimeを参照設定します。
なお

マクロを作成する段階では参照設定を行って、
　　Dim fso As New Scripting.FileSystemObject
あるいは
　　Dim fso As Scripting.FileSystemObject
　　Set fso = New Scripting.FileSystemObject

とありますが、後者の方がよいそうです。
なぜかというと As Newで宣言するとその時点でインスタンスが作成され、解放することができないからです。このため、エラーがおきるとFsoがメモリに残る可能性があります。
このため Set でNewにした方が良いのだそうです。

「参照があるかないかを調べる」時に、宣言時のNewによって、
再度インスタンスが生成されてしまうからです。
http://www.gizcollabo.jp/vbtomo/log/archive/vbqanda_10377_0.html

VBScript

下記のコードはVBScript用ではありません。
VBScriptにする場合は次のようにします。

まずAsが使えないので、すべてのAs String As Booleanを削除する
On Error Goto が使えないのでOn error resume Nextに変える。
Exit Function 以下の行を削除
If err.Number <> 0 Then 関数名=関数名にふさわしい値 False 0 空白のいずれかをいれる

Public Function fsoFolderExists(sFullFolderName As String) As Boolean
'Folderの有無
'fsoFolderExists("C:\hoge")
'Dim fso Scripting.FileSystemObject: Set fso = New Scripting.FileSystemObject
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
On Error GoTo Terminate
fsoFolderExists = fso.FolderExists(sFullFolderName)
Set fso = Nothing
Exit Function
Terminate:
fsoFolderExists = False
Set fso = Nothing
End Function

がVBScriptだとAsとGotoを変えて

Public Function fsoFolderExists(sFullFolderName)
'Folderの有無
'fsoFolderExists("C:\hoge")
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
fsoFolderExists = fso.FolderExists(sFullFolderName)
If Err.Number <> 0 Then fsoFolderExists = False :Set fso = Nothing: Exit Function
Set fso = Nothing
End Function

このように変えるとVBScriptで動きます。

参照設定した場合

'Dim fso Scripting.FileSystemObject: Set fso = New Scripting.FileSystemObject
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")

この部分を

Dim fso Scripting.FileSystemObject: Set fso = New Scripting.FileSystemObject
'Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")

このように変えてください。

ファイルかフォルダーか

fsoFilExists
fsoFolderExists
の２つを使います

ファイルなら

関数	結果
fsoFilExists	True
fsoFolderExists	False

フォルダなら

関数	結果
fsoFilExists	False
fsoFolderExists	True

となるので、この差を利用します。
またどちらもFalseになるのはファイルかフォルダか知らんけどあんたの言うものなんてあらしまへんのや。
ということになります。

以下コード

Public Function fsoFileExists(sFullPathFileName As String) As Boolean
'ファイルがあるかないか。代入するのはフルパスのファイル名
'fsoFileExists("C:\hoge\test.txt")
'Dim fso Scripting.FileSystemObject: Set fso = New Scripting.FileSystemObject
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
On Error GoTo Terminate
fsoFileExists = fso.FileExists(sFullPathFileName)
Set fso = Nothing
Exit Function
Terminate:
fsoFileExists = False
Set fso = Nothing
End Function

Public Function fsoFolderExists(sFullFolderName As String) As Boolean
'Folderの有無
'fsoFolderExists("C:\hoge")
'Dim fso Scripting.FileSystemObject: Set fso = New Scripting.FileSystemObject
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
On Error GoTo Terminate
fsoFolderExists = fso.FolderExists(sFullFolderName)
Set fso = Nothing
Exit Function
Terminate:
fsoFolderExists = False
Set fso = Nothing
End Function

Public Function fsoGetBaseName(sFullPathFileName As String) As String
'Dim fso Scripting.FileSystemObject: Set fso = New Scripting.FileSystemObject
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
On Error GoTo Terminate
fsoGetBaseName = fso.GetBaseName(sFullPathFileName)
Set fso = Nothing
Exit Function
Terminate:
fsoGetBaseName = ""
Set fso = Nothing
End Function

Public Function fsoGetExtensionName(sFullPathFileName As String) As String
'Dim fso Scripting.FileSystemObject: Set fso = New Scripting.FileSystemObject
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
On Error GoTo Terminate
fsoGetExtensionName = fso.GetExtensionName(sFullPathFileName)
Set fso = Nothing
Exit Function
Terminate:
fsoGetExtensionName = ""
Set fso = Nothing
End Function

Public Function fsoGetFileDateLastModified(sFullPathFileName As String) As Date
'Dim fso Scripting.FileSystemObject: Set fso = New Scripting.FileSystemObject
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
fsoGetFileDateLastModified = fso.GetFile(sFullPathFileName).DateLastModified
Set fso = Nothing
Exit Function
Terminate:
fsoGetFileDateLastModified = 0
Set fso = Nothing
End Function

Public Function fsoGetFileDateCreated(sFullPathFileName As String) As Date
'Dim fso Scripting.FileSystemObject: Set fso = New Scripting.FileSystemObject
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
fsoGetFileDateCreated = fso.GetFile(sFullPathFileName).DateCreated
Set fso = Nothing
Exit Function
Terminate:
fsoGetFileDateCreated = 0
Set fso = Nothing
End Function

Public Function fsoGetFileName(sFullPathFileName As String) As String
'引数 pathspec に指定した文字列の最後が名前付きの構成要素になっていない場合は、長さ 0 の文字列 ("") を返します。
'エラーでも長さ0の文字列を返します。
'指定されたパスが存在しなくても返します
'Dim fso Scripting.FileSystemObject: Set fso = New Scripting.FileSystemObject
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
fsoGetFileName = fso.GetFileName(sFullPathFileName).DateLastAccessed
Set fso = Nothing
Exit Function
Terminate:
fsoGetFileName = ""
Set fso = Nothing
End Function

Function CreateTempFile() As String
'Dim fso Scripting.FileSystemObject: Set fso = New Scripting.FileSystemObject
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
Dim tfolder, tname, tfile
Const TemporaryFolder = 2
Set tfolder = fso.GetSpecialFolder(TemporaryFolder)
tname = fso.GetTempName
Set tfile = tfolder.CreateTextFile(tname)
CreateTempFile = tfile
End Function
Public Function fsoGetFileDateLastAccessed(sFullPathFileName As String) As Date
'Dim fso Scripting.FileSystemObject: Set fso = New Scripting.FileSystemObject
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
fsoGetFileDateLastAccessed = fso.GetFile(sFullPathFileName).DateLastAccessed
Set fso = Nothing
Exit Function
Terminate:
fsoGetFileDateLastAccessed = 0
Set fso = Nothing
End Function

Public Function fsoGetFolderDateLastModified(sFullFolderName As String) As Date
'Dim fso Scripting.FileSystemObject: Set fso = New Scripting.FileSystemObject
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
fsoGetFolderDateLastModified = fso.GetFolder(sFullFolderName).DateLastModified
Set fso = Nothing
Exit Function
Terminate:
fsoGetFolderDateLastModified = 0
Set fso = Nothing
End Function

Public Function fsoGetFolderDateCreated(sFullFolderName As String) As Date
'Dim fso Scripting.FileSystemObject: Set fso = New Scripting.FileSystemObject
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
fsoGetFolderDateCreated = fso.GetFolder(sFullFolderName).DateLastCreated
Set fso = Nothing
Exit Function
Terminate:
fsoGetFolderDateCreated = 0
Set fso = Nothing
End Function

Public Function fsoGetFolderDateLastAccessed(sFullFolderName As String) As Date
'Dim fso Scripting.FileSystemObject: Set fso = New Scripting.FileSystemObject 'scrrun.dll Microsoft.e
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
fsoGetFolderDateLastAccessed = fso.GetFolder(sFullFolderName).DateLastAccessed
Set fso = Nothing
Exit Function
Terminate:
fsoGetFolderLastaccessed = 0
Set fso = Nothing
End Function

Public Function fsoGetDriveLetter(sNetWorkDriveName As String) As String
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
fsoGetDriveLetter = fso.GetDrive(sNetWorkDriveName).DriveLetter
Set fso = Nothing
Exit Function
Terminate:
fsoGetDriveLetter = ""
Set fso = Nothing
End Function

Public Function fsoParentFolderName(sFullPathFolderOrFile As String) As String
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
fsoParentFolderName = fso.GetParentFolderName(sFullPathFolderOrFile)
Set fso = Nothing
Exit Function
Terminate:
sFullPathFolderOrFile = ""
Set fso = Nothing
End Function

Public Function fsoDriveExists(strDrive As String) As Boolean
'E, "E:\"
'ドライブの有無。リムーバブル メディアのドライブの場合は、メディアがセットされていなくても真 (true) が返されます。
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
On Error GoTo Terminate
fsoDriveExists = fso.DriveExists(strDrive)
Set fso = Nothing
Exit Function
Terminate:
fsoDriveExists = False
Set fso = Nothing
End Function

Function ShowDriveInfo(drvpath)
'https://msdn.microsoft.com/ja-jp/library/cc428116.aspx
'Dim fso Scripting.FileSystemObject: Set fso = New Scripting.FileSystemObject
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
Dim d, s, t
On Error Goto Terminate
Set d = fso.GetDrive(drvpath)
Select Case d.DriveType
Case 0: t = "不明"
Case 1: t = "リムーバブル ディスク"
Case 2: t = "ハード ディスク"
Case 3: t = "ネットワーク ドライブ"
Case 4: t = "CD-ROM"
Case 5: t = "RAM ディスク"
End Select
s = "Drive " & d.DriveLetter & ": - " & t
If d.IsReady Then
s = s & " " & "ドライブの準備ができています。"
Else
s = s & " " & "ドライブの準備ができていません。"
End If
ShowDriveInfo = s
Exit Function
Terminate:
ShowDriveInfo= ""
Exit Function
End Function

Function ShowSpaceInfo(drvpath)
'https://msdn.microsoft.com/ja-jp/library/cc392048.aspx
Dim fso, d, s
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Goto Terminate
Set d = fso.GetDrive(fso.GetDriveName(fso.GetAbsolutePathName(drvpath)))
s = "ドライブ " & d.DriveLetter & ":"
s = s & vbCrLf
s = s & "合計サイズ : " & FormatNumber(d.TotalSize/1024, 0) & " KB"
s = s & vbCrLf
s = s & "空き領域 : " & FormatNumber(d.AvailableSpace/1024, 0) & " KB"
ShowSpaceInfo = s
Exit Function
Terminate:
Set fso = Nothing
Exit Function
End Function

Function ShowShortName(filespec As String) As String
'https://msdn.microsoft.com/ja-jp/library/cc428148.aspx
'For VBA
'Version Up 2018/05/21
'ShowShortName("C:\Hoge\test.txt")
Dim fso, f, s
On Error GoTo Terminate
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFile(filespec)
s = f.shortname
ShowShortName = CStr(s)
Set fso = Nothing
Exit Function
Terminate:
If Err.Number <> 0 Then ShowShortName = "": Err.Clear: Set fso = Nothing: Exit Function
End Function

Function ShowShortPath(Folderspec) As String
'https://msdn.microsoft.com/ja-jp/library/cc428148.aspx
Dim fso, f, s
Dim ar, i, buf, br(), ib, sHead, ssHead
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(Folderspec) Then
ar = Split(Folderspec, "\")
sHead = ar(LBound(ar)) & "\"
ssHead = sHead
For i = LBound(ar) + 1 To UBound(ar)
sHead = sHead & ar(i) & "\"
Set f = fso.getfolder(sHead)
ssHead = ssHead & f.ShortName & "\"
Next
Else
GoTo Terminate
End If
ShowShortPath = ssHead
Exit Function
Terminate:
ShowShortPath = ""
Set fso = Nothing
End Function




Function ShowShortFullpath(fullPathfilespec As String) As String
'2018/6/2 Version Up
'ユーザー定義関数ShowShortPathを活用しファイルのフルパスからショートパスとショートネームのフルパス文字列を作成する。
'Dim fso Scripting.FileSystemObject: Set fso = New Scripting.FileSystemObject
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
Dim f, s, fol
If fso.FileExists(fullPathfilespec) Then
Set f = fso.GetFile(fullPathfilespec)
Set fol = fso.getfolder(fso.getparentfoldername(fullPathfilespec))
ShowShortFullpath = CStr(ShowShortPath(fol.Path) & f.shortname)
Else
ShowShortFullpath = ""
End If
Set fso = Nothing
End Function

Excel Access VBA 用Filesystemobjectユーザー定義関数