エクセルVBAでCSVファイル、固定長ファイルの入出力

このエントリーをはてなブックマークに追加

ひさしぶりの更新。ものすごく前に作成したエクセルVBA用に作成したモジュールをみつけた。せっかくなので公開しようと思う。機能としてはCSVファイルのインプット、アウトプット、固定長ファイルのインプット、アウトプット。ファイルは以下の5つ。

  • basConstForFileIO
  • clsMakeCSV
  • clsMakeFixedLenValue
  • clsReadCSV
  • clsReadFixedLenValue

basConstForFileIO.bas

これは共通定数。以下ソース。

' -----------------------------------------------
' 共通
' -----------------------------------------------
' ファイルシステムオブジェクト用
Public Const FILEOPEN_FORREADING = 1
Public Const FILEOPEN_FORWRITING = 2
Public Const FILEOPEN_FORAPPENDING = 8

' エラーコード
Public Const NORMAL_FILEOPEN = 0
Public Const ERROR_FILEOPEN = -1
Public Const ERROR_FILENOTFOUND = -2

' 改行コード
Public Enum ReturnCode
    retCR = 1                           ' キャリッジリターン
    retLF = 2                           ' ラインフィールド
    retCRLF = 3                         ' キャリッジリターン + ラインフィールド
End Enum

' -----------------------------------------------
' CSVファイル
' -----------------------------------------------
' CSVファイル用列挙型
Public Enum CsvValueType
    csvDefault = &H0                    ' デフォルト値を使用
    csvNormal = &H1                     ' 値をそのまま出力
    csvWithDblQuote = &H2               ' ダブルクォート付き
    csvWithSglQuote = &H4               ' シングルクォート付き
    csvToWide = &H8                     ' 全角変換
    csvToNarrow = &H10                  ' 半角変換
End Enum

' -----------------------------------------------
' 固定長ファイル
' -----------------------------------------------
' 固定長ファイル用列挙型
Public Enum FixedValueType
    fixlenDefault = &H0                 ' デフォルト値を使用
    fixlenAlignLeft = &H1               ' 左詰め
    fixlenAlignRight = &H2              ' 右詰め
    fixlenToWide = &H4                  ' 全角変換
    fixlenToNarrow = &H8                ' 半角変換
    fixlenWithNarrowSpace = &H10        ' 半角スペース埋め
    fixlenWithWideSpace = &H20          ' 全角スペース埋め
    fixlenWithZero = &H40               ' 0(半角)埋め
End Enum

clsMakeCSV.cls

これはCSVファイル作成クラス。以下ソース。

Private m_objFS             As Object           ' ファイルシステムオブジェクト
Private m_objMakeFile       As Object           ' CSVファイルオブジェクト
Private m_strFilePath       As String           ' CSVファイルパス
Private m_strValue          As String           ' 出力する1行分の文字列
Private m_enmDefaultDeco    As CsvValueType     ' CSV値タイプ
Private m_strRetCode        As String           ' 改行文字

' Class_Initialize
'
' #コンストラクタ
'
Private Sub Class_Initialize()

    ' 初期化
    Set m_objFS = CreateObject("Scripting.FileSystemObject")
    m_enmDefaultDeco = csvNormal    ' 初期値はそのまま値を出力とする
    m_strValue = ""
    m_strRetCode = vbCrLf           ' デフォルトの改行コード
    
End Sub

' FilePath
'
' #ファイルパスの設定
'   @param  Path    ファイルパス
'
Public Function SetFilePath(ByVal Path As String) As Long

    m_strFilePath = Path

    On Error Resume Next
    Set m_objMakeFile = m_objFS.OpenTextFile(m_strFilePath, FILEOPEN_FORWRITING, True)
    If Err.Number <> 0 Then
    ' ファイルオープンエラー時
        SetFilePath = ERROR_FILEOPEN
        Exit Function
    End If
    On Error GoTo 0
    
    SetFilePath = NORMAL_FILEOPEN
    
End Function

' ReturnCode
'
' #改行コードの設定
'   @param  RetCode     改行コード(列挙型)
'
Public Property Let ReturnCode(ByVal RetCode As ReturnCode)

    Select Case RetCode
        Case retCR
        ' キャリッジリターン
            m_strRetCode = vbCr
            
        Case retLF
        ' ラインフィールド
            m_strRetCode = vbLf
            
        Case retCRLF
        ' キャリッジリターン + ラインフィールド
            m_strRetCode = vbCrLf
            
        Case Else
        
    End Select

End Property

' Decoration
'
' #値の装飾デフォルト値の変更
'   @param  Deco        値の装飾設定
'
Public Property Let Decoration(ByVal Deco As CsvValueType)

    m_enmDefaultDeco = Deco        ' 値の装飾デフォルト値変更
    
End Property

' AddValue
'
' #値の追加(カンマ区切りの1項目)
'   @param  value   値
'   @param  deco    デフォルトの装飾
'
Public Sub AddValue(ByVal Value As String, Optional ByVal Deco As CsvValueType = csvDefault)
        
    Dim enmDeco         As CsvValueType
    Dim strMakeValue    As String
    
    ' ダブルクォート設定
    If Deco = csvDefault Then
        ' デフォルト値の場合、もしくは引数省略の場合
        enmDeco = m_enmDefaultDeco
    Else
        ' 引数指定の場合
        enmDeco = Deco
    End If
    
    ' CSV値を作成
    strMakeValue = Value
    
    ' 全角、半角設定
    If enmDeco And csvToWide Then
        strMakeValue = StrConv(strMakeValue, vbWide)
    ElseIf enmDeco And csvToNarrow Then
        strMakeValue = StrConv(strMakeValue, vbNarrow)
    End If
    
    ' 「"」→「""」
    strMakeValue = Replace(strMakeValue, Chr(&H22), Chr(&H22) & Chr(&H22))
    
    ' 装飾設定
    If enmDeco And csvWithDblQuote Then
    ' ダブルクォート付き
        strMakeValue = Chr(&H22) & strMakeValue & Chr(&H22)
    ElseIf enmDeco And csvWithSglQuote Then
    ' シングルクォート付き
        strMakeValue = Chr(&H27) & strMakeValue & Chr(&H27)
    End If
    
    ' 値追加
    If m_strValue = "" Then
        ' 最初の場合
        m_strValue = strMakeValue
    Else
        ' 2項目以降
        m_strValue = m_strValue & "," & strMakeValue
    End If
    
End Sub

' NextLine
'
' #1ラインの書き込み
'
Public Sub NextLine()
    
    m_objMakeFile.Write m_strValue & m_strRetCode        ' 値 + 改行コード
    m_strValue = ""

End Sub

' Class_Terminate
'
' #デストラクタ
'
Private Sub Class_Terminate()

    On Error Resume Next
    
    ' すべてのオブジェクト破棄
    m_objMakeFile.Close
    Set m_objMakeFile = Nothing
    Set m_objFS = Nothing
    
    On Error GoTo 0

End Sub

clsMakeFixedLenValue.cls

これは固定長ファイル作成クラス。以下ソース。

Private m_objFS             As Object           ' ファイルシステムオブジェクト
Private m_objMakeFile       As Object           ' CSVファイルオブジェクト
Private m_strFilePath       As String           ' CSVファイルパス
Private m_strValue          As String           ' 出力する1行分の文字列
Private m_enmDefaultDeco    As CsvValueType     ' CSV値タイプ
Private m_strRetCode        As String           ' 改行文字

' Class_Initialize
'
' #コンストラクタ
'
Private Sub Class_Initialize()

    ' 初期化
    Set m_objFS = CreateObject("Scripting.FileSystemObject")
    m_enmDefaultDeco = csvNormal    ' 初期値はそのまま値を出力とする
    m_strValue = ""
    m_strRetCode = vbCrLf           ' デフォルトの改行コード
    
End Sub

' FilePath
'
' #ファイルパスの設定
'   @param  Path    ファイルパス
'
Public Function SetFilePath(ByVal Path As String) As Long

    m_strFilePath = Path

    On Error Resume Next
    Set m_objMakeFile = m_objFS.OpenTextFile(m_strFilePath, FILEOPEN_FORWRITING, True)
    If Err.Number <> 0 Then
    ' ファイルオープンエラー時
        SetFilePath = ERROR_FILEOPEN
        Exit Function
    End If
    On Error GoTo 0
    
    SetFilePath = NORMAL_FILEOPEN
    
End Function

' ReturnCode
'
' #改行コードの設定
'   @param  RetCode     改行コード(列挙型)
'
Public Property Let ReturnCode(ByVal RetCode As ReturnCode)

    Select Case RetCode
        Case retCR
        ' キャリッジリターン
            m_strRetCode = vbCr
            
        Case retLF
        ' ラインフィールド
            m_strRetCode = vbLf
            
        Case retCRLF
        ' キャリッジリターン + ラインフィールド
            m_strRetCode = vbCrLf
            
        Case Else
        
    End Select

End Property

' Decoration
'
' #値の装飾デフォルト値の変更
'   @param  Deco        値の装飾設定
'
Public Property Let Decoration(ByVal Deco As CsvValueType)

    m_enmDefaultDeco = Deco        ' 値の装飾デフォルト値変更
    
End Property

' AddValue
'
' #値の追加(カンマ区切りの1項目)
'   @param  value   値
'   @param  deco    デフォルトの装飾
'
Public Sub AddValue(ByVal Value As String, Optional ByVal Deco As CsvValueType = csvDefault)
        
    Dim enmDeco         As CsvValueType
    Dim strMakeValue    As String
    
    ' ダブルクォート設定
    If Deco = csvDefault Then
        ' デフォルト値の場合、もしくは引数省略の場合
        enmDeco = m_enmDefaultDeco
    Else
        ' 引数指定の場合
        enmDeco = Deco
    End If
    
    ' CSV値を作成
    strMakeValue = Value
    
    ' 全角、半角設定
    If enmDeco And csvToWide Then
        strMakeValue = StrConv(strMakeValue, vbWide)
    ElseIf enmDeco And csvToNarrow Then
        strMakeValue = StrConv(strMakeValue, vbNarrow)
    End If
    
    ' 「"」→「""」
    strMakeValue = Replace(strMakeValue, Chr(&H22), Chr(&H22) & Chr(&H22))
    
    ' 装飾設定
    If enmDeco And csvWithDblQuote Then
    ' ダブルクォート付き
        strMakeValue = Chr(&H22) & strMakeValue & Chr(&H22)
    ElseIf enmDeco And csvWithSglQuote Then
    ' シングルクォート付き
        strMakeValue = Chr(&H27) & strMakeValue & Chr(&H27)
    End If
    
    ' 値追加
    If m_strValue = "" Then
        ' 最初の場合
        m_strValue = strMakeValue
    Else
        ' 2項目以降
        m_strValue = m_strValue & "," & strMakeValue
    End If
    
End Sub

' NextLine
'
' #1ラインの書き込み
'
Public Sub NextLine()
    
    m_objMakeFile.Write m_strValue & m_strRetCode        ' 値 + 改行コード
    m_strValue = ""

End Sub

' Class_Terminate
'
' #デストラクタ
'
Private Sub Class_Terminate()

    On Error Resume Next
    
    ' すべてのオブジェクト破棄
    m_objMakeFile.Close
    Set m_objMakeFile = Nothing
    Set m_objFS = Nothing
    
    On Error GoTo 0

End Sub

clsReadCSV.cls

これはCSV読み込みクラス。以下ソース。

Private m_objFS                 As Object               ' ファイルシステムオブジェクト
Private m_objReadFile           As Object               ' CSVファイルオブジェクト
Private m_strFilePath           As String               ' CSVファイルパス
Private m_strOneLineString      As String               ' 1行分の文字列
Private m_colIndex              As New Collection       ' 設定フィールド
Private m_blnEndOfStream        As Boolean              ' EOFプロパティ
Private m_lngLineCount          As Long                 ' 行数
Private m_intItemCount          As Integer              ' 1行分のアイテムカウント
Private m_strRetCode            As String               ' 改行文字

' Class_Initialize
'
' #コンストラクタ
'
Private Sub Class_Initialize()

    ' 初期化
    Set m_objFS = CreateObject("Scripting.FileSystemObject")
    m_lngLineCount = 1
    m_strRetCode = vbCrLf          ' デフォルトの改行コード
    
End Sub

' SetFilePath
'
' #ファイルパスの設定
'   @param  Path    ファイルパス
'   @return エラーコード
'
Public Function SetFilePath(ByVal Path As String) As Long

    m_strFilePath = Path    ' CSVファイルパス設定

    ' ファイル存在チェック
    If Not m_objFS.FileExists(m_strFilePath) Then
    ' ファイル存在エラー
        SetFilePath = ERROR_FILENOTFOUND
        Exit Function
    End If

    On Error Resume Next
    Set m_objReadFile = m_objFS.OpenTextFile(m_strFilePath, FILEOPEN_FORREADING, False)   '  CSVファイルオブジェクト作成
    If Err.Number <> 0 Then
    ' ファイルオープンエラー
        SetFilePath = ERROR_FILEOPEN
        Exit Function
    End If
    On Error GoTo 0
    
    If m_objReadFile.AtEndOfStream Then
        m_blnEndOfStream = True
    Else
        m_strOneLineString = m_GetLineString
        m_blnEndOfStream = False
    End If
    
    SetFilePath = NORMAL_FILEOPEN
    
End Function

' ReturnCode
'
' #改行コードの設定
'   @param  RetCode     改行コード(列挙型)
'
Public Property Let ReturnCode(ByVal RetCode As ReturnCode)

    Select Case RetCode
        Case retCR
        ' キャリッジリターン
            m_strRetCode = vbCr
            
        Case retLF
        ' ラインフィールド
            m_strRetCode = vbLf
            
        Case retCRLF
        ' キャリッジリターン + ラインフィールド
            m_strRetCode = vbCrLf
            
        Case Else
        
    End Select

End Property

' HasNext
'
' #次のラインが存在するか判別
'   @return     True    存在する
'               False   存在しない
'
Public Property Get HasNext() As Boolean
      
    HasNext = Not m_blnEndOfStream

End Property

' SetValue
'
' #フィールドのセット
'   @param  fieldname   フィールド名
'   @param  index       インデックス
'
Public Sub SetValue(ByVal FieldName As String, ByVal Index As Integer)

    On Error Resume Next
    m_colIndex.Add Item:=CStr(Index), Key:=FieldName
    If Err.Number <> 0 Then
        MsgBox "フィールド名がセットできません。重複してないか確認してください。", vbExclamation
    End If
    On Error GoTo 0
    
End Sub

' GetOneLineString
'
' #1行分の文字列を返す
'   @return     1行分の文字列
'
Public Property Get GetOneLineString() As String

    GetOneLineString = m_strOneLineString

End Property

' GetValue
'
' #フィールド値を取得する
'   @param      field   フィールド名、もしくはインデックス(インデックスは1から)
'   @return     インデックス、もしくはフィールドに対応する文字列
'
Public Property Get GetValue(ByVal Field As Variant) As String

    Dim intItemIndex        As Integer

    ' 項目インデックスを取得
    If VarType(Field) = vbInteger Then
    ' 引数がインデックス指定の場合
        intItemIndex = Field
    Else
    ' 引数が設定したフィールド名の場合
        intItemIndex = CInt(m_colIndex.Item(Field))
    End If

    GetValue = m_GetCSVItemValue(intItemIndex)

End Property

' Line
'
' #現在行を取得
'   @return     現在行を返す
'
Public Property Get Line() As Long
        
    Line = m_lngLineCount

End Property

' NextLine
'
' #次の行に移動
'
Public Sub NextLine()
        
    If m_objReadFile.AtEndOfStream Then
        m_blnEndOfStream = True
    Else
'        m_strOneLineString = m_objReadFile.ReadLine
        m_strOneLineString = m_GetLineString
        m_blnEndOfStream = False
    End If

    m_lngLineCount = m_lngLineCount + 1

End Sub

' ReSet
'
' #ファイルをセットし直す
'   @param  なし
'   @return エラーコード
'
Public Function ReSetFile() As Long

    ' ファイルいったんクローズ
    m_objReadFile.Close
    Set m_objReadFile = Nothing

    ' ファイル存在チェック
    If Not m_objFS.FileExists(m_strFilePath) Then
    ' ファイル存在エラー
        ReSetFile = ERROR_FILENOTFOUND
        Exit Function
    End If

    On Error Resume Next
    Set m_objReadFile = m_objFS.OpenTextFile(m_strFilePath, FILEOPEN_FORREADING, False)   ' CSVファイルオブジェクト作成
    If Err.Number <> 0 Then
    ' ファイルオープンエラー
        ReSetFile = ERROR_FILEOPEN
        Exit Function
    End If
    
    If m_objReadFile.AtEndOfStream Then
        m_blnEndOfStream = True
    Else
        m_strOneLineString = m_GetLineString
        m_blnEndOfStream = False
    End If

    m_lngLineCount = 1

    ' 戻り値、正常コード
    ReSetFile = NORMAL_FILEOPEN

End Function

' m_GetLineString
'
' #1行分の文字列を返す
'   @param  なし
'   @return 1行分の文字列
'
Private Function m_GetLineString() As String
    
    Dim strLine     As String   ' 1行分文字列
    Dim strTmp1     As String   ' 改行コード判別用
    Dim strTmp2     As String   ' 改行コード判別用

    strLine = ""

    Do While Not m_objReadFile.AtEndOfStream
        strTmp1 = m_objReadFile.Read(1)         ' 1文字取得
        strTmp2 = ""
        
        ' 改行判定
        Select Case m_strRetCode
            Case vbCr
            ' キャリッジリターン
                If strTmp1 = vbCr Then
                    Exit Do
                End If
            
            Case vbLf
            ' ラインフィールド
                If strTmp1 = vbLf Then
                    Exit Do
                End If
            
            Case vbCrLf
            ' キャリッジリターン + キャリッジリターン
                If strTmp1 = vbCr Then
                    If Not m_objReadFile.AtEndOfStream Then
                        strTmp2 = m_objReadFile.Read(1)
                        If strTmp2 = vbLf Then
                        ' CRLFである
                            Exit Do
                        End If
                    End If
                End If
            Case Else
        End Select
        
        strLine = strLine & strTmp1 & strTmp2
    Loop

    m_GetLineString = strLine

End Function

' GetItemCount
'
' #カンマ区切りの項目数を返す
'   @return カンマ区切りの項目数
'
Public Property Get GetItemCount() As Integer

    Const CHARCODE_DOUBLEQUOTE = &H22

    Dim i                           As Integer
    Dim strOneStr                   As String
    Dim intItemCount                As Integer
    Dim blnFirstStrFlg              As Boolean      ' 項目の最初の文字か判別
    Dim blnDblQuoteOnFlg            As Boolean      ' 項目が「"」くくられているか判別
    Dim blnBeforStrDblQuoteFlg      As Boolean      ' 前の文字が「"」か判別
    
    ' 1行分の文字列が空なら終了
    If Len(m_strOneLineString) = 0 Then
        GetItemCount = 1
        Exit Property
    End If
    
    ' 初期化
    blnFirstStrFlg = True
    blnDblQuoteOnFlg = False
    blnBeforStrDblQuoteFlg = False
    intItemCount = 1
        
    For i = 0 To Len(m_strOneLineString) - 1
        strOneStr = Mid(m_strOneLineString, i + 1, 1)
        Select Case strOneStr
            Case Chr(CHARCODE_DOUBLEQUOTE)
            ' 「"」の場合
                If blnFirstStrFlg = True Then
                ' 項目の最初の文字の場合
                    blnDblQuoteOnFlg = True
                Else
                ' 2文字目以降の文字の場合
                    If blnDblQuoteOnFlg = True Then
                    ' 項目が「"」でくくられている場合
                        If blnBeforStrDblQuoteFlg = True Then
                        ' 前の文字が「"」の場合、エスケープされた「"」とみなす
                            blnBeforStrDblQuoteFlg = False
                        Else
                        ' 前の文字が「"」でない場合
                            blnBeforStrDblQuoteFlg = True
                        End If
                    Else
                    ' 項目が「"」でくくられてない場合
                    
                    End If
                End If
                blnFirstStrFlg = False
                
            Case ","
            '「,」の場合
                If blnDblQuoteOnFlg = False Or (blnDblQuoteOnFlg = True And blnBeforStrDblQuoteFlg = True) Then
                ' 「"」でくくられてない、または「"」でくくられていて前の文字が「"」である場合、セパレート文字とみなす。項目確定
                    ' 指定項目でないので初期化して次の項目へ
                    blnFirstStrFlg = True
                    blnDblQuoteOnFlg = False
                    blnBeforStrDblQuoteFlg = False
                    intItemCount = intItemCount + 1
                Else
                ' セパレート文字でなく文字の「,」とみなす
                    blnFirstStrFlg = False
                End If
                                 
            Case Else
            ' 上記以外の場合
                blnFirstStrFlg = False
                                              
        End Select
    Next i
    
    GetItemCount = intItemCount
    
End Property

' m_GetCSVItemValue
'
' #指定インデックスのCSVの値を求める
'   @param  ItemIndex       インデックス
'   @return 指定インデックスのCSVの値
'
Private Function m_GetCSVItemValue(ByVal ItemIndex As Integer) As String

    Const CHARCODE_DOUBLEQUOTE = &H22

    Dim i                           As Integer
    Dim strOneStr                   As String
    Dim intItemCount                As Integer
    Dim blnFirstStrFlg              As Boolean      ' 項目の最初の文字か判別
    Dim blnDblQuoteOnFlg            As Boolean      ' 項目が「"」くくられているか判別
    Dim blnBeforStrDblQuoteFlg      As Boolean      ' 前の文字が「"」か判別
    Dim strMakeStr                  As String
    
    ' 1行分の文字列が空なら終了
    If Len(m_strOneLineString) = 0 Then
        m_GetCSVItemValue = ""
        Exit Function
    End If

    ' 初期化
    blnFirstStrFlg = True
    blnDblQuoteOnFlg = False
    blnBeforStrDblQuoteFlg = False
    strMakeStr = ""
    intItemCount = 1
        
    For i = 0 To Len(m_strOneLineString) - 1
        strOneStr = Mid(m_strOneLineString, i + 1, 1)
        Select Case strOneStr
            Case Chr(CHARCODE_DOUBLEQUOTE)
            ' 「"」の場合
                If blnFirstStrFlg = True Then
                ' 項目の最初の文字の場合
                    blnDblQuoteOnFlg = True
                Else
                ' 2文字目以降の文字の場合
                    If blnDblQuoteOnFlg = True Then
                    ' 項目が「"」でくくられている場合
                        If blnBeforStrDblQuoteFlg = True Then
                        ' 前の文字が「"」の場合、エスケープされた「"」とみなす
                            strMakeStr = strMakeStr & strOneStr
                            blnBeforStrDblQuoteFlg = False
                        Else
                        ' 前の文字が「"」でない場合
                            blnBeforStrDblQuoteFlg = True
                        End If
                    Else
                    ' 項目が「"」でくくられてない場合
                        strMakeStr = strMakeStr & strOneStr
                    End If
                End If
                blnFirstStrFlg = False
                
            Case ","
            '「,」の場合
                If blnDblQuoteOnFlg = False Or (blnDblQuoteOnFlg = True And blnBeforStrDblQuoteFlg = True) Then
                ' 「"」でくくられてない、または「"」でくくられていて前の文字が「"」である場合、セパレート文字とみなす。項目確定
                    If intItemCount = ItemIndex Then
                    ' 指定項目の確定
                        Exit For
                    End If
                    
                    ' 指定項目でないので初期化して次の項目へ
                    blnFirstStrFlg = True
                    blnDblQuoteOnFlg = False
                    blnBeforStrDblQuoteFlg = False
                    strMakeStr = ""
                    intItemCount = intItemCount + 1
                Else
                ' セパレート文字でなく文字の「,」とみなす
                    strMakeStr = strMakeStr & strOneStr
                    blnFirstStrFlg = False
                End If
                
            Case Else
            ' 上記以外の場合
                strMakeStr = strMakeStr & strOneStr
                blnFirstStrFlg = False
                                              
        End Select
    Next i

    ' 取得した指定インデックスのCSV項目
    If intItemCount = ItemIndex Then
        m_GetCSVItemValue = strMakeStr
    Else
        m_GetCSVItemValue = ""
    End If

End Function

' Class_Terminate
'
' #デストラクタ
'
Private Sub Class_Terminate()

    On Error Resume Next
    
    ' すべてのオブジェクト破棄
    m_objReadFile.Close
    Set m_objReadFile = Nothing
    Set m_objFS = Nothing
    Set m_colIndex = Nothing
    
    On Error GoTo 0

End Sub

clsReadFixedLenValue.cls

これは固定長ファイル読み込みクラス。以下ソース。

Private m_objFS                 As Object               ' ファイルシステムオブジェクト
Private m_objReadFile           As Object               ' 固定長ファイルオブジェクト
Private m_strFilePath           As String               ' 固定長ファイルパス
Private m_strLine               As String
Private m_blnEndOfStream        As Boolean
Private m_colStart              As New Collection
Private m_colLength             As New Collection
Private m_lngLineCount          As Long
Private m_strRetCode            As String               ' 改行文字

' Class_Initialize
'
' #コンストラクタ
'
Private Sub Class_Initialize()

    ' 初期化
    Set m_objFS = CreateObject("Scripting.FileSystemObject")
    m_lngLineCount = 1
    m_strRetCode = vbCrLf          ' デフォルトの改行コード

End Sub

' SetFilePath
'
' #ファイルパスの設定
'   @param  Path    ファイルパス
'   @return エラーコード
'
Public Function SetFilePath(ByVal Path As String) As Long

    m_strFilePath = Path    ' 固定長ファイルパス設定

    ' ファイル存在チェック
    If Not m_objFS.FileExists(m_strFilePath) Then
    ' ファイル存在エラー
        SetFilePath = ERROR_FILENOTFOUND
        Exit Function
    End If

    On Error Resume Next
    Set m_objReadFile = m_objFS.OpenTextFile(m_strFilePath, FILEOPEN_FORREADING, False)   ' 固定長ファイルオブジェクト作成
    If Err.Number <> 0 Then
    ' ファイルオープンエラー
        SetFilePath = ERROR_FILEOPEN
        Exit Function
    End If
    On Error GoTo 0
    
    If m_objReadFile.AtEndOfStream Then
        m_blnEndOfStream = True
    Else
        m_strLine = m_GetLineString()
        m_blnEndOfStream = False
    End If
    
    SetFilePath = NORMAL_FILEOPEN
    
End Function

' ReturnCode
'
' #改行コードの設定
'   @param  RetCode     改行コード(列挙型)
'
Public Property Let ReturnCode(ByVal RetCode As ReturnCode)

    Select Case RetCode
        Case retCR
        ' キャリッジリターン
            m_strRetCode = vbCr
            
        Case retLF
        ' ラインフィールド
            m_strRetCode = vbLf
            
        Case retCRLF
        ' キャリッジリターン + ラインフィールド
            m_strRetCode = vbCrLf
            
        Case Else
        
    End Select

End Property

' SetValue
'
' #フィールドのセット
'   @param  FieldName   フィールド名
'   @param  Start       スタート点
'   @param  Length      文字列長さ(バイト数)
'
Public Sub SetValue(ByVal FieldName As String, _
                        ByVal Start As Integer, ByVal Length As Integer)

    On Error Resume Next
    m_colStart.Add Item:=CStr(Start), Key:=FieldName
    m_colLength.Add Item:=CStr(Length), Key:=FieldName
    If Err.Number <> 0 Then
        MsgBox "フィールド名がセットできません。重複してないか確認してください。", vbExclamation
    End If
    On Error GoTo 0

End Sub

' HasNext
'
' #次のラインが存在するか判別
'   @return     True    存在する
'               False   存在しない
'
Public Property Get HasNext() As Boolean
      
    HasNext = Not m_blnEndOfStream

End Property

' GetValue
'
' #フィールド値を取得する
'   @param  Field   フィールド名、もじくは文字のスタート位置
'   @return インデックス、もしくはフィールド名に対応する文字列
'
Public Property Get GetValue(ByVal Field As Variant, Optional ByVal Length As Integer = 0) As String

    If VarType(Field) = vbInteger Then
        ' 引数がインデックス指定の場合
        GetValue = StrConv(MidB(StrConv(m_strLine, vbFromUnicode), Field, Length), vbUnicode)
    Else
        ' 引数が指定したフィールド名の場合
        GetValue = StrConv(MidB(StrConv(m_strLine, vbFromUnicode), _
                            CInt(m_colStart.Item(Field)), CInt(m_colLength.Item(Field))), vbUnicode)
    End If

End Property

' NextLine
'
' #次の行に移動
'
Public Sub NextLine()
        
    If m_objReadFile.AtEndOfStream Then
        m_blnEndOfStream = True
    Else
        m_strLine = m_GetLineString()
        m_blnEndOfStream = False
    End If

    m_lngLineCount = m_lngLineCount + 1

End Sub

' GetOneLineString
'
' #1行分の文字列を返す
'   @return     1行分の文字列
'
Public Property Get GetOneLineString() As String

    GetOneLineString = m_strLine

End Property

' Line
'
' #現在行を取得
'   @return     現在行
'
Public Property Get Line() As Long
        
    Line = m_lngLineCount

End Property

' ReSetFile
'
' #ファイルをセットし直す
'   @param  なし
'   @return エラーコード
'
Public Function ReSetFile() As Long

    ' ファイルいったんクローズ
    m_objReadFile.Close
    Set m_objReadFile = Nothing

    ' ファイル存在チェック
    If Not m_objFS.FileExists(m_strFilePath) Then
    ' ファイル存在エラー
        ReSetFile = ERROR_FILENOTFOUND
        Exit Function
    End If

    On Error Resume Next
    Set m_objReadFile = m_objFS.OpenTextFile(m_strFilePath, FILEOPEN_FORREADING, False)   ' 固定長ファイルオブジェクト作成
    If Err.Number <> 0 Then
    ' ファイルオープンエラー
        ReSetFile = ERROR_FILEOPEN
        Exit Function
    End If
    
    If m_objReadFile.AtEndOfStream Then
        m_blnEndOfStream = True
    Else
        m_strLine = m_GetLineString()
        m_blnEndOfStream = False
    End If

    m_lngLineCount = 1

    ' 戻り値、正常コード
    ReSetFile = NORMAL_FILEOPEN

End Function

' m_GetLineString
'
' #1行分の文字列を返す
'   @param  なし
'   @return 1行分の文字列
'
Private Function m_GetLineString() As String
    
    Dim strLine     As String   ' 1行分文字列
    Dim strTmp1     As String   ' 改行コード判別用
    Dim strTmp2     As String   ' 改行コード判別用

    strLine = ""

    Do While Not m_objReadFile.AtEndOfStream
        strTmp1 = m_objReadFile.Read(1)    ' 1文字取得
        strTmp2 = ""
        
        ' 改行判定
        Select Case m_strRetCode
            Case vbCr
            ' キャリッジリターン
                If strTmp1 = vbCr Then
                    Exit Do
                End If
            
            Case vbLf
            ' ラインフィールド
                If strTmp1 = vbLf Then
                    Exit Do
                End If
            
            Case vbCrLf
            ' キャリッジリターン + キャリッジリターン
                If strTmp1 = vbCr Then
                    If Not m_objReadFile.AtEndOfStream Then
                        strTmp2 = m_objReadFile.Read(1)
                        If strTmp2 = vbLf Then
                        ' CRLFである
                            Exit Do
                        End If
                    End If
                End If
            Case Else
        End Select
        
        strLine = strLine & strTmp1 & strTmp2
    Loop

    m_GetLineString = strLine

End Function

' Class_Terminate
'
' #デストラクタ
'
Private Sub Class_Terminate()

    On Error Resume Next
    
    ' すべてのオブジェクト破棄
    m_objReadFile.Close
    Set m_objReadFile = Nothing
    Set m_objFS = Nothing
    Set m_colStart = Nothing
    Set m_colLength = Nothing
    
    On Error GoTo 0

End Sub

使い方

上記ファイルをエクセルにインポートし以下のサンプルコードで使用できる。

' CSVファイルの作成
Public Sub MakeCSVFile()

    Dim objFileIO       As New clsMakeCSV
    Dim i               As Integer

    With objFileIO
        If .SetFilePath(ThisWorkbook.Path & "\" & "MakeCSVFile.csv") = ERROR_FILEOPEN Then
            MsgBox "エラー", vbExclamation
            Set objFileIO = Nothing
            Exit Sub
        End If
        
        ' 装飾設定
'        .Decoration = csvWithSglQuote   ' シングルクォートでくくりたい場合
        .Decoration = csvWithDblQuote   ' ダブルクォートでくくりたい場合
        
        For i = 0 To 10
            .AddValue "a"
            .AddValue "b"
            .AddValue "c", csvWithSglQuote  ' 途中にシングルクォートでくくりたい場合(ないと思うけど)
            .NextLine                       ' 改行
        Next i
    End With
    
    Set objFileIO = Nothing
    
End Sub

' CSVファイルの読み込み
Public Sub ReadCSVFile()

    Dim objFileIO       As New clsReadCSV
    
    With objFileIO
        
        If .SetFilePath(ThisWorkbook.Path & "\" & "ReadCSVFile.csv") = ERROR_FILEOPEN Then
            MsgBox "エラー", vbExclamation
            Set objFileIO = Nothing
            Exit Sub
        End If
        
        ' CSV項目のエイリアス設定
        .SetValue "項目1", 1
        .SetValue "項目2", 2
        .SetValue "項目3", 3
        
        Do While .HasNext
            Debug.Print .GetItemCount       ' カレント行のCSV項目数
            Debug.Print .GetValue("項目1")
            Debug.Print .GetValue("項目2")
            Debug.Print .GetValue("項目3")
            Debug.Print .GetValue(4)        ' エイリアスでなくて列番号で取得する場合(1から)
            .NextLine   ' 次の行へ
        Loop
                
    End With
    
    Set objFileIO = Nothing
    
End Sub

' 固定長ファイルの作成
Public Sub MakeFixedLenFile()

    Dim objFileIO       As New clsMakeFixedLenValue
    Dim i               As Integer
    
    With objFileIO
        If .SetFilePath(ThisWorkbook.Path & "\" & "MakeFixedLenFile.txt") = ERROR_FILEOPEN Then
            MsgBox "エラー", vbExclamation
            Set objFileIO = Nothing
            Exit Sub
        End If

        ' デフォルト装飾設定
        .Decoration = fixlenAlignLeft + fixlenWithNarrowSpace   ' 左寄せ、半角スペース埋め
        
        For i = 0 To 10
            .AddValue "aaa", 10                                     ' 第二引数はバイト数
            .AddValue "bbb", 10, fixlenAlignRight + fixlenWithZero  ' デフォルトと違う場合、個別に指定
            .AddValue "ccc", 10, fixlenAlignLeft + fixlenWithZero   ' デフォルトと違う場合、個別に指定
            .NextLine
        Next i
        
        .NextLine
        
        .NextLine

    End With
    
    Set objFileIO = Nothing
    
End Sub

' 固定長ファイルの読み込み
Public Sub ReadFixedLenFile()

    Dim objFileIO       As New clsReadFixedLenValue
    
    With objFileIO
        If objFileIO.SetFilePath(ThisWorkbook.Path & "\" & "ReadFixedLenFile.txt") <> NORMAL_FILEOPEN Then
            MsgBox "ファイルを開けませんでした。", vbExclamation
            Set objFileIO = Nothing
            Exit Sub
        End If

        ' 固定長ファイルのエイリアス設定
        objFileIO.SetValue "項目1", 1, 3  ' 1バイト目から3バイト分
        objFileIO.SetValue "項目2", 4, 3
        objFileIO.SetValue "項目3", 7, 3
            
        Do While objFileIO.HasNext
            Debug.Print objFileIO.GetValue("項目1")
            Debug.Print objFileIO.GetValue("項目2")
            Debug.Print objFileIO.GetValue(7, 3)    ' エイリアスではなく直接指定したい場合(7バイト目から3バイト分)
            .NextLine   ' 次の行へ
        Loop
    End With
    
    Set objFileIO = Nothing
    
End Sub

作成したモジュール

ExcelFileIO.zip

コメントを残す

メールアドレスが公開されることはありません。 * が付いている欄は必須項目です