アキュート・アクセント文字の弊害に苦しむ（最新プログラム、忘備録）
ファイル一覧の取得と書き込みプログラムを作ったのですが、どうしてもエラーが出てしまう。
「ファイル名が違うよ」エラーが出るので、よーくファイル名を見ると、なんか前から七行目の「i」文字の形が違っている？？？。
調べたら、これはイタリア語やラテン語の「アクセント付き文字」と言うものらしい。
確かに、イタリア語って独特のアクセントだよねぇ。
今回のＣＤに保存されているモーツアルトのオペラって、用いている言語がラテン劇なんで、データベースのファイル名もラテン語が使ってあるんですかね・・・。
別に、普通の英語で記述してくれると有り難いのに。
ネットで対処法をぐぐってみたら、EXCELのVBAではこの文字は扱えないらしいので、自動チェックのプログラムも作れないそうです。
今回のＣＤ集をリッピングするに当たって、EACで使っている「CUETool ＤＢ」で唯一でてくるデータなので、仕方なく使っているのですが、困ったなぁ。
他のデータベースに変えてみるかと考えましたが、なんか、もっと危なそうな文字列がでているのです。
やべー！。
***************** pm13:47分 追記 **************************
以前作成したバージョンで、「VBAのFileSystemObject」を使ってファイル名一覧を作成したデータを見ると、なんと「アキュート・アクセント文字」も EXCELのsheetにきちんと記録されていました。
もしかしてファイルの読み書きに「VBAのFileSystemObject」を使えば、「アキュート・アクセント文字」の操作が可能？かもしれない。
そこで、読み込みや書き込み双方に、「VBAのFileSystemObject」を使ってみた所、なんとエラーが起こることもなく動作しました。 ヤッター＼(^o^)／
追記：2025/11/12
何度か使っていましたら、未だ時々エラーが出ることが有りました。
動きを一つ一つチェックしていくと、書き換え前後のファイル名が同じ場合にだけエラーが出る事が判りました。
つまり、「元のファイル名と変更後のファイル名が同じですよ！」と言って、エラーが出ていた様です。
対応策を色々と検討した結果、もっとも簡単な方法を思いつきました。
ファイル一覧を作成する時に、元のファイルを後に変更する為のセル（1列セル）に加えてもう1枠（3列セル）に比較用として保存しておいて、書き込み時に変更名とオリジナル名を比較し、もし同一ならファイル名変更動作を行わない様に、プログラムを変更しました。
★最新プログラム（2025/11/12）
***********************************************************************************
Option Explicit
Sub FSOフォルダーを指定しファイル一覧を作成()
Sub FSOフォルダーを指定しファイル一覧を作成()
' ******************************フォルダーの指定
MsgBox "ファイル一覧を取得するフォルダーを指定してください"
Dim TgtfolderPath As Variant
With Application.FileDialog(msoFileDialogFolderPicker).Show
TgtfolderPath = .SelectedItems(1)
End With
' ********************************** シート名の作成
Dim StrCnt As Integer
StrCnt = InStrRev(TgtfolderPath, "\", , vbTextCompare)
Dim NewSheetName As String
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 OutputSheet As Worksheet
Set OutputSheet = Worksheets(NewSheetName)
Dim R As Long
R = 1
'***************************** GetFolderメソッドでFolderオブジェクトを取得する
Dim FSO As New FileSystemObject
Dim 指定フォルダ As Folder
Set 指定フォルダ = FSO.GetFolder(TgtfolderPath)
'***************************** Filesプロパティの中をForEachで順次取得する
Dim MyFile As File
For Each ファイル In 指定フォルダ.Files
' ************************ファイルの情報をシートに書き出す
OutputSheet.Cells(R, 1) = MyFile .Name
OutputSheet.Cells(R,3) = MyFile .Name '書き込み時のチェック用
OutputSheet.Cells(R,2) = MyFile .Path
R = R + 1
Next
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
********************************************************************************
Option Explicit
Sub フォルダー内のファイル名をリストに従ってFSOで書き換え()
'************************** 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 OldFileName As String '比較用
Dim NewFileName As String
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
With ActiveSheet
For MyRow = 1 To LastRow
NewFileName = Cells(MyRow, 1).Value
FullOldName = Cells(MyRow, 2).Value
OldFileName = Cells(MyRow, 3).Value
'**********************************ファイル名の変更
If NewFileName <> OldFileName Then
FSO.GetFile(FullOldName).Name = NewFileName
End If
Next
End With
Set FSO = Nothing
'************終了***********
MsgBox "処理が完了しました｡"
End Sub
***************************************************************************
いよいよ完成です。
もう、理由のわからないエラーが出ることはなくなりました。
パソコンでの「楽曲データの整理作業」が飛躍的に効率アップとなりました。
「VBAによるプログラミング」は数年ぶりと本当に久しぶりでしたが、なんとか完成させる事ができました。
関数を思い出すのに相当時間がかかりましたが、少し頭脳が戻ってきた感じです。
もっと前にこのプログラムを作成しＣＤリッピング作業の後処理に使っていれば、ずっと楽に完了させられたでしょう。
これを契機に、今後はパソコン処理にもっとVBAを活用しようと思います。
次は楽曲データのバックアップやコピーをする時に、差分だけ書き込むようなプログラムを作ってみようと思っています。
0 件のコメント:
コメントを投稿