趣味プログラミングblog

'-----------------------------------------------------------ここから

C:\Dirtest のディレクトリ ①「のディレクトリ」で終わる

2022/06/24 13:18 18,449,249 CMD_DIR結果の解析.xls ②5文字目、8文字目が「/」
2022/04/08 23:22 10,671,755 Dirリスト.txt ②
2 個のファイル 29,121,004 バイト ③「バイト」で終わり、「個のファイル」を含む
'-----------------------------------------------------------ここまで

追加する処理は以下の２つ。
①を読み込んだ際に、対象のフォルダパスが定数の文字列で始まる場合は、対象のフォルダパスを""にする。
フォルダパスが""の場合は、②を読み込んでも配列に格納せずにスキップする。

やっぱり、複数フォルダを指定したいので、
定数を｜で区切って、複数フォルダを指定可能に。


Const strExcArr = "C:\Windows | C:\Program Files | C:\$Recycle.Bin | C:\Dirtest\xxファイル一覧\BKUP"
Const strExcExc = "C:\Dirtest\xxファイル一覧\BKUP\大事大事 | C:\Program Files\otbedit"

該当か判定するには、定数を｜で区切って配列に格納。
対象のフォルダパスが配列の要素に１つでも一致すれば
excFlagをONにして、対象のフォルダパスを""にする。


やっぱりやっぱり、除外対象フォルダであってもその中の特定のフォルダは解析対応にしたいので、
上と同様にeeFlagを用意して、excFlagがONでeeFlagがOFFのときのみ
②の格納処理をスキップする。


ちなみに、この除外機能がないときにCドライブ全検索の結果を取り込んだら
メモリ不足で停止した。。。

メモリ不足については別途書くことにする。

以下、ソース。ソーステキストは こちら。

Option Explicit

Sub ■dir結果のファイル解析()
ThisWorkbook.Activate '誤操作防止のために対象ブックを指定

'msgboxに表示するメッセージをrcGetTpath関数に渡して、Dirリスト.txtのパスを取得。
Dim rcMsg As String: rcMsg = "File一覧を出力します。同じディレクトリのDirリスト.txtを指定しますか？"
Dim TargetPath As String: TargetPath = rcGetTpath(rcMsg)

Dim shname As String: shname = Left(Replace(ベースファイル名(TargetPath), "Dirリスト", "Fileリスト"), 31)
Call Select_Make_Sheet(shname) '入力したシートをアクティベート。なければ挿入する。

Dim tictoc As Single
Call ストップウォッチ(tictoc)
Call dir結果のFile解析(TargetPath) 'メインモジュール
Call ストップウォッチ(tictoc)
End Sub

Sub ■dir結果のDir解析()
ThisWorkbook.Activate '誤操作防止のために対象ブックを指定

'msgboxに表示するメッセージをrcGetTpath関数に渡して、Dirリスト.txtのパスを取得。
Dim rcMsg As String: rcMsg = "Dir一覧を出力します。同じディレクトリのDirリスト.txtを指定しますか？"
Dim TargetPath As String: TargetPath = rcGetTpath(rcMsg)

Dim shname As String: shname = Left(ベースファイル名(TargetPath), 31)
Call Select_Make_Sheet(shname) '入力したシートをアクティベート。なければ挿入する。

Dim tictoc As Single
Call ストップウォッチ(tictoc)
Call dir結果のDir解析(TargetPath) 'メインモジュール
Call ストップウォッチ(tictoc)

End Sub

Private Function rcGetTpath(rcMsg As String)
'rcMsgのメッセージを表示して、テキストファイルのフルパスを取得する

Dim RC As Long: RC = MsgBox(rcMsg, vbYesNoCancel)
Dim TargetPath As String

If RC = vbYes Then 'デフォルトファイル
TargetPath = ThisWorkbook.Path & "\" & "Dirリスト.txt"
ElseIf RC = vbNo Then 'ファイルから
TargetPath = txtファイル名取得2(ThisWorkbook.Path)
If TargetPath = "" Then End
Else 'キャンセル
End
End If
rcGetTpath = TargetPath
End Function

Private Function txtファイル名取得2(デフォルト As String)
Dim i As Long
'’https://excel-ubara.com/excelvba1/EXCELVBA376.html
Dim FSO: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim FullName As String
With Application.FileDialog(msoFileDialogFilePicker)
.InitialFileName = デフォルト
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "テキストファイル", "*.txt"
.Title = "テキストファイルの選択"
If .Show = True Then
FullName = .SelectedItems(1)
Else
MsgBox "キャンセルしました"
End If
End With
Set FSO = Nothing
txtファイル名取得2 = FullName
End Function

Private Sub Select_Make_Sheet(shname As String)
'shnameシートを選択 なければ作って、shnameに応じた列幅をセット
'シートループで該当シートをアクティベートできたかで判断

Dim sh As Long, k As Long
For sh = 1 To Worksheets.Count
If Worksheets(sh).Name = shname Then Worksheets(sh).Activate
Next sh
If ActiveSheet.Name <> shname Then
Worksheets.Add
ActiveSheet.Name = shname
If shname = "Fileリスト" Then
'シートの幅 A B C D E F G H I J
Dim wfArr: wfArr = Split(Replace("4.5 , 52 , 21.88 , 12.13 , 7.13 , 32.63 , 71 , 4.75 , 14.75 , 14.75 ", " ", ""), ",")
For k = 0 To UBound(wfArr)
Cells(1, k + 1).EntireColumn.ColumnWidth = wfArr(k)
Next k
ElseIf shname = "Dirリスト" Then
'シートの幅 A 　B C D E F G H I J K
Dim wdArr: wdArr = Split(Replace("4.5 , 48.25 , 7.25 , 8.13 , 10.75 , 10 , 10.75 , 10.63 , 14.75 , 14.75 , 56.88 ", " ", ""), ",")
For k = 0 To UBound(wdArr)
Cells(1, k + 1).EntireColumn.ColumnWidth = wdArr(k)
Next k
End If
End If
End Sub

Function ベースファイル名(FileName As String) As String 'フルパス対応
Dim pPos As Long: pPos = InStrRev(FileName, ".")
Dim yPos As Long: yPos = InStrRev(FileName, "\")
If yPos > pPos - 1 Then '　拡張子のみファイルは拡張子じゃない
ベースファイル名 = ""
Else
If pPos > 0 Then
ベースファイル名 = Mid(FileName, yPos + 1, pPos - yPos - 1)
Else
ベースファイル名 = ""
End If
End If
End Function

Function isLeftmatch(Path, Arr)
Dim k As Long, Buf As String, Flag As Boolean
For k = 0 To UBound(Arr)
Buf = Trim(Arr(k))
If Left(Path, Len(Buf)) = Buf And Buf <> "" Then Flag = True
Next k
isLeftmatch = Flag
End Function
Private Sub dir結果のFile解析(fpath As String)
Const strExcArr = "C:\Windows | C:\Program Files | C:\$Recycle.Bin | C:\Dirtest\xxファイル一覧\BKUP"
Const strExcExc = "C:\Dirtest\xxファイル一覧\BKUP\大事大事 | C:\Program Files\otbedit"

Dim excArr: excArr = Split(strExcArr, "|")
Dim eeArr: eeArr = Split(strExcExc, "|")

Dim excFlag As Boolean, eeFlag As Boolean

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
Dim c3buf As String
'タイトル行作成　★区切り文字として「‡」を使用。ファイル名に‡があるとうまく動かない
Const Tgyo = 3
Const strTitle = "File" & "‡" & "Date" & "‡" & "Size" & "‡" & "Ext" & "‡" & "Folder" & "‡" & "FullName" & "‡" & "期"
Dic.Add "FullName", strTitle
Open fpath For Input As #1
Application.StatusBar = "ファイル解析中"
Do Until EOF(1)
Line Input #1, Buf
If Right(Buf, Len("のディレクトリ")) = "のディレクトリ" Then
Path = Trim(Replace(Buf, "のディレクトリ", ""))
If isLeftmatch(Path, excArr) = True Then
If isLeftmatch(Path, eeArr) = False Then
Path = ""
End If
End If
ElseIf Mid(Buf, 5, 1) = "/" And Mid(Buf, 8, 1) = "/" And Path <> "" 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)
If Not Dic.exists(Path & "\" & fname) Then '出るはずない重複が出たので対策
If Dic.Count < Rows.Count - Tgyo Then
Dic.Add Path & "\" & fname, fname & "‡" & strDate & "‡" & fSize & "‡" & Ext & "‡" & ファイル名(Path) & "‡ ‡" & Year(strDate) - 1982 + (Sgn(Month(strDate) - 3.5) - 1) / 2 'Folderそのまま
' Dic.Add Path & "\" & fname, fname & "‡" & strDate & "‡" & fSize & "‡" & Ext & "‡" & AddressToLinkFunc(Path, ファイル名(Path)) & "‡ ‡" & Year(strDate) - 1982 + (Sgn(Month(strDate) - 3.5) - 1) / 2'Folderをリンクへ
End If
Else
Debug.Print Path & "\" & fname
End If
ElseIf Buf = " ファイルの総数:" Then '終端まで来たら
Line Input #1, Buf 'もう１行読む
c3buf = Trim(Buf)
Line Input #1, Buf 'もう１行読む
c3buf = Trim(Buf) & " " & c3buf
End If
Loop
Close #1
Application.StatusBar = "Arr作成"

'Dicのキーと値を変数に格納して、メモリ解放
Dim keys: keys = Dic.keys
Dim Items: Items = Dic.Items
Set Dic = Nothing

'‡の数を数えて、Arrをリサイズ
Dim cCnt As Long: cCnt = Len(strTitle) - Len(Replace(strTitle, "‡", "")) + 2
Dim Arr(): ReDim Arr(UBound(keys), cCnt) 'Arrはタイトル項目数＋２

'ArrにDicの情報を格納
Dim oBuf, i As Long, j As Long, tmp As String
For i = 0 To UBound(keys)
Arr(i, 0) = i
oBuf = Split(Items(i), "‡")
For j = 0 To UBound(oBuf)
Arr(i, j + 1) = oBuf(j)
Next j
tmp = keys(i)
Arr(i, 6) = tmp '決め打ち
Next i
Arr(0, 0) = "№" '決め打ち

'Arrをエクセルに出力する前にメモリ解放
Set keys = Nothing
Set Items = Nothing

'出力 のまえに初期化
Application.StatusBar = "シートへ出力中"
ActiveSheet.Cells.ClearContents


'出力先の書式を設定（日付とサイズ）
Dim OutPutCell As range: Set OutPutCell = Cells(Tgyo, 1) '出力先の先頭セルを指定
Dim OutPutRange As range: Set OutPutRange = OutPutCell.Resize(UBound(Arr, 1) + 1, 1)
OutPutRange.Offset(1, 0).NumberFormatLocal = "0" '№
OutPutRange.Offset(1, 1).NumberFormatLocal = "@" 'File
OutPutRange.Offset(1, 2).NumberFormatLocal = "yyyy(ge)/mm/dd hh:mm" 'Date
OutPutRange.Offset(1, 3).NumberFormatLocal = "#,##0" 'Size
OutPutRange.Offset(1, 4).NumberFormatLocal = "@" 'Ext
OutPutRange.Offset(1, 5).NumberFormatLocal = "@" 'Folder
OutPutRange.Offset(1, 6).NumberFormatLocal = "@" 'Fullname
OutPutRange.Offset(1, 7).NumberFormatLocal = "0" '


'出力先の先頭セルを指定して、Arrを貼り付け
Dim k As Long
Const 分割貼り付けフラグ = 0 'メモリ停止対策をするか
If 分割貼り付けフラグ = 0 Then
Call ArrayToCell_2d(OutPutCell, Arr)
Else '1列ずつ貼り付け
For k = 0 To UBound(Arr, 2)
Call ArrayToCell_2d(OutPutCell.Offset(0, k), Array2dTo1d(Arr, k))
Next k
End If

Application.StatusBar = "表示調整中"
Call オートフィルタと枠固定と罫線(OutPutCell)



Dim txtPath As String: txtPath = ThisWorkbook.Path 'ここのフォルダパス
Dim yPos As Long: yPos = InStrRev(txtPath, "\") '\を右から数えた位置
Dim tarPath As String: tarPath = Left(txtPath, yPos - 1) '対象フォルダパス

Cells(1, "A") = tarPath
Cells(1, "C") = FileDateTime(fpath)
Cells(1, "D") = FileLen(fpath)
Cells(1, "E") = fpath

Cells(2, "C") = c3buf ' buf

' 日付を降順でソート
With ActiveSheet.AutoFilter.range
.Sort Key1:=.range("C2"), Order1:=xlDescending, Header:=xlYes
End With

ReDim Preserve Arr(UBound(Arr, 1), 0) '１列目のみ残して通番を貼り付け
Call ArrayToCell_2d(OutPutCell, Arr)

'期
Dim kiRow As Long
kiRow = OutPutCell.Offset(1, 2).Row '日付１つ目
If Cells(Rows.Count - 1, 1) <> "" Then Cells(1, 2) = "行数上限で破棄"
Application.StatusBar = ""
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

Function AddressToLinkFunc(Address As String, Caption As String) As String
AddressToLinkFunc = "=hyperlink(""" & Address & """,""" & Caption & """)"

End Function

Sub ArrayToCell_2d(Target As range, oArr, Optional ColCnt As Long = 0) '2次元配列貼り付け便利モジュール
Dim iRowMax: iRowMax = UBound(oArr, 1) - LBound(oArr, 1) + 1 '// １次元目の要素数を取得 '// 二次元配列の最大行数
Dim iColMax: iColMax = UBound(oArr, 2) - LBound(oArr, 2) + 1 '// ２次元目の要素数を取得'// 二次元配列の最大列数
If iRowMax - 1 > Rows.Count Then iRowMax = Rows.Count - 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 getDimention(Arr)
On Error GoTo ANS
Dim i As Long, tmpSize As Long
For i = 1 To 5
tmpSize = UBound(Arr, i)
Next i
ANS:
getDimention = i - 1
End Function

Function Array2dTo1d(Arr, col As Long)
If getDimention(Arr) <> 2 Then Stop '２次元じゃないし
Dim rowMax As Long: rowMax = UBound(Arr)

If rowMax < col Then Stop 'そこにはないし

Dim oArr(): ReDim oArr(rowMax, 0)
Dim i As Long
For i = 0 To rowMax
oArr(i, 0) = Arr(i, col)
Next i
Array2dTo1d = oArr
End Function

Function 拡張子(FileName As String) As String
Dim pPos As Long: pPos = InStrRev(FileName, ".")
Dim yPos As Long: yPos = InStrRev(FileName, "\")
If yPos > pPos - 1 Then '　拡張子のみファイルは拡張子じゃない
拡張子 = ""
Else
If pPos > 0 Then
拡張子 = Right(FileName, Len(FileName) - pPos)
Else
拡張子 = ""
End If
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