ファイル一覧解析マクロ（その２）
2020年02月12日
前回作ったマクロの利便性が微妙だったので手直し。
/Bありで解析するパターンは、
FSOを使ってファイルの全行を読み込み、
split関数で配列に格納して1つずつ処理していた。
１行ずつ処理するならlinereadで処理したほうがいいなと思い
手を入れてみたら、IF文の分岐を結合して
ちょっと手直しするくらいでいけた。
If Right(buf, Len("のディレクトリ")) = "のディレクトリ" Then
ElseIf Mid(buf, 5, 1) = "/" And Mid(buf, 8, 1) = "/" Then
ElseIf Mid(buf, 2, 1) = ":" Then 'dirB用に追記
End If
あと、ファイル選択をオプションにすべく、
実行モジュールとメインモジュールに分割。
optional fname as string = ""とした。以下ソース。
/Bありで解析するパターンは、
FSOを使ってファイルの全行を読み込み、
split関数で配列に格納して1つずつ処理していた。
１行ずつ処理するならlinereadで処理したほうがいいなと思い
手を入れてみたら、IF文の分岐を結合して
ちょっと手直しするくらいでいけた。
If Right(buf, Len("のディレクトリ")) = "のディレクトリ" Then
ElseIf Mid(buf, 5, 1) = "/" And Mid(buf, 8, 1) = "/" Then
ElseIf Mid(buf, 2, 1) = ":" Then 'dirB用に追記
End If
あと、ファイル選択をオプションにすべく、
実行モジュールとメインモジュールに分割。
optional fname as string = ""とした。以下ソース。
Option Explicit
Private Sub ストップウォッチ(ByRef tictoc)
If tictoc = 0 Then
tictoc = Timer
Else
Debug.Print "[" & Now & "] "; Format(Timer - tictoc, "0.00秒")
tictoc = Timer
End If
End Sub
Sub ■dir結果の解析()
Call dir結果の解析
' Call dir結果の解析("C:\Users\Akihiro\Desktop\sadb.txt")
End Sub
Private Sub dir結果の解析(Optional fPath As String = "")
' dir "D:\Dropbox\VBA" /s /a-d > "D:\Dropbox\VBA\dirout.txt"
If fPath = "" Then fPath = txtファイル名取得("DIR /A-D /Sの解析結果ファイルの選択")
If fPath = "" Then Exit Sub
Dim tictoc As Single
Call ストップウォッチ(tictoc)
Dim Dic: Set Dic = CreateObject("Scripting.Dictionary")
Dim buf As String, Path As String
Dim strDate As String, fSize As String, fname As String, Ext As String
'タイトル行作成
On Error Resume Next
Dic.Add "FulName", "Folder" & "‡" & "File" & "‡" & "Date" & "‡" & "Size" & "‡" & "Ext"
Open fPath For Input As #1
Do Until EOF(1)
Line Input #1, buf
If Right(buf, Len("のディレクトリ")) = "のディレクトリ" Then
Path = Trim(Replace(buf, "のディレクトリ", ""))
ElseIf Mid(buf, 5, 1) = "/" And Mid(buf, 8, 1) = "/" Then
strDate = Replace(Trim(Mid(buf, 1, 17)), " ", " ")
fSize = Trim(Mid(buf, 19, 17))
fname = Trim(Mid(buf, 37, Len(buf) - 37 + 1))
Ext = 拡張子(fname)
Dic.Add Path & "\" & fname, AddressToLink(Path, ファイル名(Path)) & "‡" & fname & "‡" & strDate & "‡" & fSize & "‡" & Ext
ElseIf Mid(buf, 2, 1) = ":" Then 'dirBの場合
fname = ファイル名(buf)
Path = Left(buf, Len(buf) - Len(fname) - 1)
Ext = 拡張子(buf)
strDate = FileDateTime(buf)
fSize = FileLen(buf)
Dic.Add buf, AddressToLink(Path, ファイル名(Path)) & "‡" & fname & "‡" & strDate & "‡" & fSize & "‡" & Ext
strDate = ""
fSize = ""
End If
Loop
Close #1
Dim keys: keys = Dic.keys
Dim Items: Items = Dic.Items
Set Dic = Nothing
Dim Arr(): ReDim Arr(UBound(keys), 5)
Dim oBuf, i As Long, j As Long
For i = 0 To UBound(keys)
oBuf = Split(Items(i), "‡")
For j = 0 To UBound(oBuf)
Arr(i, j) = oBuf(j)
Next j
Next i
'出力
Worksheets.Add
Call ChangeSheetName("dir_" & ファイル名(fPath))
Dim OutPutCell As Range: Set OutPutCell = Cells(1, 1)
Call ArrayToCell_1d_trns(OutPutCell, keys)
Call ArrayToCell_2d(OutPutCell.Offset(0, 1), Arr)
Call オートフィルタと枠固定と罫線(OutPutCell)
Dim OutPutRange As Range: Set OutPutRange = OutPutCell.Resize(UBound(Arr, 1) + 1, 1)
OutPutRange.Offset(1, 3).NumberFormatLocal = "yyyy/mm/dd hh:mm"
OutPutRange.Offset(1, 4).NumberFormatLocal = "#,##0"
Cells(1, "H") = AddressToLink(fPath, "dir > " & fPath)
Call ストップウォッチ(tictoc)
End Sub
Private Sub オートフィルタと枠固定と罫線(OutPutCell As Range)
OutPutCell.Offset(1, 1).Select
ActiveWindow.FreezePanes = True 'ウィンドウ枠の固定ON
OutPutCell.AutoFilter
With ActiveSheet.AutoFilter.Range
.CurrentRegion.Borders.LineStyle = xlContinuous
End With
End Sub
Private Sub ChangeSheetName(shName As String)
Dim flag As Boolean
If UsedSheetName(shName) = False Then
ActiveSheet.Name = shName
Exit Sub
End If
Dim cnt As Long: cnt = 2
Dim NewName As String: NewName = shName & " (" & cnt & ")"
Do While UsedSheetName(NewName) = True
cnt = cnt + 1
NewName = shName & " (" & cnt & ")"
Loop
ActiveSheet.Name = NewName
End Sub
Private Function UsedSheetName(shName As String) As Boolean
Dim ws As Worksheet, flag As Boolean
For Each ws In Worksheets
If ws.Name = shName Then flag = True
Next ws
UsedSheetName = flag
End Function
Private Sub ArrayToCell_1d_trns(Target As Range, oArr) '配列貼り付け便利モジュール
Dim iRowMax: iRowMax = UBound(oArr, 1) - LBound(oArr, 1) + 1
Dim iColMax: iColMax = 1 '１列データは転置が必要
Target.Resize(iRowMax, iColMax).Value = WorksheetFunction.Transpose(oArr)
End Sub
Function AddressToLink(Address As String, Caption As String) As String
AddressToLink = "=hyperlink(""" & Address & """,""" & Caption & """)"
End Function
Function Path2Link(Path As String) As String
Path2Link = "=Hyperlink(""" & Path & """,""" & Path & """)"
End Function
Function txtファイル名取得(Optional タイトル As String = "テキストファイルの選択", Optional デフォルト As String = "")
If デフォルト = "" Then
デフォルト = デスクトップパス
End If
Dim i As Long
'’https://excel-ubara.com/excelvba1/EXCELVBA376.html
Dim FSO: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim FulName As String
With Application.FileDialog(msoFileDialogFilePicker)
.InitialFileName = デフォルト
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "テキストファイル", "*.txt"
.Filters.Add "すべてのファイル", "*.*"
.Title = タイトル
If .Show = True Then
FulName = .SelectedItems(1)
Else
MsgBox "キャンセルしました"
End If
End With
Set FSO = Nothing
txtファイル名取得 = FulName
End Function
Private Function ユーザー名取得()
Dim WshNetworkObject As Object
Set WshNetworkObject = CreateObject("WScript.Network")
ユーザー名取得 = WshNetworkObject.UserName
Set WshNetworkObject = Nothing
End Function
Private Function デスクトップパス()
Dim UserName As String
UserName = ユーザー名取得
デスクトップパス = "C:\Users\" & UserName & "\Desktop"
End Function
Sub ArrayToCell_2d(Target As Range, oArr, Optional ColCnt As Long = 0) '配列貼り付け便利モジュール
Dim iRowMax: iRowMax = UBound(oArr, 1) - LBound(oArr, 1) + 1 '// １次元目の要素数を取得 '// 二次元配列の最大行数
Dim iColMax: iColMax = UBound(oArr, 2) - LBound(oArr, 2) + 1 '// ２次元目の要素数を取得'// 二次元配列の最大列数
'// Rangeオブジェクトで開始セルから貼り付けるセル範囲を拡張する場合
If ColCnt > 0 And ColCnt <= iColMax Then
Target.Resize(iRowMax, ColCnt).Value = oArr
Else
Target.Resize(iRowMax, iColMax).Value = oArr
End If
End Sub
Function 拡張子(FileName As String) As String
Dim pPos As Long
pPos = InStrRev(FileName, ".")
If pPos <> 0 Then
拡張子 = Right(FileName, Len(FileName) - pPos)
Else
拡張子 = ""
End If
End Function
Function ファイル名(FileName As String) As String
Dim yPos As Long
yPos = InStrRev(FileName, "\")
If yPos <> 0 Then
ファイル名 = Right(FileName, Len(FileName) - yPos)
Else
ファイル名 = ""
End If
End Function
Function TextFileToBuf(FullName As String) As String
If FullName = "" Then Exit Function
Dim buf As String
With CreateObject("Scripting.FileSystemObject")
With .GetFile(FullName).OpenAsTextStream
buf = .ReadAll
.Close
End With
End With
TextFileToBuf = buf
End Function
PR
Comment