モーツアルトのリッピングデータを整理するために、フォルダー内のファイル名の一覧を取得するVBAプログラムを作成する事にしました。
今回のファイル名には、英語、ドイツ語、イタリア語、ラテン語なんかが混在していて、そのままではどんな曲なのか判らないのです。
結局、混在したファイル名を日本語に翻訳することにしたのです。
これまでは、フォルダーのファイルを直接書き換えていたのですが、しばしばファイルシステムがエラーを起こして止まってしまいます。
そこで、ファイル一覧をテキストで取得し、それを書き換えて、プログラムで直接書き換えようと思います。
パソコンのOSが「MS-DOS」だった頃は、「リダイレクト機能（パイプ機能）」でフォルダーのファイル一覧を取得していたのです。
「windows11」でも、「コマンドプロンプト」は使えるので、リダイレクトも使えそうですが、フォルダー階層が深くなると、コマンド入力が面倒に思えます。
手元のパソコンにEXCELがインストールしてあるので、久しぶりにVBAでフォルダー内のファイル一覧の取得とファイル名の書き換えを自動で行うプログラムを作成してみることにしました。
VBAってしばらく使ってなかったので（5～6年程前に退社した関係で）、中々にVBAに関する記憶が戻ってきません。
比較的に簡単なコードのハズなのですが、結局5～6時間ほど費やしてしまいました。
最終的に、コードはこうなりました。
一部に、VBAの「FileSystemObject」を使っているので、 このプログラムの実行には、「Microsoft Scripting Runtime」の参照設定を事前に行う必要があります。
**************************************************
Option Explicit
Sub フォルダーを指定してファイル一覧を作成() ' 指定フォルダのファイル一覧をシートに書き出す()
' ******************************フォルダーの指定
MsgBox "ファイル一覧を取得するフォルダーを指定してください"
’*******************************
Dim TgtfolderPath As Variant
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
TgtfolderPath = .SelectedItems(1)
End With
' ********************************** シート名の作成
Dim StrCnt As Integer
Dim NewSheetName As String
StrCnt = InStrRev(TgtfolderPath, "\", , vbTextCompare) '￥の位置を探す
NewSheetName = Strings.Mid(TgtfolderPath, StrCnt)
If Len(NewSheetName) > 21 Then
NewSheetName = Left(NewSheetName, 21)
Else
End If
NewSheetName = GetTimeTxt(NewSheetName)
NewSheetName = FileNameNGReplace(NewSheetName)
' ******************************* 出力するシートを2番目のシートとして作成
Dim TopSheetName As String
TopSheetName = Worksheets(1).Name
Worksheets.Add After:=Worksheets(TopSheetName)
ActiveSheet.Name = NewSheetName
'*******************************全てのファイル名の取得
Dim FileName As String
Dim R As Long
FileName = Dir(TgtfolderPath & "\" & "*.*") '*********全てのファイル名を取得
R = 1
Do While FileName <> ""
ActiveSheet.Cells(R, 1) = FileName
ActiveSheet.Cells(R, 2) = TgtfolderPath & "\" & FileName
FileName = Dir()
R = R + 1
Loop
'*********************
MsgBox "終了しました"
End Sub
'時間をテキストで取得(フォルダー作成時に使う関数）
Public Function GetTimeTxt(ByVal Mytxt As String) As String
Dim A As Variant
A = CDate(Time)
GetTimeTxt = Mytxt & CStr(A)
End Function
'禁則文字列を削除(フォルダー作成時に使う関数）
Public Function FileNameNGReplace(sFileName As String) As String
Dim TmpStr As String
TmpStr = sFileName
TmpStr = Replace(TmpStr, "\", "")
TmpStr = Replace(TmpStr, "/", "")
TmpStr = Replace(TmpStr, ":", "")
TmpStr = Replace(TmpStr, "*", "")
TmpStr = Replace(TmpStr, "?", "")
TmpStr = Replace(TmpStr, """", "")
TmpStr = Replace(TmpStr, "<", "")
TmpStr = Replace(TmpStr, ">", "")
TmpStr = Replace(TmpStr, "|", "")
TmpStr = Replace(TmpStr, "[", "")
TmpStr = Replace(TmpStr, "]", "")
FileNameNGReplace = TmpStr
End Function
’**************************************
ファイル一覧の取得に対し、最初は「VBAのFileSystemObject」を使ったのですが、何故か画像ファイルが取得できませんでした。
そう言えば、このプログラムを作成する前は、フォルダーのファイルを直接書き換えていたのですが、どんどんパソコンの調子が悪くなり、動作がおかしくなる事がありました。
ファイル名の変更を付け付けなく成ったり、入力した文字列が消えてしまったり・・・。
原因を色々と調べてみると、ファイル名の文字数が多いのが原因の様でした。
今回のプログラムで、一部のファイルの名前が取得できなかった原因でもあるようです。
VBAの問題なのか、或いは「ファイルアロケーションシステム」の所為の可能性もあります。
たまには頭の体操と考えて、こんな遊びも良いですね。
2025/11/10 追記
次に、ファイル名を直接変更するプログラムを作成してみました。
ファイル名が異常に長かったり、ファイルシステムが使えない文字があったりして、手こずりました。
「EAC」でピッキング時に使ったデータベースから取得したファイル名に、見慣れない文字などが含まれていりして、ファイルを書き込む時にエラーが出ること判明しました。
どうも、ラテン語？みたいな感じです。（よく知らないのでツッコミはなしです）
まあそれでもファイル自体が消えてしまう事は無いので、エラーが出た場合だけ、直接ファイル名を修正してもう一度走らせれば良いので、このまま進めることにしました。
******************************************
Option Explicit
Sub フォルダー内のファイル名をリストに従って書き換え()
'************************** Sheetの指定
Dim TgtSheetName As String
Dim MyAns As VbMsgBoxResult
If Worksheets.Count = 1 Then
MsgBox "一覧リストがありません"
Exit Sub
End If
'*************************
TgtSheetName = Worksheets(2).Name
' ************************* 確認用メッセージボックスを表示する
MyAns = MsgBox(TgtSheetName & " に対して処理を実行しますか？", vbYesNo + vbQuestion, "確認")
If MyAns = vbNo Then
MsgBox "操作をキャンセルしました。", vbInformation, "情報"
Exit Sub
End If
' ************************** アクティブシートの最終行を取得
Worksheets(TgtSheetName).Activate
Dim xlLastRow As Long 'Excel自体の最終行
Dim LastRow As Long '最終行
Dim MyRow As Long
' **************************
With ActiveSheet
xlLastRow = Cells(Rows.Count, 1).Row 'Excelの最終行を取得
LastRow = Cells(xlLastRow, 1).End(xlUp).Row 'D列の最終行を取得
End With
' ****************** ファイル名の文字数をチェック
Dim WordCNT As Long
With ActiveSheet
For MyRow = 1 To LastRow
WordCNT = Len(Cells(MyRow, 2).Value)
If WordCNT > 256 Then
MsgBox MyRow & "行の文字数が、256より多いので、処理できません" & "値= " & WordCNT
Exit Sub
End If
Next
End With
' ************************** 最終行まで処理を繰り返す
Dim FullOldName As String
Dim FullPath As String
Dim NewName As String
Dim FullNewName As String
Dim MyCnt As Integer
With ActiveSheet
For MyRow = 1 To LastRow
NewName = Cells(MyRow, 1).Value
FullOldName = Cells(MyRow, 2).Value
'*********************************** Pathの切り取り
MyCnt = InStrRev(FullOldName, "\", , vbTextCompare)
FullPath = Left(FullOldName, MyCnt)
FullNewName = FullPath & NewName
Name FullOldName As FullNewName 'ファイル名の変更
Next
MsgBox "処理が完了しました｡"
End With
End Sub
***********************************
シート（１）に、コマンドボタンを作成しましたので、操作は簡単です。
考えてみると、excelを使うということは、文字列の置換等の機能が使えるので、直接ファイル名を一つ一つ時間をかけて書き換える必要がなくて便利だろうと想像できます。
明日からこれを使ってファイル名整理したいと思います。
追記： 時々エラーが出るので、一部のプログラムを修正しました。
0 件のコメント:
コメントを投稿