CSVファイルのタイトル行を削除してリネームするスクリプト
2022年12月28日
A5アプリを使っているんだけど、
データベースからCSVファイルを抽出するときに、
タイトル行を出力するかしないかオプションで選択できる。
設定すると次回抽出するときに保持されるので、
たまにタイトル行が不要なときにめんどくさい。
あと、たくさんのCSVファイルを抽出するのに
いちいちファイル名を正しく入力するのもめんどくさい。
めんどくさがりな自分のために、
CSVファイルのタイトル行を削除して、特定のファイル名に変更するスクリプトを作った。
これまで作ったVBScriptとあんまり変わんないけど、
ドラッグドロップを使って進捗状況を表示する機能は
一般的に使えそうなので投稿。
当初は、テキストの内容をバッファに保持して、
まとめてテキストに書き込む作りにしていたけど、
CSVファイルの行数が多いと遅くなるので
読みだした文字列をそのまま出力ファイルに送る仕様にした。
圧倒的に速い!!!
以下、ソース。ソーステキストは こちら。
Option Explicit
'ファイルドロップ共通モジュール 起動条件で分岐してメイン処理を呼ぶ
call FileDrop()
'ファイルをドロップした場合
sub Main_File(strFullName)
if right(strFullName, 4) <> ".csv" then call errorEnd("CSV以外のファイルは対応していません。")
dim FSO: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim inputFile: Set inputFile = FSO.OpenTextFile(strFullName, 1, False, 0)
dim strHead: strHead =inputFile.ReadLine 'タイトル行は別名で読みだして捨てる
'出力フォルダは、ファイルと同じ階層にoutputフォルダを作る
Dim outPath: outPath = getPath(strFullName) & "output\"
call makeFolder(outPath)
'出力ファイル名は、フルパスからファイル名を取り出して、makeNewname関数を通す
dim outName: outName = makeNewname(getFileName(strFullName))
dim outputFile : set outputFile = FSO.OpenTextFile(outPath & outName , 2, True)
'読みだした文字列をそのまま書き込む(バッファに入れると遅くなる)
Do Until inputFile.AtEndOfStream
outputFile.write inputFile.ReadLine & chr(10)
Loop
inputFile.Close' バッファを Flush してファイルを閉じる
outputFile.Close' バッファを Flush してファイルを閉じる
set FSO = nothing
end sub
Function getPath(strFullName)
dim fileName : fileName = getFileName(strFullName)
dim filePath : filePath =left(strFullName,len(strFullName)-len(fileName))
getPath = filePath
end function
Function getFileName(FileName )
Dim yPos
yPos = InStrRev(FileName, "\")
If yPos <> 0 Then
getFileName = Right(FileName, Len(FileName) - yPos)
Else
getFileName = ""
End If
End Function
'特定ファイルは固定名、他は"_delTitle"を追加
function makeNewname(fName)
dim outName
dim baseName : baseName = replace(fName,".csv","")
select case baseName
case "1": outName = "A.csv"
case "2": outName = "B.csv"
case "3": outName = "C.csv"
case else : outName = baseName & "_delTitle.csv"
end select
makeNewname = outName
end function
'ファイルドロップ共通'-----------------------------------------------------------ここから
sub FileDrop
'ファイルドロップ共通モジュール ファイルならメイン処理を呼ぶ
dim strFileName, strFullName
dim cnt, prgPath:prgPath = getPath(Wscript.scriptFullname) '進捗表示用
If WScript.Arguments.count = 0 then '引数なし
call Main_noFile()
else '引数ありの場合
with CreateObject("Scripting.FileSystemObject")
for each strFullName In WScript.Arguments
cnt = cnt + 1
call outputProgress(cnt & "件/" & WScript.Arguments.count,prgPath)'プログレス表示
If .FolderExists(strFullName) then ' is folder.
call Main_Folder(strFullName)
ElseIf .FileExists(strFullName) then' is file.
Call Main_Filer(strFullName)
else ' is unknown.
call errorEnd("謎のデータがドロップされました。終了します。")
End If
Next
end with
end if
call outputProgress("",prgPath)'プログレス表示
msgbox cnt & "件のファイルのタイトル行を削除しました。"
end sub
sub Main_noFile()'VBSを直接実行した場合
call errorEnd("リネーム対象のファイルをドラッグドロップしてください。")
end sub
sub Main_Folder(strFullName)'フォルダをドロップした場合
call errorEnd("フォルダは対象外です。リネーム対象のファイルをドラッグドロップしてください。")
end sub
'ファイルドロップ共通'-----------------------------------------------------------ここまで
'フォルダがなければ作る。あればメッセを出す
sub makeFolder(DirName)
dim objFS,str_path
' ファイルストリーム・オブジェクト生成
Set objFS = CreateObject("Scripting.FileSystemObject")
If objFS.FolderExists(DirName) Then
'msgbox "すでにフォルダが存在します"
else
' フォルダを生成する
str_path = objFS.CreateFolder(DirName)
end if
end sub
'エラーメッセージを表示して終了する
sub ErrorEnd(msg)
set FSO = nothing
WScript.Echo msg
WScript.Quit
end sub
'プログレス表示ファイル
sub outputProgress(text,oPath)
call deletePrgrsFile(oPath)
if text <> "" then call makePrgrsFile(text,oPath)
end sub
private sub deletePrgrsFile(oPath)
on error resume next
dim tarFile:tarFile = oPath & "*.prgrs"
with CreateObject("Scripting.FileSystemObject")
.DeleteFile tarFile
end with
end sub
private Sub makePrgrsFile(text,oPath)
dim strNow: strNow = replace(now,"/","")
dim strFile: strFile = oPath & "VBS進行率:" & text & ".prgrs"
dim objFS: Set objFS = CreateObject("Scripting.FileSystemObject")
dim obfFile : Set obfFile = objFS.CreateTextFile(strFile) ' ファイル作成
set objFS = nothing
set obfFile = nothing
end sub
PR
Comment