つらつら Excel VBA

私の備忘録です。

BOM有無UTF-8テキストファイルの読み書き

「Option Explicit」マジ大事。適当に書いても動くからVBA厄介デスヨネー。
UTF-8はBOM有で、UTF-8NはBOM無し。
本題。UTF-8はADODBを使って入出力します。FSOもついでに載せときます。

Option Explicit

Public Sub テキストファイルUTF8読み込み(strFilePath As String)

    Dim buf As String, temp As Variant
    Dim iRow As Long, iClm As Long
    Dim ws As Worksheet
    
    Set ws = ThisWorkbook.Worksheets("読込結果")
    
    '違う文字コードのファイルを読み込むとエラーとなるので必ず回避。
    '回避先でCloseを忘れない。
    On Error GoTo err_1

    With CreateObject("ADODB.Stream")
        .Charset = "UTF-8"
        .Open
        .LoadFromFile strFilePath
        Do Until .EOS 'EOFと同義
            buf = .ReadText(-2) '1行ずつ読み込みは-2、全て読み込みは-1又は引数無し
            iRow = iRow + 1
            temp = Split(buf, vbTab) 'タブ区切り
            For iClm = LBound(temp) To UBound(temp)
                ws.Cells(iRow, iClm + 1) = temp(iClm)
            Next
    Loop
err_1:
        .Close
    End With
    
    Set ws = Nothing
    
End Sub

Public Sub テキストファイル読み込みFSO(strFilePath As String)

    Dim buf As String, temp As Variant, lineTemp As Variant
    Dim iRow As Long, iClm As Long
    Dim ws As Worksheet
    
    Set ws = ThisWorkbook.Worksheets("読込結果")
    
    With CreateObject("Scripting.FileSystemObject")
        With .GetFile(strFilePath).OpenAsTextStream
            buf = .ReadAll '全て読み込む
            .Close
        End With
    End With
    
    lineTemp = Split(buf, vbCrLf) '改行で区切る
    For iRow = LBound(lineTemp) To UBound(lineTemp)
        temp = Split(lineTemp(iRow), vbTab) 'タブ区切り
        For iClm = LBound(temp) To UBound(temp)
            ws.Cells(iRow + 1, iClm + 1) = temp(iClm)
        Next
    Next
    
    Set ws = Nothing
    
End Sub

Public Sub テキストファイル書き出しFSO()

    Dim strFilePath As String
    Dim buf As String
    Dim delimiter As String
    Dim row As Range, clm As Range
    
    Dim ws As Worksheet
    Dim fso As Object
    
    strFilePath = Application.GetSaveAsFilename(InitialFileName:="shift-jis.txt", _
    FileFilter:="テキストファイル(*.txt),*txt,CSVファイル(*.csv),*.csv")
    If strFilePath = "False" Then Exit Sub
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ws = ThisWorkbook.Worksheets("読込結果")
    
    delimiter = vbTab 'タブ区切り
    
    With fso.CreateTextFile(strFilePath)
        
        For Each row In ws.UsedRange.Rows
            
            buf = ""
            For Each clm In row.Columns
                buf = buf & clm.Value
                If clm.Column < row.Columns(row.Columns.Count).Column Then
                    buf = buf & delimiter '最後の列でなければ区切り文字を追加
                End If
            Next
            
            .WriteLine buf
        Next
        
        .Close
        
    End With
    
    Set ws = Nothing
    Set fso = Nothing
    
End Sub

Public Sub テキストファイル書き出しADODB(Optional bom As Boolean = True)
    
    Dim ws As Worksheet
    Dim strFilePath As String
    Dim buf As String
    Dim delimiter As String
    Dim row As Range, clm As Range
    
    strFilePath = Application.GetSaveAsFilename(InitialFileName:="utf-8.txt", _
    FileFilter:="テキストファイル(*.txt),*txt,CSVファイル(*.csv),*.csv")
    If strFilePath = "False" Then Exit Sub
    
    Set ws = ThisWorkbook.Worksheets("読込結果")
    
    delimiter = vbTab 'タブ区切り
    
    With CreateObject("ADODB.Stream")
        
        .Charset = "UTF-8"
        .LineSeparator = -1 '-1:adCRLF, 10:adLF, 13:adCR
        .Open
        
        For Each row In ws.UsedRange.Rows
            
            buf = ""
            For Each clm In row.Columns
                buf = buf & clm.Value
                If clm.Column < row.Columns(row.Columns.Count).Column Then
                    buf = buf & delimiter '最後の列でなければ区切り文字を追加
                End If
        Next
        
        .WriteText buf, 1 '0:adWriteChar, 1:adWriteLine
    Next
    
    
    If Not bom Then
        'UTF-8N(UTF-8 BOM無し)を出力する
        Dim byteData() As Byte
        .Position = 0
        .Type = 1 '1:adTypeBinary(バイナリ), 2:adTypeText(既定値、テキスト)
        .Position = 3 '先頭3Byte(BOM)を回避
        byteData = .Read '書き込み予定データを一時避難
        .Position = 0
        .Write byteData '一時避難データを再設定
        .SetEOS '終了個所を再設定
        .SaveToFile strFilePath, 2 '1:adSaveCreateNotExist(既定値、新規作成), 2:adSaveCreateOverWrite(上書保存)
        .Close
    Else
        'BOM有のUTF-8を出力する
        .SaveToFile strFilePath, 2
        .Close
    End If
    
    End With
    
    Set ws = Nothing
    
End Sub