趣味プログラミングblog

---

Option Explicit
Const FulNameOnly = 0 'オプション　0:フォルダ名、ファイル名、ファイルサイズ、更新日時を出力　1:フルパスファイル名のみ

'ドラッグドロップでファイルを印刷するスクリプト
'http://chuckischarles.hatenablog.com/entry/2018/10/29/002921
'-------------------------------------------------------------------------------------------------------
' 引数が無かった時の処理
If WScript.Arguments.count = 0 then
WScript.Echo "引数が無いため、実行できません。" & vbNewLine & _
"ファイルをドロップしてください。"
WScript.Quit
End If

'確認
' if msgbox("更新日時でリネームします。よろしいでしょうか？",vbyesno) = vbno then
' WScript.Quit
' end if
dim targetPath,FilePath
dim FSO
'----------------------------------------------------------------------------------------------------
' ファイルシステムオブジェクト作成
Set FSO = CreateObject("Scripting.FileSystemObject")
'-------------------------------------------------------------------------------------------------------
' フォルダ内ファイルリスト出力
for each targetPath In WScript.Arguments
'----------------------------------------------------------------------------------------------------
' ドロップされた引数がフォルダかファイルかを判定する
If FSO.FolderExists(targetPath) then
' is folder.
WScript.Echo "フォルダがドロップされました。" & vbNewLine & _
"処理を終了します。"
WScript.Quit
ElseIf FSO.FileExists(targetPath) then
' is file.
else
' is unknown.
WScript.Echo "フォルダ 及び ファイル とも認識できないデータがドロップされました。" & vbNewLine & _
"処理を終了します。"
WScript.Quit
End If

' メインモジュール呼び出し
Call ChangeFormatMain(targetPath)

Next

set FSO = nothing

'-----------------------------------------------------------実質ここから
'------------------------------
' メイン処理
'------------------------------
Sub ChangeFormatMain(targetPath)

const strCode = "Shift-Jis" ' 文字コード指定 "Shift-Jis" "UTF-8"

Dim input: Set input = CreateObject("ADODB.Stream")
input.Type = 2 ' 1：バイナリ・2：テキスト
input.Charset = strCode ' 文字コード指定
input.Open ' Stream オブジェクトを開く
input.LoadFromFile targetPath ' ファイルを読み込む


Dim StrText,buf,Ext,Path,strDate,fSize,fname
Dim Dic: Set Dic = CreateObject("Scripting.Dictionary")
Dim dirDic: Set dirDic = CreateObject("Scripting.Dictionary")


Do Until input.EOS 'https://qiita.com/5zm/items/a8ba71d47d161b52c823
buf = input.ReadText(-2) ' -1：全行読み込み・-2：一行読み込み
If Right(buf, Len("のディレクトリ")) = "のディレクトリ" Then
Path = Trim(Replace(buf, "のディレクトリ", ""))
ElseIf Mid(buf, 5, 1) = "/" And Mid(buf, 8, 1) = "/" Then
strDate = Replace(Trim(Mid(buf, 1, 17)), " ", " ")
fSize = Trim(Replace(Mid(buf, 19, 17),"バイト",""))
fname = Trim(Mid(buf, 37, Len(buf) - 37 + 1))
Ext = getExt(fname)
If fname <> "." And fname <> ".." Then
Dic.Add Path & "\" & fname, getFileName(Path) & "‡" & fname & "‡" & strDate & "‡" & fSize & "‡" & Ext
End If
ElseIf Right(buf, 3) = "バイト" Then
'dirDic.Add Path, buf
End If
Loop
' Stream を閉じる
input.Close

Dim keys: keys = Dic.keys
Dim Items: Items = Dic.Items
Set Dic = Nothing

Dim oBuf, i , j , fCnt , dSize , strItem
For i = 0 To UBound(keys)
oBuf = Split(Items(i), "‡")
If oBuf(3) <> "" Then
if FulNameOnly = 1 then
StrText = StrText & keys(i) & chr(10)
else
StrText = StrText & keys(i) & "‡" & Items(i) & chr(10)
end if
end if
Next

' 書き出しファイルの指定 (今回は新規作成する)
Dim output: Set output = CreateObject("ADODB.Stream")
output.Type = 2
output.Charset = strCode
output.Open
output.WriteText StrText, 0 ' 0：文字列のみ書き込み・1：文字列 + 改行を書き込み

dim FulSaveName
FulSaveName = MakeOutputPath(targetPath)
' 書き出しファイルの保存
output.SaveToFile FulSaveName , 2 '1：指定ファイルがなければ新規作成・2：ファイルがある場合は上書き

output.Close

'ログファイルを開く
call OpenTextFileShell(FulSaveName)

End Sub


'------------------------------
' CMDで指定したファイルを開く
'------------------------------
sub OpenTextFileShell(FulName)

Dim objWshShell
'シェルオブジェクトの作成
Set objWshShell = WScript.CreateObject("WScript.Shell")
'シェルの実行
objWshShell.Run FulName

end sub

Function MakeOutputPath(targetPath)
dim fileName :fileName = getFileName(targetPath)
dim filePath: filePath = left(targetPath,len(targetPath)-len(fileName))

MakeOutputPath = filePath & "【dirB_" & FulNameOnly & "】" & fileName

end function

Function getExt(FileName)
Dim pPos
pPos = InStrRev(FileName, ".")
If pPos <> 0 Then
getExt = Right(FileName, Len(FileName) - pPos)
Else
getExt = ""
End If
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