So-net無料ブログ作成
検索選択

[VBA]文字コードを指定してファイルにテキストを出力するクラスモジュール [Programming ExcelVBA]

[はじめに]
・最近、JSONファイルを扱うことがあり、
 UTF-8でテキストファイルを作成する機会があったので、
 作ってみました。
 備忘録としてサンプルを掲載します。
 クラスモジュールで定義することを前提としています。

[ソース]
コードのコピー
''' <summary>
''' クラスモジュール名:TextWriterWithCharaSet
''' 文字コードを指定してファイルにテキストを出力するクラス
''' </summary>
''' <remarks></remarks>
Option Explicit

'ファイルのバッファサイズ
Private Const BUF_SIZE As Integer = 1024

'文字コード(デフォルト:UTF-8)
Public CharCode As String

'出力ディレクトリ
Public TargetDirectory As String

'出力ファイル名
Public TargetFileName As String

'FileSystemObject
Private objFs As Object

'ADODB.Stream
Private objStream As Object

'ADODB.StreamのSaveOptionsEnum
Private Enum SaveOptionsEnum
    'ファイルが存在しない場合にのみ作成します。
    '存在する場合はエラー。(既定値)
    adSaveCreateNotExist = 1
    'ファイルが存在する場合は、
    'ファイルを上書きします。
    adSaveCreateOverWrite = 2
End Enum

'出力テキストのコレクション
Private colTraget As New Collection

''' <summary>
''' Initializeイベント(コンストラクタ)
''' </summary>
''' <remarks></remarks>
Private Sub Class_Initialize()
    Set objStream = CreateObject("ADODB.Stream")
    Set objFs = CreateObject("Scripting.FileSystemObject")
    
    Me.CharCode = "UTF-8"
    
    Call ClearBuffer
End Sub

''' <summary>
''' Terminateイベント(デストラクタ)
''' </summary>
''' <remarks></remarks>
Private Sub Class_Terminate()
     
    Call Flush
    
    Set objStream = Nothing
    Set objFs = Nothing

End Sub

''' <summary>
''' テキストを出力する。
''' </summary>
''' <param name="strText">出力テキスト</param>
''' <param name="useBuffer">バッファの利用有無</param>
''' <remarks></remarks>
Public Sub WriteText( _
    ByVal strText As String, _
    Optional ByVal useBuffer As Boolean = False)
    
    colTraget.Add strText
    
    If useBuffer = True Then
        If colTraget.Count > BUF_SIZE Then
            'バッファがサイズを超えた場合は、ファイルに出力
            Me.Flush
        End If
    Else
        'バッファ無効の場合は、ファイルに出力
        Me.Flush
    End If

End Sub

''' <summary>
''' バッファーのデータをテキストに出力する。
''' </summary>
''' <remarks></remarks>
Public Sub Flush()
     
    Dim i As Long
    Dim targetFilePath As String
    
    On Error GoTo LBL_ERR:
     
    'ファイルパスを生成
    targetFilePath = objFs.BuildPath( _
        GetTargetDirectory(), TargetFileName)
    
    With objStream
        .Charset = Me.CharCode
        .Open
        
        'ファイルが既に存在する場合は、全テキストを読込む。
        '※追記書込みができないので、
        '  既存テキストをメモリ上に取込んでから上書きする。
        If objFs.FileExists(targetFilePath) Then
            .LoadFromFile targetFilePath
            .Position = .Size
        End If

        For i = 1 To colTraget.Count
            .WriteText colTraget(i)
        Next
        
        .SaveToFile targetFilePath, _
            SaveOptionsEnum.adSaveCreateOverWrite
        
        .Close
    
    End With
     
    Call ClearBuffer
    
    Exit Sub
LBL_ERR:
    
     Call ClearBuffer
     
     Err.Raise _
         Number:=Err.Number, _
         Description:="テキストの出力に失敗しました。" & _
         Err.Description

End Sub

''' <summary>
''' 出力ディレクトリを取得する。
''' </summary>
''' <returns>出力ディレクトリ(デフォルト:ThisWorkbook.path)</returns>
''' <remarks></remarks>
Private Function GetTargetDirectory() As String
     If Me.TargetDirectory = "" Then
         GetTargetDirectory = ThisWorkbook.path
         Exit Function
     End If

     GetTargetDirectory = Me.TargetDirectory

End Function

''' <summary>
''' 出力ファイルパスを設定する。
''' </summary>
''' <param name="targetFilePath">出力ファイルパス</param>
''' <remarks></remarks>
Public Sub SetFilePath(ByVal targetFilePath As String)
     
    With objFs
        Me.TargetDirectory = _
            .GetParentFolderName(targetFilePath)
        Me.TargetFileName = _
            objFs.GetFileName(targetFilePath)
    End With

End Sub

''' <summary>
''' バッファーをクリアする。
''' </summary>
''' <remarks></remarks>
Public Sub ClearBuffer()
     Dim i As Long
     
     For i = colTraget.Count To 1 Step -1
         colTraget.Remove i
     Next

End Sub
[VBA]文字コードを指定してファイルにテキストを出力するクラスモジュール

[ソース]
コードのコピー
Private Sub CommandButton1_Click()

    Dim rw As New TextWriterWithCharaSet
    
    rw.CharCode = "UTF-8"
    rw.SetFilePath "C:\aaa\hogehoge.txt"
    rw.WriteText "ABCDE"True
    
    Set rw = Nothing
    
End Sub
[VBA]使用例

メッセージを送る

この広告は前回の更新から一定期間経過したブログに表示されています。更新すると自動で解除されます。