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

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

  1. Option Explicit
  2. Const CSVFileName As String = "フォルダーリストCSV.csv"
  3. Dim KIHONPath As String
  4.  
  5. Dim STRAns As String
  6. Dim VARAns As Variant
  7. Sub Auto_Open()
  8. Dim mbTitle As String
  9. Dim dsn As Long
  10. Dim csvFullPath As String
  11.  
  12. mbTitle = "Auto_Open/" & getMacroTitle()
  13. VARAns = getFolderName()
  14. If VARAns = False Then
  15. Exit Sub
  16. Else
  17. KIHONPath = VARAns
  18. End If
  19. csvFullPath = ThisWorkbook.Path & "\" & CSVFileName
  20. If Dir(csvFullPath) <> "" Then Kill (csvFullPath)
  21. dsn = FreeFile
  22. Open csvFullPath For Output As #dsn
  23. Write #dsn, "基本フォルダー", "フルパス", "フォルダーの場所", "サイズ(バイト)", "ファイル数", "更新日時"
  24. VARAns = MsgBox("直下のフォルダーのみですか?" & vbCrLf & vbCrLf _
  25. & " ■はい: 直下のフォルダーのみ出力する。" & vbCrLf _
  26. & " ■いいえ: 全てのフォルダーを出力する。" _
  27. , vbYesNo + vbDefaultButton2 + vbQuestion, mbTitle)
  28. If VARAns = vbYes Then
  29. VARAns = make直下フォルダ名(KIHONPath, dsn)
  30. Else
  31. VARAns = make全フォルダ名(KIHONPath, dsn)
  32. End If
  33. Close #dsn
  34.  
  35. '  Application.Quit
  36. If MsgBox("終了しました。" & vbCrLf & "出力したCSVファイルを Excel にインポートしますか?" _
  37. , vbYesNo + vbInformation, mbTitle) = vbYes Then
  38. Workbooks.Add
  39. VARAns = インポートCSVファイル(csvFullPath)
  40. End If
  41. ThisWorkbook.Close SaveChanges:=False
  42.  
  43. End Sub
  44. '全フォルダ名を、テキストファイルで出力する。
  45. Function make全フォルダ名(argPath As String, argDSN As Long)
  46. On Error GoTo Exit_make全フォルダ名
  47. Dim mbTitle As String
  48. Dim fso As Object
  49. mbTitle = "make全フォルダ名/" & getMacroTitle()
  50. With CreateObject("Scripting.FileSystemObject")
  51. For Each fso In .getFolder(argPath).SubFolders
  52. VARAns = make全フォルダ名(fso.Path, argDSN)
  53. If Dir(fso.Path, vbDirectory) <> "" Then
  54. Write #argDSN, KIHONPath, fso.Path, getフォルダーの場所(fso.Path), getFolderSize(fso.Path), getFileCount(fso.Path), getLastUpdate(fso.Path)
  55. '        Print #argDSN, KIHONPath & "," & fso.Path & "," & getフォルダーの場所(fso.Path) _
  56. '            & "," & getFolderSize(fso.Path) & "," & getFileCount(fso.Path) & "," & getLastUpdate(fso.Path)
  57. End If
  58. Next fso
  59. End With
  60.  
  61. Exit_make全フォルダ名:
  62. Exit Function
  63.  
  64. Err_make全フォルダ名:
  65. If Err.Number = 70 Then Resume Next
  66. If (Err.Number = 91) Or (Err.Number = 92) Then Resume Next
  67. MsgBox Err.Number & "/" & Err.Description, vbCritical, mbTitle
  68. Resume Exit_make全フォルダ名
  69. End Function
  70. 'フォルダ名を、テキストファイルで出力する。
  71. Function make直下フォルダ名(argPath As String, argDSN As Long) As Boolean
  72. On Error GoTo Exit_make直下フォルダ名
  73. Dim mbTitle As String
  74. Dim fso As Object
  75. mbTitle = "make直下フォルダ名/" & getMacroTitle()
  76. With CreateObject("Scripting.FileSystemObject")
  77. For Each fso In .getFolder(argPath).SubFolders
  78. '      VARAns = make全フォルダ名(fso.Path, argDSN)
  79. If Dir(fso.Path, vbDirectory) <> "" Then
  80. Write #argDSN, KIHONPath, fso.Path, getフォルダーの場所(fso.Path), getFolderSize(fso.Path), getFileCount(fso.Path), getLastUpdate(fso.Path)
  81. '        Print #argDSN, KIHONPath & "," & fso.Path & "," & getフォルダーの場所(fso.Path) _
  82. '            & "," & getFolderSize(fso.Path) & "," & getFileCount(fso.Path) & "," & getLastUpdate(fso.Path)
  83. End If
  84. Next fso
  85. End With
  86.  
  87. Exit_make直下フォルダ名:
  88. Exit Function
  89.  
  90. Err_make直下フォルダ名:
  91. If Err.Number = 70 Then Resume Next
  92. If (Err.Number = 91) Or (Err.Number = 92) Then Resume Next
  93. MsgBox Err.Number & "/" & Err.Description, vbCritical, mbTitle
  94. Resume Exit_make直下フォルダ名
  95. End Function
  96. 'フォルダー更新日時
  97. Function getLastUpdate(argFolderName As String) As String
  98. On Error GoTo Err_getLastUpdate
  99. Dim mbTitle As String
  100. Dim fso As Object
  101.  
  102. mbTitle = "getLastUpdate/" & getMacroTitle()
  103. getLastUpdate = 1
  104. Set fso = CreateObject("Scripting.FileSystemObject")
  105. VARAns = fso.getFolder(argFolderName).DateLastModified
  106. getLastUpdate = Format(CDate(VARAns), "yyyy/mm/dd HH:MM:SS")
  107.  
  108. Exit_getLastUpdate:
  109. Set fso = Nothing
  110. Exit Function
  111.  
  112. Err_getLastUpdate:
  113. MsgBox "更新日時取得に失敗しました。" & vbCrLf & vbCrLf _
  114. & " ■フォルダー名=" & argFolderName & vbCrLf & vbCrLf _
  115. & Err.Number & "/" & Err.Description, vbCritical, mbTitle
  116. Resume Exit_getLastUpdate
  117. End Function
  118. '概要:引数のパス直下のファイル数を返す。(サブフォルダは含まれない)
  119. Function getFolderFilesCount(argパス As String) As Double
  120. Dim fso As Object
  121.  
  122. Set fso = CreateObject("Scripting.FileSystemObject")
  123. getFolderFilesCount = fso.getFolder(argパス).Files.Count
  124. Set fso = Nothing
  125.  
  126. End Function
  127. Function getFolderSize(argフォルダ名 As String) As Double
  128. Dim fso As Object
  129.  
  130. Set fso = CreateObject("Scripting.FileSystemObject")
  131. getFolderSize = fso.getFolder(argフォルダ名).Size
  132. Set fso = Nothing
  133.  
  134. End Function
  135. Function getFolderName() As Variant
  136. On Error GoTo Err_getFolderName
  137. Dim mbTitle As String
  138. Dim WSH As Object
  139. Dim iniPath As String
  140.  
  141. mbTitle = "getFolderName/" & getMacroTitle()
  142. Set WSH = CreateObject("WScript.Shell")
  143. iniPath = ""     'wsh.specialfolders("MyComputer")
  144. With Application.FileDialog(msoFileDialogFolderPicker)
  145. .InitialFileName = iniPath
  146. .Title = "トップフォルダーを指定してください。"
  147. .AllowMultiSelect = False
  148. If .Show = True Then
  149. getFolderName = .SelectedItems(1)
  150. Else
  151. getFolderName = False
  152. End If
  153. End With
  154. Set WSH = Nothing
  155.  
  156. Exit_getFolderName:
  157. Exit Function
  158.  
  159. Err_getFolderName:
  160. MsgBox Err.Number & "/" & Err.Description, vbCritical, mbTitle
  161. Resume Exit_getFolderName
  162. End Function
  163. Function getMacroTitle() As String
  164. STRAns = ThisWorkbook.Name
  165. getMacroTitle = Left(STRAns, InStrRev(STRAns, ".") - 1)
  166. End Function
  167. '概要:引数のパスのみにあるファイル数を返す。隠しファイルを含み、サブフォルダーは含まない。
  168. Function getFileCount(argPath As String)
  169. Dim fso As Object
  170.  
  171. Set fso = CreateObject("Scripting.FileSystemObject")
  172. getFileCount = fso.getFolder(argPath).Files.Count
  173. Set fso = Nothing
  174.  
  175. End Function
  176. Function getフォルダーの場所(argPath As String) As String
  177. Dim i As Long
  178.  
  179. i = InStrRev(argPath, "\")
  180. If i = 0 Or i = Len(argPath) Then
  181. getフォルダーの場所 = ""
  182. Else
  183. getフォルダーの場所 = Mid(argPath, i + 1)
  184. End If
  185.  
  186. End Function
  187. Function インポートCSVファイル(argCSVファイル As String) As Boolean
  188. '
  189. '  Range("A1").Select
  190. With ActiveSheet.QueryTables.Add(Connection:= _
  191. "TEXT;" & argCSVファイル, Destination:=Range("$A$1"))
  192. '    .Name = "フォルダーリストCSV"
  193. .FieldNames = True
  194. .RowNumbers = False
  195. .FillAdjacentFormulas = False
  196. .PreserveFormatting = True
  197. .RefreshOnFileOpen = False
  198. .RefreshStyle = xlInsertDeleteCells
  199. .SavePassword = False
  200. .SaveData = True
  201. .AdjustColumnWidth = True
  202. .RefreshPeriod = 0
  203. .TextFilePromptOnRefresh = False
  204. .TextFilePlatform = 1252
  205. .TextFileStartRow = 1
  206. .TextFileParseType = xlDelimited
  207. .TextFileTextQualifier = xlTextQualifierDoubleQuote
  208. .TextFileConsecutiveDelimiter = False
  209. .TextFileTabDelimiter = True
  210. .TextFileSemicolonDelimiter = False
  211. .TextFileCommaDelimiter = True
  212. .TextFileSpaceDelimiter = False
  213. .TextFileColumnDataTypes = Array(2, 2, 2, 1, 1, 5)
  214. .TextFileTrailingMinusNumbers = True
  215. .Refresh BackgroundQuery:=False
  216. End With
  217.  
  218. End Function