Option Explicit
On Error Resume Next

Dim Arg, WS, FS, SH, File, Path, Ret
Set Arg = WScript.Arguments
Set WS  = WScript.CreateObject("WScript.Shell")
Set FS  = WScript.CreateObject("Scripting.FileSystemObject")
Set SH  = WScript.CreateObject("Shell.Application")

If Arg.Count = 1 Then
  Path = Arg(0)
  If FS.FolderExists(Path) Then
    call FileList(Path)
  Else
    Ret = WS.Popup( "オプション指定に間違いがあります！" _
                   , 3 _
                   , "確認" _
                   , 0)
  End If
Else
  Ret = WS.Popup( "フォルダを指定して下さい！" _
                 , 3 _
                 , "確認" _
                 , 0)
End If

Set SH  = Nothing
Set FS  = Nothing
Set WS  = Nothing
Set Arg = Nothing
WScript.Quit

'-----------------------------------------------------------------------
Function FileList(Path)
  Dim f, f1, subf
  Path = FS.GetAbsolutePathName(Path)
  Set f = FS.GetFolder(Path)
  'すべてのファイルを表示
  WScript.Echo Path
  For Each f1 In f.Files
      call GetKTitle(f1.Path)
  Next
  WScript.Echo
  'すべてのサブフォルダを表示
  For Each subf In f.SubFolders
      call FileList(subf.Path)
  Next
End Function
'-----------------------------------------------------------------------
Function GetKTitle(File)
  Dim SubPath, Name, ShortName, Size, Last, ShortExt, ShortBaseName, TrueName
  Dim NS, Stream, c1, c2, i ,j, Title, Ver, TimeC, TimeM
  SubPath  = FS.GetParentFolderName(File)
  Name     = FS.GetFile(File).Name
  ShortName= FS.GetFile(File).ShortName
  Size     = FS.GetFile(File).Size
  Last     = FS.GetFile(File).DateLastModified
  ShortExt = FS.GetExtensionName(ShortName)
  ShortBaseName = FS.GetBaseName(ShortName)
  If IsNull(SubPath) Or SubPath = "" Then SubPath = FS.GetAbsolutePathName(".\")
  Set NS   = SH.NameSpace(SubPath)
  TrueName = NS.ParseName(Name)
  Set NS   = Nothing

  If Size < 4096 Then
    Ver   = Space(3)
    Title = Space(40)
    TimeC = Space(6)
    TimeM = Space(6)

  ElseIf InStr(".TBL,.WFM,.FRM,.RPT,.VIW,.XVW,.CMD,.KEV", UCase(Right(File, 4))) = 0 Then
    Ver   = Space(3)
    Title = Space(40)
    TimeC = Space(6)
    TimeM = Space(6)

  Else
    Dim Data(41), Bin(2), T0(7), T1(7)
    Const adTypeBinary = 1
    Const adTypeText = 2
    Const adModeUnknown = 0 'Default
    Const adModeRead = 1
    Const adModeWrite = 2
    Const adModeReadWrite = 3
    Const adModeShareDenyRead = 4
    Const adModeShareDenyWrite = 8
    Const adModeShareExclusive = 12
    Const adModeRecursive = &H400000
    Const adSaveCreateNotExist = 1
    Const adSaveCreateOverWrite = 2
    Const adReadAll = -1

    Set Stream = WScript.CreateObject("Adodb.Stream")
    Stream.Type = adTypeBinary
    Stream.Mode = adModeReadWrite
    Stream.Open
    Stream.LoadFromFile File

  ' 対象ファイルの先頭「0x00」を読み込む
    Stream.Position = &H00
    Bin(0) = Stream.Read(1)

  ' 対象ファイルのバージョン「0x30」を読み込む
    Stream.Position = &H30
    Bin(1) = Stream.Read(1)
    If UCase(Right(File,4)) = ".WFM" And AscB(Bin(1)) = 7 Then
      Stream.Position = &H33
      Bin(1) = Stream.Read(1)
    End If

  ' 対象ファイルの表題「0x34〜0x5B」を読み込む
    Stream.Position = &H34
    For i=1 To 40
      Data(i) = Stream.Read(1)
    Next

  ' 対象ファイルの作成日「0x9C〜0xA1」を読み込む
    Stream.Position = &H9C
    For i=1 To 6
      T0(i) = Stream.Read(1)
    Next

  ' 対象ファイルの更新日「0xA2〜0xA7」を読み込む
    Stream.Position = &HA2
    For i=1 To 6
      T1(i) = Stream.Read(1)
    Next

    Stream.Close
    Set Stream = Nothing

    ' 桐のファイルか否かを 0x00h とバージョン情報でチェックする
    If (AscB(Bin(0)) = 0 And AscB(Bin(1)) >= 1 And AscB(Bin(1)) <= 9) Then
      ' バージョン情報を文字列に変換する
      Ver = "[" & Chr(AscB(Bin(1)) + &H30) & "]"

      ' 表題を JIS から SJIS にコード変換する
      i = 0 : j = 0 : Title = ""
      For i = 1 To 40
        If (i mod 2) = 0 Then
          c1 = AscB(Data(i))
          c2 = AscB(Data(i-1))
          If (c1 <> 0) Then
            If (c1 mod 2) = 1 Then
              c1 = ((c1 + 1) / 2) + &H70
              c2 = c2 + &H1F
            Else
              c1 = (c1 / 2) + &H70
              c2 = c2 + &H7D
            End If
            If (c1 >= &HA0) Then c1 = c1 + &H40
            If (c2 >= &H7F) Then c2 = c2 + 1
          ElseIf (c1 = 0 And c2 = 0) Then
            c2 = AscB(" ")
            j = j + 1
          Else
            j = j + 1
          End If
          Title = Title & Chr(c1 * &H100 + c2)
        End If
      Next
      Title = Title & Space(j)

      ' 作成日を文字列に変換する
      For i=1 To 6
        TimeC = TimeC & Chr(AscB(T0(i)))
      Next

      ' 更新日を文字列に変換する
      For i=1 To 6
        TimeM = TimeM & Chr(AscB(T1(i)))
      Next

    ' 桐のファイルで無い場合の処理
    Else
      Ver   = Space(3)
      Title = Space(40)
      TimeC = Space(6)
      TimeM = Space(6)

    End If

  End If

  If (Name = ShortName) Then
    ShortName = Space(12)
  Else
    ShortName = ShortBaseName & _
                Space(8 - (Len(ShortBaseName) + DblCnt(ShortBaseName))) & _
                "." & _
                ShortExt & _
                Space(3 - (Len(ShortExt) + DblCnt(ShortExt)))
  End If

' 表題を出力する
  WScript.Echo FormatDateTime(Last,2) & _
               " " & _
               FormatDateTime(Last,3) & _
               " " & _
               Right(Space(11) & FormatNumber(Size,0,-1,0,-1),11) & _
               " " & _
               Ver & _
               " " & _
               TimeC & _
               " " & _
               TimeM & _
               " " & _
               Title & _
               " " & _
               ShortName & _
               " " & _
               TrueName

End Function
'-----------------------------------------------------------------------
Function DblCnt(String)
  Dim objRE, Matches, ank
  Set objRE = New RegExp
  objRE.IgnoreCase = True
  objRE.Global = True
  objRE.Pattern = "([\ -~]|[｡-ﾟ])"
  Set Matches = objRE.Execute(String)
  ank = Matches.Count
  DblCnt = Len(String) - ank
  Set objRE = Nothing
End Function
'-----------------------------------------------------------------------