Excel2010/「マクロフォルダーリスト」を作ったが理解できないところも...

　「ドキュメントの中に見慣れないファイルが並んでしまった」件で、iPS-BBの会を予定している。
ツールとして「ファイルリスト作成機」を使うことにしているが、自分のPCで「予行演習」してみると「あまりにも細かさ過ぎる」‥‥ という懸念が出てきた。
そこで、「フォルダーリスト」を作ろう‥‥ と、三日掛りでコーディングした。
　動作は問題ないレベル（たぶん）だが、最後の Function インポートCSVファイルは、マクロをそのまま貼り付けただけ。ネットで検索したが、いまだ理解できていない。
問題は「当日、問題の PCで上手く動作するか‥‥ だ。

Option Explicit

Const CSVFileName As String = "フォルダーリストCSV.csv"

Dim KIHONPath As String

　

Dim STRAns As String

Dim VARAns As Variant

Sub Auto_Open()

Dim mbTitle As String

Dim dsn As Long

Dim csvFullPath As String

　

mbTitle = "Auto_Open/" & getMacroTitle()

VARAns = getFolderName()

If VARAns = False Then

Exit Sub

Else

KIHONPath = VARAns

End If

csvFullPath = ThisWorkbook.Path & "\" & CSVFileName

If Dir(csvFullPath) <> "" Then Kill (csvFullPath)

dsn = FreeFile

Open csvFullPath For Output As #dsn

Write #dsn, "基本フォルダー", "フルパス", "フォルダーの場所", "サイズ（バイト）", "ファイル数", "更新日時"

VARAns = MsgBox("直下のフォルダーのみですか？" & vbCrLf & vbCrLf _

& "　■はい：直下のフォルダーのみ出力する。" & vbCrLf _

& "　■いいえ：全てのフォルダーを出力する。" _

, vbYesNo + vbDefaultButton2 + vbQuestion, mbTitle)

If VARAns = vbYes Then

VARAns = make直下フォルダ名(KIHONPath, dsn)

Else

VARAns = make全フォルダ名(KIHONPath, dsn)

End If

Close #dsn

　

'　　Application.Quit

If MsgBox("終了しました。" & vbCrLf & "出力したCSVファイルを Excel にインポートしますか？" _

, vbYesNo + vbInformation, mbTitle) = vbYes Then

Workbooks.Add

VARAns = インポートCSVファイル(csvFullPath)

End If

ThisWorkbook.Close SaveChanges:=False

　

End Sub

'全フォルダ名を、テキストファイルで出力する。

Function make全フォルダ名(argPath As String, argDSN As Long)

On Error GoTo Exit_make全フォルダ名

Dim mbTitle As String

Dim fso As Object

mbTitle = "make全フォルダ名/" & getMacroTitle()

With CreateObject("Scripting.FileSystemObject")

For Each fso In .getFolder(argPath).SubFolders

VARAns = make全フォルダ名(fso.Path, argDSN)

If Dir(fso.Path, vbDirectory) <> "" Then

Write #argDSN, KIHONPath, fso.Path, getフォルダーの場所(fso.Path), getFolderSize(fso.Path), getFileCount(fso.Path), getLastUpdate(fso.Path)

'　　　　　　　　Print #argDSN, KIHONPath & "," & fso.Path & "," & getフォルダーの場所(fso.Path) _

'　　　　　　　　　　　　& "," & getFolderSize(fso.Path) & "," & getFileCount(fso.Path) & "," & getLastUpdate(fso.Path)

End If

Next fso

End With

　

Exit_make全フォルダ名:

Exit Function

　

Err_make全フォルダ名:

If Err.Number = 70 Then Resume Next

If (Err.Number = 91) Or (Err.Number = 92) Then Resume Next

MsgBox Err.Number & "/" & Err.Description, vbCritical, mbTitle

Resume Exit_make全フォルダ名

End Function

'フォルダ名を、テキストファイルで出力する。

Function make直下フォルダ名(argPath As String, argDSN As Long) As Boolean

On Error GoTo Exit_make直下フォルダ名

Dim mbTitle As String

Dim fso As Object

mbTitle = "make直下フォルダ名/" & getMacroTitle()

With CreateObject("Scripting.FileSystemObject")

For Each fso In .getFolder(argPath).SubFolders

'　　　　　　VARAns = make全フォルダ名(fso.Path, argDSN)

If Dir(fso.Path, vbDirectory) <> "" Then

Write #argDSN, KIHONPath, fso.Path, getフォルダーの場所(fso.Path), getFolderSize(fso.Path), getFileCount(fso.Path), getLastUpdate(fso.Path)

'　　　　　　　　Print #argDSN, KIHONPath & "," & fso.Path & "," & getフォルダーの場所(fso.Path) _

'　　　　　　　　　　　　& "," & getFolderSize(fso.Path) & "," & getFileCount(fso.Path) & "," & getLastUpdate(fso.Path)

End If

Next fso

End With

　

Exit_make直下フォルダ名:

Exit Function

　

Err_make直下フォルダ名:

If Err.Number = 70 Then Resume Next

If (Err.Number = 91) Or (Err.Number = 92) Then Resume Next

MsgBox Err.Number & "/" & Err.Description, vbCritical, mbTitle

Resume Exit_make直下フォルダ名

End Function

'フォルダー更新日時

Function getLastUpdate(argFolderName As String) As String

On Error GoTo Err_getLastUpdate

Dim mbTitle As String

Dim fso As Object

　

mbTitle = "getLastUpdate/" & getMacroTitle()

getLastUpdate = 1

Set fso = CreateObject("Scripting.FileSystemObject")

VARAns = fso.getFolder(argFolderName).DateLastModified

getLastUpdate = Format(CDate(VARAns), "yyyy/mm/dd HH:MM:SS")

　

Exit_getLastUpdate:

Set fso = Nothing

Exit Function

　

Err_getLastUpdate:

MsgBox "更新日時取得に失敗しました。" & vbCrLf & vbCrLf _

& "　■フォルダー名＝" & argFolderName & vbCrLf & vbCrLf _

& Err.Number & "/" & Err.Description, vbCritical, mbTitle

Resume Exit_getLastUpdate

End Function

'概要：引数のパス直下のファイル数を返す。（サブフォルダは含まれない）

Function getFolderFilesCount(argパス As String) As Double

Dim fso As Object

　

Set fso = CreateObject("Scripting.FileSystemObject")

getFolderFilesCount = fso.getFolder(argパス).Files.Count

Set fso = Nothing

　

End Function

Function getFolderSize(argフォルダ名 As String) As Double

Dim fso As Object

　

Set fso = CreateObject("Scripting.FileSystemObject")

getFolderSize = fso.getFolder(argフォルダ名).Size

Set fso = Nothing

　

End Function

Function getFolderName() As Variant

On Error GoTo Err_getFolderName

Dim mbTitle As String

Dim WSH As Object

Dim iniPath As String

　

mbTitle = "getFolderName/" & getMacroTitle()

Set WSH = CreateObject("WScript.Shell")

iniPath = ""　　　　 'wsh.specialfolders("MyComputer")

With Application.FileDialog(msoFileDialogFolderPicker)

.InitialFileName = iniPath

.Title = "トップフォルダーを指定してください。"

.AllowMultiSelect = False

If .Show = True Then

getFolderName = .SelectedItems(1)

Else

getFolderName = False

End If

End With

Set WSH = Nothing

　

Exit_getFolderName:

Exit Function

　

Err_getFolderName:

MsgBox Err.Number & "/" & Err.Description, vbCritical, mbTitle

Resume Exit_getFolderName

End Function

Function getMacroTitle() As String

STRAns = ThisWorkbook.Name

getMacroTitle = Left(STRAns, InStrRev(STRAns, ".") - 1)

End Function

'概要：引数のパスのみにあるファイル数を返す。隠しファイルを含み、サブフォルダーは含まない。

Function getFileCount(argPath As String)

Dim fso As Object

　

Set fso = CreateObject("Scripting.FileSystemObject")

getFileCount = fso.getFolder(argPath).Files.Count

Set fso = Nothing

　

End Function

Function getフォルダーの場所(argPath As String) As String

Dim i As Long

　

i = InStrRev(argPath, "\")

If i = 0 Or i = Len(argPath) Then

getフォルダーの場所 = ""

Else

getフォルダーの場所 = Mid(argPath, i + 1)

End If

　

End Function

Function インポートCSVファイル(argCSVファイル As String) As Boolean

'

'　　Range("A1").Select

With ActiveSheet.QueryTables.Add(Connection:= _

"TEXT;" & argCSVファイル, Destination:=Range("$A$1"))

'　　　　.Name = "フォルダーリストCSV"

.FieldNames = True

.RowNumbers = False

.FillAdjacentFormulas = False

.PreserveFormatting = True

.RefreshOnFileOpen = False

.RefreshStyle = xlInsertDeleteCells

.SavePassword = False

.SaveData = True

.AdjustColumnWidth = True

.RefreshPeriod = 0

.TextFilePromptOnRefresh = False

.TextFilePlatform = 1252

.TextFileStartRow = 1

.TextFileParseType = xlDelimited

.TextFileTextQualifier = xlTextQualifierDoubleQuote

.TextFileConsecutiveDelimiter = False

.TextFileTabDelimiter = True

.TextFileSemicolonDelimiter = False

.TextFileCommaDelimiter = True

.TextFileSpaceDelimiter = False

.TextFileColumnDataTypes = Array(2, 2, 2, 1, 1, 5)

.TextFileTrailingMinusNumbers = True

.Refresh BackgroundQuery:=False

End With

　

End Function