趣味プログラミングblog

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