前回の VBScript 版からの移植希望がありましたので、適当にコンバートしてみました。Scripting.Dictionary クラスから VBA.Collection クラスに置き換わっています。
VB (VB6) - CsvReader クラス
'/** CsvReader クラス */
Option Explicit
' EnumState 列挙体
Private Enum EnumState
None = 0 '読み込み開始前
Beginning = 1 '初期状態の入力待ち
WaitInput = 2 '入力待ち
FindQuote = 3 '引用符を発見
FindQuoteDouble = 4 '引用符の連続を発見
InQuote = 5 '引用符の中で入力待ち
FindQuoteInQuote = 6 '引用符の中で引用符を発見
FindComma = 7 'カンマを発見
FindCr = 8 'Cr を発見
FindCrLf = 9 'CrLf を発見
Error = 255 'エラー発生
End Enum
' プロパティ変数
Private m_FilePath As String
Private m_HasHeader As Boolean
Private m_IgnoreError As Boolean
' Private フィールド
Private mTextStream As TextStream
Private mState As EnumState
Private mHeaders As Collection
' コンストラクタ
Private Sub Class_Initialize()
mState = EnumState.Beginning
End Sub
' デストラクタ
Private Sub Class_Terminate()
Call Me.CloseStream
End Sub
' FilePath プロパティ - Getter
Public Property Get FilePath() As String
Let FilePath = m_FilePath
End Property
' HasHeader プロパティ - Getter
Public Property Get HasHeader() As Boolean
Let HasHeader = m_HasHeader
End Property
' IgnoreError プロパティ - Getter
Public Property Get IgnoreError() As Boolean
Let IgnoreError = m_IgnoreError
End Property
' IgnoreError プロパティ - Setter
Public Property Let IgnoreError(ByVal Value As Boolean)
m_IgnoreError = Value
End Property
' EndOfStream プロパティ
Public Property Get EndOfStream() As Boolean
Let EndOfStream = mTextStream.AtEndOfStream
End Property
' OpenStream メソッド
Public Function OpenStream(ByVal stFilePath As String) As Boolean
On Error GoTo Exception
m_FilePath = stFilePath
Dim cFso As FileSystemObject
Set cFso = New FileSystemObject
Set mTextStream = cFso.OpenTextFile(Me.FilePath)
OpenStream = True
Exit Function
Exception:
Call Me.CloseStream
OpenStream = False
End Function
' CloseStream メソッド
Public Sub CloseStream()
If Not mTextStream Is Nothing Then
On Error Resume Next
Call mTextStream.Close
On Error GoTo 0
End If
End Sub
' ReadHeader メソッド
Public Function ReadHeader() As Collection
Set mHeaders = Me.ReadLine()
m_HasHeader = True
Set ReadHeader = mHeaders
End Function
' ReadLine メソッド
Public Function ReadLine() As Collection
Do While (True)
Dim stReadLine As String
stReadLine = stReadLine & mTextStream.ReadLine()
Dim cRow As Collection
Set cRow = ReadLineInternal(stReadLine)
Select Case mState
Case EnumState.FindQuote, EnumState.InQuote
stReadLine = stReadLine & vbNewLine
Case Else
Exit Do
End Select
Loop
Set ReadLine = cRow
End Function
' ReadToEnd メソッド
Public Function ReadToEnd() As Collection
Dim cTable As Collection
Set cTable = New Collection
Dim stReadAll As String
stReadAll = mTextStream.ReadAll()
Dim stBuffers() As String
stBuffers = Split(stReadAll, vbNewLine)
Dim stReadLine As String
Dim i As Long
Dim lIndex As Long
For i = LBound(stBuffers()) To UBound(stBuffers())
stReadLine = stReadLine & stBuffers(i)
Dim cRow As Collection
Set cRow = ReadLineInternal(stReadLine)
Select Case mState
Case EnumState.FindQuote, EnumState.InQuote
stReadLine = stReadLine & vbNewLine
Case Else
stReadLine = ""
lIndex = lIndex + 1
Call cTable.Add(cRow)
End Select
Next
Set ReadToEnd = cTable
End Function
' 1 行読み込み
Private Function ReadLineInternal(ByVal stBuffer As String) As Collection
Dim cRow As Collection
Set cRow = New Collection
mState = EnumState.Beginning
Dim stItem As String
Dim iIndex As Integer
Dim iSeek As Integer
For iSeek = 1 To Len(stBuffer)
Dim chNext As String
chNext = Mid$(stBuffer, iSeek, 1)
Select Case mState
Case EnumState.Beginning
stItem = ReadForStateBeginning(stItem, chNext)
Case EnumState.WaitInput
stItem = ReadForStateWaitInput(stItem, chNext)
Case EnumState.FindQuote
stItem = ReadForStateFindQuote(stItem, chNext)
Case EnumState.FindQuoteDouble
stItem = ReadForStateFindQuoteDouble(stItem, chNext)
Case EnumState.InQuote
stItem = ReadForStateInQuote(stItem, chNext)
Case EnumState.FindQuoteInQuote
stItem = ReadForStateFindQuoteInQuote(stItem, chNext)
End Select
Select Case mState
Case EnumState.FindCrLf
mState = EnumState.Beginning
Exit For
Case EnumState.FindComma
iIndex = iIndex + 1
Call AddRowItem(stItem, cRow, iIndex)
mState = EnumState.Beginning
stItem = ""
Case EnumState.Error
If Not Me.IgnoreError Then
Call Err.Raise(5, "ReadLineInternal", "書式が不正です。")
End If
mState = EnumState.WaitInput
End Select
Next
If mState = EnumState.FindQuoteDouble Then
stItem = stItem & """"
End If
iIndex = iIndex + 1
Call AddRowItem(stItem, cRow, iIndex)
Set ReadLineInternal = cRow
End Function
' 初回入力待ち状態での Read
Private Function ReadForStateBeginning(ByVal stItem As String, ByVal chNext As String) As String
Select Case chNext
Case vbCr
mState = EnumState.FindCr
Case ","
mState = EnumState.FindComma
Case """"
mState = EnumState.FindQuote
Case Else
mState = EnumState.WaitInput
stItem = stItem & chNext
End Select
Let ReadForStateBeginning = stItem
End Function
' 入力待ち状態での Read
Private Function ReadForStateWaitInput(ByVal stItem As String, ByVal chNext As String) As String
Select Case chNext
Case vbCr
mState = EnumState.FindCr
Case ","
mState = EnumState.FindComma
Case """"
mState = EnumState.FindQuote
Case Else
stItem = stItem & chNext
End Select
Let ReadForStateWaitInput = stItem
End Function
' 引用符を発見した状態での Read
Private Function ReadForStateFindQuote(ByVal stItem As String, ByVal chNext As String) As String
Select Case chNext
Case """"
mState = EnumState.FindQuoteDouble
Case Else
mState = EnumState.InQuote
stItem = stItem & chNext
End Select
Let ReadForStateFindQuote = stItem
End Function
' 引用符の連続を発見した状態での Read
Private Function ReadForStateFindQuoteDouble(ByVal stItem As String, ByVal chNext As String) As String
Select Case chNext
Case vbCr
mState = EnumState.FindCr
stItem = stItem & """"
Case ","
mState = EnumState.FindComma
stItem = stItem & """"
Case """"
mState = EnumState.FindQuote
stItem = stItem & """"
Case Else
mState = EnumState.WaitInput
stItem = stItem & """" & chNext
End Select
ReadForStateFindQuoteDouble = stItem
End Function
' 引用符の中で入力待ち状態での Read
Private Function ReadForStateInQuote(ByVal stItem As String, ByVal chNext As String) As String
Select Case chNext
Case """"
mState = EnumState.FindQuoteInQuote
Case Else
stItem = stItem & chNext
End Select
Let ReadForStateInQuote = stItem
End Function
' 引用符の中で引用符を発見した状態での Read
Private Function ReadForStateFindQuoteInQuote(ByVal stItem As String, ByVal chNext As String) As String
Select Case chNext
Case vbCr
mState = EnumState.FindCr
Case ","
mState = EnumState.FindComma
Case """"
mState = EnumState.InQuote
stItem = stItem & """"
Case Else
mState = EnumState.Error
End Select
Let ReadForStateFindQuoteInQuote = stItem
End Function
' Row にアイテムを入れる
Private Sub AddRowItem(ByVal stItem As String, ByVal cRow As Collection, ByVal lIndex As Long)
If Me.HasHeader Then
Call cRow.Add(stItem, mHeaders(lIndex))
Else
Call cRow.Add(stItem)
End If
End Sub
使用例となるサンプルコードを以下に示します。
VB (VB6) - CSV 読み込みクラス 使用例 1
Private Sub MosaMosaAA()
Dim cCsvReader As CsvReader
Set cCsvReader = New CsvReader
' 指定した CSV ファイルを開く
Call cCsvReader.OpenStream("C:\MakiMaki.csv")
' CSV ファイルの中身をすべて取得する
Dim cTable As Collection
Set cTable = cCsvReader.ReadToEnd()
' すべての中身 (Table) から 行 (Row) を列挙して取り出す
Dim cRow As Collection
For Each cRow In cTable
Dim i As Integer
' 行から添え字を使って各 Item を出力する
For i = 1 To cRow.Count()
Debug.Print cRow(i)
Next
Debug.Print vbNewLine
Next
End Sub
ReadHeader メソッドを使用すると、各 Item にカラム名からアクセスすることができます。
VB (VB6) - CSV 読み込みクラス 使用例 2
Private Sub MosaMosaAA()
Dim cCsvReader As CsvReader
Set cCsvReader = New CsvReader
' 指定した CSV ファイルを開く
Call cCsvReader.OpenStream("C:\MakiMaki.csv")
' 最初の行をヘッダとして読み込む
Call cCsvReader.ReadHeader
' CSV ファイルの中身をすべて取得する
Dim cTable As Collection
Set cTable = cCsvReader.ReadToEnd()
' すべての中身 (Table) から 行 (Row) を列挙して取り出す
Dim cRow As Collection
For Each cRow In cTable
' 行からカラム名を使って各 Item を出力する
Debug.Print cRow("社員番号")
Debug.Print cRow("社員名")
Debug.Print cRow("住所")
Debug.Print cRow("電話番号")
Debug.Print
Next
End Sub
サンプルでは ReadToEnd メソッドを使って一気に全部読み込んでいますが、ReadLine メソッドを使うと 1 行ずつ読むことができます。
なるべく RFC に準拠するように努めましたが、自己都合でいくつかカスタマイズが入っています。一応、状況によって処理が細かく分かれているので、カスタマイズはそこそこ容易だと思います。
関連リンク