作成 2010.01.07
更新 2010.01.07
VBScript で CSV の読み取り
目次
概要
CSVReader クラス
使い方
概要

じゃんぬねっと氏作 CsvReader クラス を作りなおしました。 CSVフォーマット を文字コードの問題以外すべてサポートしています。
オリジナルとの主な違いは、以下の通り。

  • ReadLine → 1レコードの文字列を返します。代わりにGetRow を使用してください。
  • ReadToEnd メソッドを実装していません。全部読み込むメソッドが必要になるケースに遭遇しないので。
  • フィールド内の改行は vbNewLine (CRLF) に変更されます。
  • 最初のフィールドを読み込まない仕様を読み込むように変えています。
  • ヘッダー フィールドよりもレコード フィールドが多くても動作します。
  • ヘッダー フィールドの名前が重複していたら左側のフィールドのみアクセスできます。インデックスを直接指定したら両方アクセスできます。
CSVReader クラス
Option Explicit

' CsvReader クラス
Class CsvReader
  ' ストリーム
  Private p_TextStream ' As TextStream
  ' ヘッダーの有無 - True だと最初のレコードをヘッダーとして扱う
  Private p_HeaderExists ' As Boolean
  ' ヘッダー名と格納されているキーの関連付け
  Private p_Header ' As Dictionary

  ' コンストラクタ
  Private Sub Class_Initialize()
    Set p_TextStream = Nothing
    p_HeaderExists = False
    Set p_Header = Nothing
  End Sub

  ' デストラクタ
  Private Sub Class_Terminate()
    Call Close()
  End Sub

  ' ヘッダーの有無を設定する
  ' 読み取り中の場合は効果なし
  Public Property Let HeaderExists(ByVal exists) ' As Boolean
    If p_TextStream Is Nothing Then
      p_HeaderExists = exists
      Set p_Header = Nothing
      If exists Then Set p_Header = WScript.CreateObject("Scripting.Dictionary")
    End If
  End Property

  ' ヘッダーがあるなら True
  Public Property Get HeaderExists() ' As Boolean
    HeaderExists = p_HeaderExists
  End Property

  ' ヘッダーを提供
  ' HeaderExists = False の場合は Nothing
  Public Property Get Header() ' As Dictionary
    If Me.HeaderExists Then
      Set Header = p_Header
    Else
      Set Header = Nothing
    End If
  End Property

  ' 最終行だったら True
  Public Property Get AtEndOfStream() ' As Boolean
    If p_TextStream Is Nothing Then ' 無限ループ対策
      AtEndOfStream = True
    Else
      AtEndOfStream = p_TextStream.AtEndOfStream
    End If
  End Property

  ' 指定されたファイルを開き p_TextSream に指定
  ' 開くことができたら True を返す
  Public Function OpenFile(ByVal strFilePath) ' As Boolean
    Dim FSO ' As FileSystemObject
    Dim boolResult ' As Boolean
    boolResult = False
    Set FSO = WScript.CreateObject("Scripting.FileSystemObject")
    On Error Resume Next
    Set p_TextStream = FSO.OpenTextFile(strFilePath)
    If Err.Number = 0 Then
      On Error Goto 0
      ' ヘッダーの取得
      ' 2つ目のファイルを開くときのためにヘッダーをクリアする
      If Me.HeaderExists Then
        Call p_Header.RemoveAll() ' p_Header クリア
        Call SetHeaders()
      End If
      boolResult = True
    Else
      On Error Goto 0
    End If
    OpenFile = boolResult
  End Function

  ' ストリームを閉じる
  Public Sub Close()
    If Not p_TextStream Is Nothing Then
      On Error Resume Next
      Call p_TextStream.Close()
      On Error Goto 0
      Set p_TextStream = Nothing
    End If
  End Sub

  ' 1レコードをフィールドごとに分割した配列で取得する
  ' フィールド内の改行コードはすべて CrLf に変換される
  ' 最終行は改行のみの可能性がある
  Public Function ReadLineToArray()
    Dim strRest ' As String
    Dim fieldCount ' As Integer
    Dim retArr() ' As String
    Dim isEscape ' As Boolean
    Dim intNext ' As Integer
    If p_TextStream Is Nothing Then
      ReadLineToArray = retArr
      Exit Function
    End If
    strRest = p_TextStream.ReadLine()
    fieldCount = -1
    isEscape = False
    Do While Len(strRest) > 0
      ' フィールドの1文字目を調べる
      ' Chr(34), Chr(44), それ以外の可能性がある
      Select Case Left(strRest, 1)
      Case Chr(34) ' " の場合
        intNext = Instr(2, strRest, Chr(34), 0)
        If intNext = 0 Then
          strRest = strRest & vbNewLine & p_TextStream.ReadLine()
        Else
          If isEscape Then
            retArr(fieldCount) = retArr(fieldCount) & Chr(34) _
				& Mid(strRest, 2, intNext - 2)
          Else
            fieldCount = fieldCount + 1
            ReDim Preserve retArr(fieldCount)
            retArr(fieldCount) = Mid(strRest, 2, intNext - 2)
          End If
          strRest = Mid(strRest, intNext + 1)
          isEscape = True
        End If
      Case Chr(44) ' , の場合
        If isEscape Then ' 閉じダブルクォーテーションの直後だから
          isEscape = False
        Else
          fieldCount = fieldCount + 1
          ReDim Preserve retArr(fieldCount)
          retArr(fieldCount) = vbNullString
        End If
        strRest = Mid(strRest, 2)
      Case Else ' 通常の文字の場合
        intNext = Instr(2, strRest, Chr(44), 0)
        If isEscape Then
          isEscape = False
          If intNext = 0 Then ' 最終フィールド
            retArr(fieldCount) = retArr(fieldCount) & Left(strRest, Len(strRest) - 1)
            Exit Do
          Else
            retArr(fieldCount) = retArr(fieldCount) & Left(strRest, intNext - 1)
            strRest = Mid(strRest, intNext + 1)
          End If
        Else
          fieldCount = fieldCount + 1
          ReDim Preserve retArr(fieldCount)
          If intNext = 0 Then ' 最終フィールド
            retArr(fieldCount) = strRest
            Exit Do
          Else
            retArr(fieldCount) = Left(strRest, intNext - 1)
            strRest = Mid(strRest, intNext + 1)
          End If
        End If
      End Select
    Loop
    ReadLineToArray = retArr
  End Function

  ' ヘッダーフィールドを p_Header に格納
  ' OpenFile メソッドからのみ呼び出す
  Private Sub SetHeaders()
    Dim strArr, intCount
    strArr = ReadLineToArray()
    For intCount = 0 To UBound(strArr)
      ' ヘッダー名が重複したら左側を優先する
      ' 右側を取得するにはインデックスで。
      If Not p_Header.Exists(strArr(intCount)) Then
        Call p_Header.Add(strArr(intCount), intCount)
      End If
    Next
  End Sub

  ' 1レコードを Dictionary クラスとして受け取る
  Public Function GetRow() ' As Dictionary
    Dim strArr, intCount
    Dim fRow ' As Directory
    If Me.AtEndOfStream Then
      Set GetRow = Nothing
      Exit Function
    End If
    Set fRow = WScript.CreateObject("Scripting.Dictionary")
    strArr = ReadLineToArray()
    For intCount = 0 To UBound(strArr)
      Call fRow.Add(intCount, strArr(intCount))
    Next
    Set GetRow = fRow
  End Function

  ' 1レコードを文字列として読み取る。複数行あることに考慮
  Public Function ReadLine() ' As String
    If p_TextStream Is Nothing Then
      ReadLine = Null
      Exit Function
    End If
    ' 現在のレコードが次の行に続く限り継続
    ' レコード内に改行がたくさんあるとパフォーマンスは低下する
    ' フィールド内の改行コードはすべて CrLf に変換される
    Dim strLine
    strLine = p_TextStream.ReadLine()
    Do Until IsRecord(strLine)
      strLine = strLine & vbNewLine & p_TextStream.ReadLine()
      If Me.AtEndOfStream Then Exit Do
    Loop

    ReadLine = strLine
  End Function

  ' 文字列がレコードとして完結していたら True
  ' クラス内では ReadLine メソッドからのみ呼び出す
  Public Function IsRecord(ByVal strLine) ' As Boolean
    If IsNull(strLine) Then
      IsRecord = False
      Exit Function
    End If
    Dim returnValue ' As Boolean
    Dim strRest, intNext
    returnValue = True
    strRest = strLine
    Do While Len(strRest) > 0
      ' フィールドの1文字目を調べる
      ' Chr(34), Chr(44), それ以外の可能性がある
      Select Case Left(strRest, 1)
      Case Chr(34) ' " の場合
        intNext = Instr(2, strRest, Chr(34), 1)
        If intNext = 0 Then
          returnValue = False
          Exit Do
        Else
          strRest = Mid(strRest, intNext + 1)
        End If
      Case Chr(44) ' , の場合(空文字列)
        strRest = Mid(strRest, 2)
      Case Else
        intNext = Instr(2, strRest, Chr(44), 1)
        If intNext = 0 Then
          Exit Do
        Else
          strRest = Mid(strRest, intNext + 1)
        End If
      End Select
    Loop
    IsRecord = returnValue
  End Function

  ' 表示するコードをいちいち書くのが面倒なので
  Public Sub DebugPrintHeaders()
    Dim k
    WScript.Echo "DEBUG: " & String(20, "-")
    WScript.Echo "p_Header.Count = " & p_Header.Count
    For Each k In p_Header.Keys
      WScript.Echo "p_Header.Item(" & k & ") = " & p_Header.Item(k)
    Next
    WScript.Echo "DEBUG: " & String(20, "-")
  End Sub
End Class
使い方

インデックスで読み取ります。一番左が 0です。

Sub ReadByIndex()
  Dim mycsv ' As CsvReader
  Dim k, row, str
  Set mycsv = New CsvReader
  mycsv.HeaderExists = True
  If mycsv.OpenFile("sample.txt") Then
    Do Until mycsv.AtEndOfStream
      Set row = mycsv.GetRow()
      str = ""
      For Each k In row
        str = str & "(" & row(k) & ")"
      Next
      WScript.Echo "(" & str & ")"
   Loop
    Call mycsv.Close()
  Else
    WScript.Echo "ファイルが読み取れませんでした"
  End If
End Sub

ヘッダー名で読み取ります。

Sub ReadByHeaderField()
  Dim mycsv ' As CsvReader
  Dim myheader ' As Dictionary
  Dim k, row, str
  Set mycsv = New CsvReader
  mycsv.HeaderExists = True
  If mycsv.OpenFile("sample.txt") Then
    Set myheader = mycsv.Header
    Do Until mycsv.AtEndOfStream
      Set row = mycsv.GetRow()
      str = ""
      For Each k In myheader.Keys
        str = str & "(" & row(myheader(k)) & ")"
      Next
      WScript.Echo "(" & str & ")"
   Loop
    Call mycsv.Close()
  Else
    WScript.Echo "ファイルが読み取れませんでした"
  End If
End Sub
sample.txt は以下のようになっています。
"field_1","field_2","field_3"
aaa,bbb,ccc
日本語1,abc1,日本語2
aaa,,ccc
"aaa","bbb","ccc"
zzz,yyy,xxx
"aaa","bb
b","ccc"
"aaa","bb""b","ccc"
aaa,bb"b,ccc
"abcdefghi1abcdefghi2abcdefghi3abcdefghi4abcdefghi5abcdefghi6abcdefghi7abcdefghi8abcdefghi9abcdefghi0
abcdefghi1abcdefghi2abcdefghi3abcdefghi4abcdefghi5abcdefghi6abcdefghi7abcdefghi8abcdefghi9abcdefghi0
abcdefghi1abcdefghi2abcdefghi3abcdefghi4abcdefghi5abcdefghi6abcdefghi7abcdefghi8abcdefghi9abcdefghi0","bbb","ccc"
"aaa","bb""b","cc
k
c"
aaa,bb"b,ccc
aaa,bbb,
"zzz ", "yyy " , " xxx "
field_1,field_2,field_3
aaa,bbb
aaa,bbb,ccc
aaa,bbb,ccc,ddd
aaa,"bbb",ccc
"xxx",yyy,"zzz"
"aaa","bb" "b","ccc"
ReadByHeaderField の実行結果
((aaa)(bbb)(ccc))
((日本語1)(abc1)(日本語2))
((aaa)()(ccc))
((aaa)(bbb)(ccc))
((zzz)(yyy)(xxx))
((aaa)(bb
b)(ccc))
((aaa)(bb"b)(ccc))
((aaa)(bb"b)(ccc))
((abcdefghi1abcdefghi2abcdefghi3abcdefghi4abcdefghi5abcdefghi6abcdefghi7abcdefghi8abcdefghi9abcdefghi0
abcdefghi1abcdefghi2abcdefghi3abcdefghi4abcdefghi5abcdefghi6abcdefghi7abcdefghi8abcdefghi9abcdefghi0
abcdefghi1abcdefghi2abcdefghi3abcdefghi4abcdefghi5abcdefghi6abcdefghi7abcdefghi8abcdefghi9abcdefghi0)(bbb)(ccc))
((aaa)(bb"b)(cc
k
c))
((aaa)(bb"b)(ccc))
((aaa)(bbb)())
((zzz )( "yyy " )( " xxx "))
((field_1)(field_2)(field_3))
((aaa)(bbb)())
((aaa)(bbb)(ccc))
((aaa)(bbb)(ccc))
((aaa)(bbb)(ccc))
((xxx)(yyy)(zzz))
((aaa)(bb "b")(ccc))
参考

CSVフォーマット | VBScript - CSV ファイルを読み込む CsvReader クラス

タグ: VBScript

©2004-2017 UPKEN IPv4