2004.11.24：公開
2004.11.24：いろいろ更新

'kdata_to_xs.vbs
'
Const fn_out = "c:\work\test.xls" '出力ファイル
Const fn_data = "c:\work\data.txt" 'データファイル
Const view_Excel = False 'Excelを開くかどうか。値はTrue,False

Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
If (NOT fso.FileExists(fn_data)) Then
  MsgBox("データファイルがありません")
  WScript.Quit
End If

'ファイルを読み込んで変数に代入
Dim sitename,siteurl
Dim data_ta(),data_ti(),data_tu() ' 読み込むデータの配列
LoadData1 '<関数呼び出し>
MsgBox sitename & ":" & siteurl

'データをDictionaryに保存して扱いやすくする
Dim d1,d2
Set d1 = CreateObject("Scripting.Dictionary")'感想率
Set d2 = CreateObject("Scripting.Dictionary")'コメント
Set d3 = CreateObject("Scripting.Dictionary")'新番組継続
Set d4 = CreateObject("Scripting.Dictionary")'新番組コメント
Set d5 = CreateObject("Scripting.Dictionary")'終了番組評価
Set d6 = CreateObject("Scripting.Dictionary")'終了番組コメント
AddDictionary data_ta,d1,d2'<関数呼び出し>
AddDictionary data_ti,d3,d4'<関数呼び出し>
AddDictionary data_tu,d5,d6'<関数呼び出し>

'Excelでの処理開始
Dim xla,wb
Set xla = WScript.CreateObject("Excel.Application")
Set wb =  xla.Workbooks
xla.Visible = view_Excel

'出力ファイルが存在しなければ新たに作成
Dim newbook
If (NOT fso.FileExists(fn_out)) Then
  Set newbook = wb.Add
  newbook.SaveAs fn_out
End If
Set newbook = Nothing

'ファイルを開いて処理して保存
wb.Open fn_out
  Dim sheet1,d_keys
  Set sheet1 = wb.Item(1).Worksheets("Sheet1")

sheet1.Cells.Clear
   d_keys = d1.Keys 
   For I = 1 To d1.Count
    sheet1.Cells(I,1).Value = d_keys(I-1) '番組名
    sheet1.Cells(I,2).Value = d1.Item(d_keys(I-1)) '感想率
    sheet1.Cells(I,3).Value = d2.Item(d_keys(I-1)) 'コメント
   Next
   d_keys = d3.Keys 
   For I = 1 To d3.Count
    sheet1.Cells(I,4).Value = d_keys(I-1) '番組名
    sheet1.Cells(I,5).Value = d3.Item(d_keys(I-1)) '新番組継続
    sheet1.Cells(I,6).Value = d4.Item(d_keys(I-1)) 'コメント
   Next
   d_keys = d5.Keys 
   For I = 1 To d5.Count
    sheet1.Cells(I,7).Value = d_keys(I-1) '番組名
    sheet1.Cells(I,8).Value = d5.Item(d_keys(I-1)) '終了番組評価
    sheet1.Cells(I,9).Value = d6.Item(d_keys(I-1)) 'コメント
   Next

  wb.Item(1).Save
wb.Close

'終了
xla.Quit


'読み込み関数
Sub LoadData1()

Dim f,data,IA,IA_max,phase,fl_read
Const IA_add = 30
ReDim data_ta(IA_add)
ReDim data_ti(IA_add)
ReDim data_tu(IA_add)

Set f = fso.OpenTextFile(fn_data, 1) 'ReadOnly
  Do While f.AtEndOfStream <> True
     If (fl_read = 0) Then data = f.ReadLine '読み込んでないときは読み込む
     fl_read = 0
     phase = 0
     If (InStr(data,"***感想率調査***") = 1 ) Then '感想率調査
       phase = 1
     ElseIf (InStr(data,"***新番組アンケート***") = 1 ) Then '新番組
       phase = 2
     ElseIf (InStr(data,"***終了番組アンケート***") = 1 ) Then '終了番組
       phase = 3
     ElseIf (InStr(data,"***サイトデータ***") = 1 ) Then 'サイト名とURL
       Do While f.AtEndOfStream <> True
         data = f.ReadLine
         If (InStr(data,"***") = 1 ) Then 
           fl_read = 1
           Exit Do
         ElseIf (InStr(data,"サイト名：") = 1 ) Then
           sitename = Mid(data,6)
         ElseIf (InStr(data,"URL：") = 1 ) Then
           siteurl = Mid(data,5)
         Else
         End If '***
       Loop
     End If '***感想率調査***

     If (phase >= 1) Then
       IA = 0
       IA_max = IA_add
       Do While f.AtEndOfStream <> True
         data = f.ReadLine
         If (InStr(data,"***") = 1 ) Then
           fl_read = 1
           Exit Do
         'ElseIf (data = "") Then
         Else
           If (phase = 1) Then data_ta(IA) = data
           If (phase = 2) Then data_ti(IA) = data
           If (phase = 3) Then data_tu(IA) = data
           IA = IA + 1
           If IA > IA_max Then '配列数変更
             IA_max = IA_max + IA_add
             If (phase = 1) Then ReDim Preserve data_ta(IA_max)
             If (phase = 2) Then ReDim Preserve data_ti(IA_max)
             If (phase = 3) Then ReDim Preserve data_tu(IA_max)
           End If
         End If '***
       Loop
     End If
  Loop
f.Close

End Sub

'処理関数
Sub AddDictionary(data_array,dic1,dic2)

Dim reg,match,matches,matchsub1,matchsub2,matchsub3,commentcheck
Set reg = New RegExp
reg.Pattern = "([^,]*),([^,]*),(.*)"
For Each tempstr in data_array
  I = I + 1
  Set matches = reg.Execute(tempstr)
  If (matches.Count = 1) Then
    If (commentcheck = 1) Then '改行入りコメントではないとみなす
      commentcheck = 0
      dic1.Add matchsub1,matchsub2
      dic2.Add matchsub1,Replace(matchsub3,"↓改行↓","")
    End If
    For Each match in matches
      matchsub1 = match.SubMatches(0)
      matchsub2 = match.SubMatches(1)
      matchsub3 = match.SubMatches(2)
      If (InStr(matchsub3,"↓改行↓") < 1) Then
        commentcheck = 1
      Else
        dic1.Add matchsub1,matchsub2
        dic2.Add matchsub1,Replace(matchsub3,"↓改行↓","")
      End If
    Next
  ElseIf (commentcheck = 1) Then '改行入りコメント
    matchsub3 = matchsub3 & vbNewLine &tempstr
    If (InStr(matchsub3,"↓改行↓") >= 1) Then
      commentcheck = 0
      dic1.Add matchsub1,matchsub2
      dic2.Add matchsub1,Replace(matchsub3,"↓改行↓","")
    End If
  Else
  End If
Next

End Sub