2009/04/30

VBScriptで一気にRename・・・



---------- Update 200905040237
スクリプト中に1処理2行を追加。
パラメータ中の、フォルダと、拡張子なしファイルの識別を行う重要な行。
手抜きで入れてなかった(悪) 元々暫定版だしw

アーカイブも、ココのソースも、この版に更新済み。
----------------------------


先のログで触れた、SD14のファイル管理向けReplacedRenameスクリプト、
あんまりな造りだったので、公開しない予定だったが、ちょっとした工夫を加えて汎用化したので、うpしてみた。

アーカイブはコチラ▼
   MultiReplacedRename.zip    
▲ を、右クリックしてファイルとして保存してください。

ただ単純にファイル名の文字列置換するだけだと なんか芸がないし、使い勝手が悪い。
あと、置換後の名称と同名のファイルが既存の場合は、バックアップ取らせたいし、
対象ファイルがない場合は処理したくないし・・・ とか云ってると、同じ処理の繰り返しも多くなる。
元々のモノも、そのヘンは考慮した造りだったのだが、記述自体は間に合わせ感たっぷりの、
この上なくゴチャゴチャなモノだった。

また、置換前後の文字列と対象拡張子指定を、スクリプト内に直記述していた為、全く他への流用も利かなかった・・・

んで、そのままでは、今後使い辛いってのもあったので、
ファイル名変更部や、ファイルの名称に日時を付けでバックアップする処理を分離し、
スクリプト自身のファイル名を条件パラメータとして利用する構造に変更するコトで、
現在のようなスマートな状態になった。

使い方も簡単で、このスクリプト自体のファイル名を・・・

書式)
    {Before}_{After}_{拡張子}_..._{拡張子}.vbe    

記述例)
    SDIM_SDIM01_x3f_jpg.vbe    


のように変更済ませば、スクリプト本体か そのショートカットに、対象のファイルかフォルダをドロップするだけでいい。
複数フォルダ/ファイルドロップに対応、フォルダは第1階層分のみ対応、ソレより深い階層のファイルは処理しない。


あと、蛇足だが、FileSystemObjectのFolderオブジェクトは中々のクセ者だったコトを付け加えておこう。
よく使っていた対象なので、全く油断したというのがホントのトコで、意外な伏兵だった。
フォルダ内を検索し、一部のファイルに対して処理を行う程度ならともかく、
ここで紹介しているような、フォルダ内のファイル名を順繰りに全て処理する体のスクリプトの場合、
オブジェクトを直接利用し、単純にForEach-Nextで処理を組むと、ファイル名変更済みファイルを再度、
条件に基づいて処理してしまう。

実のトコロ、ココで紹介しているスクリプトの基となった暫定版がそうだったのだよ(´ヘ`;)
しかもコレが厄介で、問題の対象は、全てが二重処理されている訳でもなく、規則性もない・・・
原因については、機器のスペックの向上なども大きいと思われるが、おそらくは仕様だろうw

症状を診るに、序盤に名称変更したファイルの幾つかが、本来最後である筈のファイルの後に続いて、
既存ファイルとして呼び出されてしまっているようだ(´ヘ`;)
この挙動から判断するに、普通の関数や配列変数を使うつもりで、
FileSystemObjectのFolderオブジェクトを利用するのは、極めて避けるべき行為なのかもしれない。

・・・仕方がないので、置換(名称変更)処理に先んじて、
フォルダオブジェクトから全てのファイル名を文字列として取り出し、
それらで構成された配列変数を作成するコトで対策とするコトにした。
コレも、よく使う処理なので別途関数にした、ソレが、Function F2a・・・
簡単な処理だが、ある と ない とではエラくちがう(^_^;

オマケだか、上記誤処理をデバッグする過程でデキた、云わば副産物の、
動作中の対象文字列の収集と表示を行う関数 も同梱してあったりするw


で、ソースはコチラ▼
    '***** ↓↓↓ScriptTitle↓↓↓ *********************************************************     
'MultiReplacedRename
'- Created by LazwardFox -

'

'Update 20090504 0227 拡張子なしファイルを、フォルダと誤認しないよう処理を追記
'Release 20090430 1843 ファイル名から動作を取得 / スクリプト名称変更
'βRelease 20090430 1755
'DevStart 20090424 2200

'***** ↓↓↓ ObjectDecralations ↓↓↓ *************************************************
Public My, Parameters, MySh, Fs
Set My = WScript
Set Parameters = My.Arguments 'パラメーター取得
If Parameters.Count <= 0 Then 'パラメータなし起動の無効化
My.Quit
End If

Set MySh = My.CreateObject("WScript.Shell")
Set Fs = My.CreateObject("Scripting.FileSystemObject") 'ファイル制御

'***** ↓↓↓ Decralations ↓↓↓ *************************************************

Public ThisScriptFull, ThisScript, Start
Const vbWq = """"

Dim vbWCrLf, vbTc
vbWCrLf = vbCrLf & vbCrLf
vbTc = vbTab & vbCrLf

Dim Source, Extention
Dim cParameters, pDepth, tExt

'***** ↓↓↓MainRoutine↓↓↓ *********************************************************
'On Error Resume Next
ThisScriptFull = My.ScriptFullName
ThisScript = Fs.GetBaseName(ThisScriptFull)
cParameters = Split(ThisScript,"_")
pDepth = Ubound(cParameters)
If pDepth >= 2 Then '▼ ファイル名から動作パラメータを取得
If pDepth > 2 Then
For Pc = 2 to pDepth
If tExt = "" Then
tExt = cParameters(Pc)
Else
tExt = tExt & "," & cParameters(Pc)
End If
Next
End If '▲
Else
My.Quit
End If
If Parameters.Count > 1 Then '多数ドロップ時のみ確認画面表示
Start = MySh.Popup("RenameStart?",15,ThisScript,33)
End If
If Start = -1 Or Start = 2 Then
Else
For Each Source in Parameters
Extention = Lcase(Fs.GetExtensionName(Source))
If Extention = "" Then
If Fs.FolderExists(strParameters) Then '拡張子なしファイルをハジく
'Folder
Dim arFiles, SourceFile
arFiles = F2a(Source)
For Each SourceFile in arFiles
'iTest SourceFile & " / Folder",15
fReplace SourceFile, cParameters(0), cParameters(1), tExt
Next
End If
Else
'File
'iTest Source & " / File",15
fReplace Source, cParameters(0), cParameters(1), tExt
End If
Next
'iTest "ResultCheck",0
MySh.Popup "Renamed",15,ThisScript,33
End If
Set Fs = Nothing
Set MySh = Nothing
My.Quit

'***** ↓↓↓Functions↓↓↓ *********************************************************
'------------------------------------
'F2a 指定フォルダ内ファイル一覧を配列化
'- Created by LazwardFox -

'Fs

' Update -------- ----
' Release 20090430 1703

Function F2a(strTarget)
Dim objFolder, arF2a(), Pc
Pc = 0
Set objFolder = Fs.GetFolder(strTarget)
For Each strTarget in objFolder.Files
Redim Preserve arF2a(Pc)
arF2a(Pc) = strTarget
Pc = Pc + 1
Next
Set objFolder = Nothing
Pc = 0
F2a = arF2a
End Function

'------------------------------------
'fReplace ファイル名内の指定文字列を置換する。
'- Created by LazwardFox -

'Fs, iRename, dRename

' Update 20090430 0120 機能毎に部品化
' Update 20090425 0053 拡張子による条件化を追加
' Release 20090425 2110

Function fReplace(strTarget, strSource, strReplace, strExts)
Dim Replaced, objTarget, RootPath, ReplacedFull '途中パスの誤置換防止 ▼
RootPath = Fs.GetParentFolderName(strTarget)
Replaced = Replace(Fs.GetFileName(strTarget),strSource,strReplace)
ReplacedFull = Fs.BuildPath(RootPath, Replaced) '▲
dRename ReplacedFull '既存バックアップ
If strExts = "" Then
Else
Dim arExts, tExt '指定拡張子識別 ▼
arExts = Split(strExts,",")
lExt = LCase(Fs.GetExtensionName(strTarget))
For Each tExt in arExts
If tExt = lExt Then
Exit For
End If
tExt = ""
Next
If tExt = "" Then
Exit Function
End If '▲
End If
iRename strTarget, Replaced
End Function

'------------------------------------
'iRename 既存ファイルの名称を変更
'- Created by LazwardFox -

'Fs

' Update -------- ----
' Release 20090429 1727

Function iRename(Target, strRename)
Dim objTarget
If Fs.FileExists(Target) Then
Set objTarget = Fs.GetFile(Target)
objTarget.Name = strRename
Set objTarget = Nothing
End IF
End Function

'------------------------------------
'dRename 指定ファイル既存の場合、ファイル名に日時を添付。既存バックアップ向け
'- Created by LazwardFox -

'Fs, iDT, iRename

' Update -------- ----
' Release 20090430 0051

Function dRename(Target)
Dim dExt, Deted
If Fs.FileExists(Target) Then
dExt = "." & LCase(Fs.GetExtensionName(Target))
Deted = Replace(Fs.GetFileName(Target),dExt," " & iDT(""," ","",0) & dExt)
iRename Target, Dated
End IF
End Function

'------------------------------------
'iDT - 日時文字列 ないし 日/時配列取得 for VBScript
'- Created by LazwardFox -

' Update 20090228 0458 変数宣言変更
' Update 20090223 0959 時刻桁処理変更
' Update 20090223 0253 Len記述忘れ修正
' Update 20090223 0135 変数宣言忘れ修正
' Update 20090210 0218
' Update 20090210 0115
' Release 20090209 2035

' iDT (
' dSplitter - DateSplitString (Normal - "/")
' ,dtSeparater - Date/Time SepaleteString (Normal - " ")
' ,tSplitter - TimeSplitString (Normal - ":")
' ,Control - 文字列 0 or 配列 1 (Default - 1)
' )

Public Function iDT(dSplitter,dtSeparater,tSplitter,Control)
Dim nX, nD, nS, strHMS, sResult 'Update 20090228 0458
nX = Now()
nD = FormatDateTime(Date(),0)
nS = ":" & Split(CStr(FormatDateTime(nX,3)),":")(2) 'Update 20090223 0951
strHMS = FormatDateTime(nX,4) & nS 'Update 20090223 0951
If tSplitter = ":" Then
Else
strHMS = Replace(strHMS,":",tSplitter)
End If
sResult = Cstr(Replace(nD,"/",dSplitter)) & "*" & strHMS
If Control = 1 Then
iDT = Split(sResult,"*")
Else
iDT = Replace(sResult,"*",dtSeparater)
End If
End Function

'------------------------------------
'iTest 動作テスト テキストデータ累積収集と表示
'- Created by LazwardFox -

' Update -------- ----
' Release 20090430 1746 表示処理も統合
' βRelease 20090430 1700 累積収集のみ機能

Public strTests, tPc
Function iTest(strTarget, Control)
If Control > 0 Then
If tPc > Control Then
tPc = 0
strTests = strTests & "," & strTarget
Else
If strTests = "" Then
strTests = strTarget
Else
strTests = strTests & vbTc & strTarget
End If
End If
tPc = tPc + 1
Else
Dim arTarget, vTarget
arTarget = Split(strTests,",")
For Each vTarget In arTarget
Msgbox vTarget,,strTarget
Next
End If
End Function
<そのまま使える SIGMA SD14 SDIM####.X3F カウント 9999 少ない 欠点 ファイル 名称 まとめて置換 日付 バックアップ>