趣味プログラミングblog

前回投稿したGoogleSearhConsoleで直近１か月のページごとのアクセス数を見ると
圧倒的に以下のtreeコマンドのページが多い。

「Windowsのtreeコマンドで3階層目までだけを表示する方法」


この方法を自分で使っていて思うのは、フォルダ数が多いNASに対して
２階層と３階層それぞれの結果を取りたいときにめんどくさい。。。

今回は、treeコマンドの結果をインポートして
階層別にファイル出力するスクリプトについて検討した話。

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

「ファイル・フォルダ一覧取得ツール～Dirコマンドの結果から生成～」シリーズ
①操作編
②VBS編【今回】
③VBAファイルリスト編
④VBAフォルダリスト編

ファイル・フォルダ一覧取得ツールの続編。
今回は、DIRコマンドをクリップボードに送るVBScriptについて。

VBScriptを実行すると、InputBoxが表示されて絞り込みキーワードの入力を促す。

何も入力しなかった場合（キャンセル押した場合）は、絞り込みなし。フォルダを指定
キーワードを入力した場合は、キーワードで絞り込んだコマンドを生成する。

---

まずはコマンドプロンプトで入力するDirコマンドについて説明。

エクセルVBAで時間のかかる処理をさせるときは、
application.statusbar で進捗状況を表示できる。

でもVBScriptだとWindows上で動作するので表示するアプリケーションがない。


検索すると、IEオブジェクトを使ってプログレスバーを表示することができるようだ。

う～ん。めんどい！
IEオブジェクトなんてわかんないもんね。


なんかしら表示が出れば・・・

前回、「Windowsのtreeコマンドで3階層目までだけを表示する方法」を紹介した。

２層までtreeコマンド
tree [フォルダパス] | findstr /R /C:"^├─" /C:"^└─" /C:"^│ ├─" /C:"^│ └─" /C:"^ ├" /C:"^ └"

３層までtreeコマンド
tree [フォルダパス] | findstr /R /C:"^├─" /C:"^└─" /C:"^│ ├─" /C:"^│ └─" /C:"^ ├" /C:"^ └" /C:"^│ │ ├─" /C:"^│ │ └─" /C:"^│ └" /C:"^│ ├" /C:"^ │ ├" /C:"^ │ └" /C:"^ ├" /C:"^ └"


パイプ以下を辞書登録したいところだけど、
長すぎて辞書登録ができない。

いちいちテキストファイルからコピペするのはだるいので、
VBScriptでクリップボードに送るソースを書いてみた。