EasyTextFileクラスは今……

f:id:akashi_keirin:20210918103251p:plain

クラスモジュールのコード

ただ、クラスモジュールのコードを晒すだけ……。

たぶん、盛大にヌケやモレがあると思うし、そもそもTextStreamオブジェクトのこととかADOSteramオブジェクトのことをろくに理解もせずに、手探りで書いたようなコードなので、ツッコミどころだらけだと思う。

達人の皆さんのご指南を仰ぎたく思う。

リスト１　クラスモジュール：EasyTextFile

Option Explicit

'設定用のテキストファイルを扱うためだけに使うクラス'
'必要最小限の機能にとどめる'
'2021-09-18現在の機能'
'・テキスト読み込み'
'・行のテキストの書きかえ'
'・行の追記：Appendメソッド'
'・テキストファイルの上書き保存：Saveメソッド'
'・テキストファイルの別名保存：SaveAsメソッド'

'Public enums'
'Enumerations for Scripting.FileSystemObject object'
Public Enum TFCharCode
  tfShiftJIS = 0
  tfUTF8 = 1
  tfUTF16 = -1
'  tfUseDefault = -2'
End Enum

'Private enums'
'Enumerations for ADODB.Stream object'
Private Enum StreamTypeEnum
  adTypeBinary = 1
  adTypeText = 2
End Enum

Private Enum SaveOptionsEnum
  adSaveCreateNotExist = 1
  adSaveCreateOverWrite = 2
End Enum

Private Enum StreamReadEnum
  adReadAll = -1
  adReadLine = -2
End Enum

Private Enum StreamWriteEnum
  adWriteChar = 0
  adWriteLine = 1
End Enum

'Enumerations for Scripting.FileSystemObject'
Private Enum IOMode
  ForReading = 1
  ForWriting = 2
  ForAppending = 8
End Enum

Private Enum Tristate
  TristateFalse = 0
  TristateTrue = -1
  TristateUseDefault = 2
End Enum

'Enumerations for error'
Private Enum TFErrType
  tfErrNotInitialized = 1
  tfErrFileNotExist
  tfErrArgInvalid
End Enum

'Constants'
Private Const ERR_NUMBER As Long = 10000

'Module level variables'
'実行時バインディングにしている'
Private m_FSO As Object
Private m_TextStream As Object
Private m_ADOStream As Object

'Field variables'
Private m_Path As String
Private m_TextLines As Collection
Private m_Encoding As TFCharCode
Private m_HasInitialized As Boolean

'Constructor'
Private Sub Class_Initialize()
  Set m_FSO = CreateObject("Scripting.FileSystemObject")
  Set m_ADOStream = CreateObject("ADODB.Stream")
  Set m_TextLines = New Collection
End Sub

Public Sub Init(ByVal a_Path As String, _
                ByVal a_CharCode As TFCharCode)
  'If file not exists, raise error.'
  If Not m_FSO.FileExists(a_Path) Then
    Call raiseError(tfErrFileNotExist)
  End If
  'LinesTextに値があったら一旦全部消しておく'
  '※Collectionの要素は上書きができないため'
  Dim i As Long
  Dim cnt As Long
  cnt = m_TextLines.Count
  If cnt > 0 Then
    For i = 1 To cnt
      Call m_TextLines.Remove(CStr(i))
    Next
  End If
  m_Path = a_Path
  m_HasInitialized = True
  Dim tmp As String
  Dim n As Long
  n = 1
  m_Encoding = a_CharCode
  Select Case m_Encoding
    Case tfUTF8
    'UTF-8のテキスト読み込み'
      With m_ADOStream
        .Charset = "UTF-8"
        'ストリームを開いてファイルをロードする'
        Call .Open
        Call .LoadFromFile(Me.Path)
        '1行づつテキストを読み込む'
        Do Until .EOS
          tmp = .ReadText(adReadLine)
          Call m_TextLines.Add(tmp, CStr(n))
          n = n + 1
        Loop
      End With
      '読み込みが終わったら閉じる'
      Call m_ADOStream.Close
    Case tfShiftJIS
    'Shift_JISのテキスト読み込み'
      Call readFromTextSteram(tfShiftJIS)
    Case tfUTF16
    'UTF-16のテキスト読み込み'
      Call readFromTextSteram(tfUTF16)
  End Select
End Sub

Private Sub readFromTextSteram(ByVal a_CharCode As TFCharCode)
  Set m_TextStream = m_FSO.OpenTextFile(FileName:=Me.Path, _
                                        IOMode:=ForReading, _
                                        Create:=False, _
                                        Format:=a_CharCode)
  Dim tmp As String
  Dim n As Long
  n = 1
  With m_TextStream
    Do Until .AtEndOfStream
      tmp = .ReadLine
      Call m_TextLines.Add(Item:=tmp, Key:=CStr(n))
      n = n + 1
    Loop
  End With
  Call m_TextStream.Close
End Sub

'Destructor'
Private Sub Class_Terminate()
  Set m_ADOStream = Nothing
  Set m_TextStream = Nothing
  Set m_TextLines = Nothing
End Sub

'Properties'
Public Property Get Path() As String
  If Not m_HasInitialized Then Call raiseError(tfErrNotInitialized)
  Path = m_Path
End Property

Public Property Let Path(ByVal a_Path As String)
  If Not m_HasInitialized Then Call raiseError(tfErrNotInitialized)
  m_Path = a_Path
End Property

Public Property Get Encoding() As String
  Dim ret As String
  Select Case m_Encoding
    Case tfUTF8: ret = "UTF-8"
    Case tfShiftJIS: ret = "Shift_JIS"
    Case tfUTF16: ret = "UTF-16"
  End Select
  Encoding = ret
End Property

Public Property Get FileName() As String
  If Not m_HasInitialized Then Call raiseError(tfErrNotInitialized)
  Dim ret As String
  ret = m_Path
  Dim arr() As String
  arr = Split(ret, "\")  '"
  ret = arr(UBound(arr))
  FileName = ret
End Property

Public Property Get LinesCount() As Long
  If Not m_HasInitialized Then Call raiseError(tfErrNotInitialized)
  LinesCount = m_TextLines.Count
End Property

Public Property Let LineText(ByVal a_index As Variant, _
                             ByVal a_Text As String)
  If Not m_HasInitialized Then Call raiseError(tfErrNotInitialized)
  If Not IsNumeric(a_index) Then Call raiseError(tfErrArgInvalid)
  If CLng(a_index) < 0 Or _
     CLng(a_index) > Me.LinesCount Then Call raiseError(tfErrArgInvalid)
  '既存のアイテムを削除してから追加する'
  Call m_TextLines.Remove(CStr(a_index))
  Call m_TextLines.Add(Item:=a_Text, _
                      Key:=CStr(a_index))
End Property

Public Property Get LineText(ByVal a_index As Variant) As String
  If Not m_HasInitialized Then Call raiseError(tfErrNotInitialized)
  If Not IsNumeric(a_index) Then Call raiseError(tfErrArgInvalid)
  If CLng(a_index) < 0 Or _
     CLng(a_index) > Me.LinesCount Then Call raiseError(tfErrArgInvalid)
  LineText = m_TextLines.Item(CStr(a_index))
End Property

'Methods'
Public Sub Append(ByVal a_Text As String)
  If Not m_HasInitialized Then Call raiseError(tfErrNotInitialized)
  Dim cnt As Long
  cnt = m_TextLines.Count
  Call m_TextLines.Add(Item:=a_Text, _
                       Key:=CStr(cnt + 1))
End Sub

Public Sub Save()
  If Not m_HasInitialized Then Call raiseError(tfErrNotInitialized)
  Select Case m_Encoding
    'UTF-8'
    Case tfUTF8
      Call SaveAs(Me.Path)
    'Shif_JIS or UTF-16'
    Case tfShiftJIS
      Call SaveAs(Me.Path)
    Case tfUTF16
      Call SaveAs(Me.Path)
  End Select
End Sub

Public Sub SaveAs(ByVal a_Path As String)
  If Not m_HasInitialized Then Call raiseError(tfErrNotInitialized)
  Select Case m_Encoding
    'UTF-8'
    Case tfUTF8
      Call writeUTF8TextFile(a_Path)
    'Shif_JIS or UTF-16'
    Case tfShiftJIS
      Call writeToTextStream(a_Path, tfShiftJIS)
    Case tfUTF16
      Call writeToTextStream(a_Path, tfUTF16)
  End Select
  '最新の状態で読み込み直しておく'
  Call Me.Init(a_Path, m_Encoding)
End Sub

Private Sub writeUTF8TextFile(ByVal a_Path As String)
  Dim createNew As SaveOptionsEnum
  If m_FSO.FileExists(a_Path) Then
    createNew = adSaveCreateOverWrite
  Else
    createNew = adSaveCreateNotExist
  End If
  Dim i As Long
  With m_ADOStream
    .Charset = "UTF-8"
    Call .Open
    For i = 1 To Me.LinesCount
      Call .WriteText(Data:=Me.LineText(CStr(i)), _
                      Options:=adWriteLine)
    Next
    Call .SaveToFile(a_Path, createNew)
    Call .Close
  End With
End Sub

Private Sub writeToTextStream(ByVal a_Path As String, _
                              ByVal a_CharCode As TFCharCode)
  Dim createNew As Boolean
  If m_FSO.FileExists(a_Path) Then
    createNew = False
  Else
    createNew = True
  End If
  Set m_TextStream = m_FSO.OpenTextFile(FileName:=a_Path, _
                                        IOMode:=ForWriting, _
                                        Create:=createNew, _
                                        Format:=a_CharCode)
  Dim i As Long
  With m_TextStream
    For i = 1 To Me.LinesCount
      Call .WriteLine(Me.LineText(CStr(i)))
    Next
    Call .Close
  End With
End Sub

'Raise Error'
Private Sub raiseError(ByVal a_ErrType As TFErrType)
  Call Err.Raise(Number:=ERR_NUMBER + a_ErrType, _
                 Description:=getErrMessage(a_ErrType))
  Call Err.Clear
End Sub

Private Function getErrMessage( _
             ByVal a_ErrType As TFErrType) As String
  Dim ret As String
  Select Case a_ErrType
    Case tfErrNotInitialized: ret = "Sorry, class has not initialized yet..."
    Case tfErrFileNotExist: ret = "Sorry, file not exists..."
    Case tfErrArgInvalid: ret = "Sorry,argument is invalid... "
  End Select
  getErrMessage = ret
End Function