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, Size, Last, TrueName
  Dim NS, Stream, c1, c2, i ,j, Title
  SubPath  = FS.GetParentFolderName(File)
  Name     = FS.GetFile(File).Name
  Size     = FS.GetFile(File).Size
  Last     = FS.GetFile(File).DateLastModified
  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
    Title = Space(40)

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

  Else
    Dim Data(41), Bin(2)
    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

    Stream.Close
    Set Stream = Nothing

    ' 桐のファイルか否かを 0x00h とバージョン情報でチェックする
    If (AscB(Bin(0)) = 0 And AscB(Bin(1)) >= 1 And AscB(Bin(1)) <= 9) Then
      ' 表題を 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)

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

    End If

  End If

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

End Function
'-----------------------------------------------------------------------