忍者ブログ

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
  Vodafone絵文字 i-mode絵文字 Ezweb絵文字