フォルダー名の複雑な変更

質問

例えば、フォルダー名が

Songbirds - 機関車 (1995) jpPop
Nodubut - Ten Day(2003)

を

1995 Songbirds - 機関車 (1995) jpPop
2003 Nodubut - Ten Day(2003)

のように()内の4桁の数値と半角のスペースをフォルダー名の最前列に追加した形式でフォルダー名を変更できますか？

--------------------
以前教えてもらった『お～瑠璃ねーむ』のマクロ機能では、処理が複雑で出来ないようです。

回答No.6

watabe007 · ベストアンサー

VBScriptを使ってフォルダ名の変更を行います。
メモ帳を開いて下記をコピーしてデスクトップにTest.vbs 名で保存してください。
Option Explicit
Dim objFSO
Dim args
Dim newName
Dim f1, fol

Set args = WScript.Arguments
If args.Count < 1 Then WScript.Quit
Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each f1 in args
set fol = objFSO.GetFolder(f1)
newName = GetnewFName(fol.Name)
If newName <> "" Then
fol.Name = newName
End If
Next
Set objFSO = Nothing

Function GetnewFName(strName)
Dim objRE
Dim myMatches
Dim strYear
Set objRE = CreateObject("VBScript.RegExp")
objRE.Pattern = "\(\d{4}\)"
Set myMatches = objRE.Execute(strName)
If myMatches.Count > 0 Then
strYear = Mid(myMatches(0).Value, 2, 4)
GetnewFName = strYear & " " & strName
End If
Set objRE = Nothing
End Function
実行は作成したTest.vbs ファイルに該当のフォルダを
ドラッグ＆ドロップすると変更が行われます。

お礼

watabe007さん、
　完璧なVBスクリプトの提示ありがとうございます。

サンプルフォルダーを利用したテストで思うような結果になりました。

VBスクリプトは、Visual Basic の構文にすごく似ていますね。
バッチのように処理ができるので大変便利で有効に利用させていただきます。

回答No.8

HohoPapa

>この2回OKを押す処理を無くして処理が完結するようには出来ませんか？

これは、動きを実感してもらいたく書き込んだコードです。

　'　MsgBox (fl.Name)
　'　MsgBox (GetNewDir(fl.Name))
としてコメントアウトするか、
行削除して使ってください。

お礼

何度もありがとうございます。

メッセージボックスを表示しないようにコメントアウトするだけで処理は進みました。
（簡単な事まで全く忘れていました。）

せっかくなので最後に下記を書き加えてマクロが終了したのを表示するようにしました。

　　MsgBox "処理が終了しました。", vbOKOnly + vbinformation, "音楽フォルダー（先頭に西暦付加)"

最後までお付き合い願いありがとうございました。

回答No.7

HohoPapa

>しかし、２つとも
>　　　コンパイルエラー
>　　　　　ユーザー定義型は定義されていません。
>とエラーが出ます。

ごめんなさい。
参照設定が必要です。

https://www.tipsfound.com/vba/18001

がわかりやすいと思います。

お礼

HohoPapaさん、アドバイスありがとうございます。

FileSystemObjectが使えるように
　　[Microsoft Scripting Runtime] をライブラリ登録をする必要があったのですね。

おかげさまで希望の処理が出来ましたが、
　　マクロを起動すると処理フォルダ一つに付き2回ダイアログが出て
　　　　OKをクリックしなと変名処理が完結しない仕様になっています。
　　（Module1に記載したコードには、OKをチェックするようなコードが無いと思います。）

　　この2回OKを押す処理を無くして処理が完結するようには出来ませんか？
　　　　（処理フォルダーの数が多い場合は単純にOKを何度もクリックする事になります。）

回答No.5

HohoPapa

>このスクリプトは、EXCELのVBA＿Editorを開いてどこに記載すれば良いでしょうか？
>また、利用するにはどうすれば良いでしょうか？
> 　　（出来れば具体的な事例で説明願えれば幸いです。

私の提示したコードは
EXCELのVBAです。
標準モジュールに配置します。

>例えば、O:\extractedに下記フォルダーを配置して処理する場合など。）
ということであれば、

Set pfl = fso.GetFolder("D:\work\") ' 親フォルダを取得
この行を
Set pfl = fso.GetFolder("O:\extracted\")
と書き換えて使うことになります。

"O:\extracted\"
このフォルダーの直下にあるフォルダー群を全数調べ、
提示の条件にあるフォルダーがあれば、
そのフォルダー名を全数変更する動作となります。

つまり、
変更対象とはならないフォルダーが含まれていた場合
それは無視する動作をします。

お礼

HohoPapaさん、追加のアドバイスありがとうございます。

添付図のようにExcelのVBAの標準モジュールにコードをコピペして
仮名（Book1.xsm)で保存しました。

Moduleを実行するのに下記の２つの方法を実施しました。

１）ツール＞マクロから　
　　マクロ名（DirChangMain)を実行

２）実行＞Sub/ユーザーフォームの実行

しかし、２つとも
　　　コンパイルエラー
　　　　　ユーザー定義型は定義されていません。
とエラーが出ます。

　　（Dim fso as FileSystemObject) !!!

----------------
何か？
　私が根本的なところで間違えているようですが、エラーが出る原因は何でしょうか？

回答No.4

HohoPapa

>のように()内の4桁の数値
４桁固定なことを見落としていました。
Functionをちょっと直します。

Function GetNewDir(IDirName As String) As String

　Dim sPos As Integer
　Dim ePos As Integer
　Dim NumText As String

　GetNewDir = IDirName

　sPos = InStr(IDirName, "(")
　If sPos = 0 Then Exit Function　　　　　　　　　 '(が無い

　ePos = InStr(IDirName, ")")
　If ePos = 0 Then Exit Function　　　　　　　　　 ')が無い
　If ePos <= sPos Then Exit Function　　　　　　　 '()の位置が逆転

　NumText = Mid(IDirName, sPos + 1, ePos - sPos - 1)
　If Len(NumText) <> 4 Then Exit Function　　　　　'()内が4文字以外
　If IsNumeric(NumText) = False Then Exit Function '()内が数値以外

　GetNewDir = NumText & " " & IDirName

End Function

お礼

レスありがとうございます。

VBAは、むかしEXCELで少し利用していましたが、ここ数年利用することが無くすっかり忘れてしまいました。

このスクリプトは、EXCELのVBA＿Editorを開いてどこに記載すれば良いでしょうか？
また、利用するにはどうすれば良いでしょうか？
　　（出来れば具体的な事例で説明願えれば幸いです。

　例えば、O:\extractedに下記フォルダーを配置して処理する場合など。）

　Terry Oldfield - Guardian Angel (2014)
　Terry Oldfield - Sacred Touch (2009)
　Terry Oldfield - Temple Moon (2017)
　Terry Oldfield - The Best Of Terry Oldfield (2018)
　Terry Oldfield Nonstop (2018)

基本的な質問でお世話をおけしてすいません。

回答No.3

kteds

Powershell での例を参考までに。
対象フォルダはf:\temp-testフォルダ内にあるとした例です。
自分で任意に設定してください。
$folder="f:\temp-test"
$name_org=(Get-Childitem $folder).name
$name_new=foreach($i in $name_org){$i.substring($i.indexof("(")+1,4) + " " + $i}
$k=0;foreach($j in $name_org){Rename-item $folder\$j $name_new[$k];$k=+1}

お礼

レス有難うございます。
　スクリプトの提示感謝します。

早速、提示されたスクリプトでテストしてみました。

O:\extractedに下記フォルダーを配置しました。

　Terry Oldfield - Guardian Angel (2014)
　Terry Oldfield - Sacred Touch (2009)
　Terry Oldfield - Temple Moon (2017)
　Terry Oldfield - The Best Of Terry Oldfield (2018)
　Terry Oldfield Nonstop (2018)

.batファイルならほんの少し理解しているのですがpowershellについては全くの門外漢です。
ネットの情報（powershell入門編）を参考に下記のバッチ（ReName_Song.bat）を作成して起動しました。

ReName_Song.bat
powershell -ExecutionPolicy RemoteSigned -File C:\Users\Nubo\Desktop\ReName_Song.ps1
pause

ReName_Song.ps1
$folder="O:\extracted"
$name_org=(Get-Childitem $folder).name
$name_new=foreach($i in $name_org){$i.substring($i.indexof("(")+1,4) + " " + $i}
$k=0;foreach($j in $name_org){Rename-item $folder\$j $name_new[$k];$k=+1}

下記のように5つの内２つは、思ったような結果が出ましたが
　2014 Terry Oldfield - Guardian Angel (2014)
　2009 Terry Oldfield - Sacred Touch (2009)

後の３つは、処理されずにpoweshellでエラーが出ました。
エラーの原因がわからないのですが、
　　スクリプトの修正が必要なら教えて下さい。

又、

回答No.2

watabe007

>()内の4桁の数値と半角のスペースをフォルダー名の最前列に追加した形式
参考に
Sub Test()
　　Dim objRE As Object
　　Dim myMatches As Object
　　Dim strFName As String, newFName As String
　　Dim strYear As String

　　strFName = "Songbirds - 機関車 (1995) jpPop"
　　Set objRE = CreateObject("VBScript.RegExp")
　　objRE.Pattern = "\(\d{4}\)"
　　Set myMatches = objRE.Execute(strFName)　　
　　If myMatches.Count < 1 Then Exit Sub
　　strYear = Mid(myMatches(0).Value, 2, 4)
　　newFName = strYear & " " & strFName
　　MsgBox newFName
End Sub

お礼

レス有難うございます。

提示いただいたスクリプトはVB（VBA)だと思うのですが？

又、記載中に
　strFName = "Songbirds - 機関車 (1995) jpPop"
とあるのですが、
対象フォルダー名は、任意なので素人ながら”Songbirds -”では固定されているようで
汎用になるのでしょうか？

提示いただいたスクリプトは、あくまでサンプルでサンプルを利用して
　後は当事者（私）が修正をするようなスクリプトですか？

回答No.1

HohoPapa

VBAでよければ、次のようなコードでいかがでしょうか。

Option Explicit

Sub DirChangeMain()

　Dim fso As FileSystemObject
　Dim pfl As Folder
　Dim fl As Folder

　Set fso = New FileSystemObject ' インスタンス化
　Set pfl = fso.GetFolder("D:\work\") ' 親フォルダを取得

　For Each fl In pfl.SubFolders ' サブフォルダの一覧を取得

　　MsgBox (fl.Name)
　　MsgBox (GetNewDir(fl.Name))

　　If fl.Name <> GetNewDir(fl.Name) Then
　　　fl.Name = GetNewDir(fl.Name)
　　End If

　Next

End Sub

Function GetNewDir(IDirName As String) As String

　Dim sPos As Integer
　Dim ePos As Integer
　Dim NumText As String

　GetNewDir = IDirName

　sPos = InStr(IDirName, "(")
　If sPos = 0 Then Exit Function　　　　　　　　　 '(が無い

　ePos = InStr(IDirName, ")")
　If ePos = 0 Then Exit Function　　　　　　　　　 ')が無い
　If ePos <= sPos Then Exit Function　　　　　　　 '()の位置が逆転

　NumText = Mid(IDirName, sPos + 1, ePos - sPos - 1)
　If NumText = "" Then Exit Function　　　　　　　 '()内がNull
　If IsNumeric(NumText) = False Then Exit Function '()内が数値以外

　GetNewDir = NumText & " " & IDirName

End Function