Excel VBAからUTF-8ファイルを出力する

VBA 文字コード

ちょっと用があってExcelからUTF-8ファイルを出力したかったのだが、まっとうな方法がなかったので自作したという話。
単にExcelで作ったテーブルをうまいことXMLに変換したいだけだったのだけど、ExcelのXMLエクスポート機能は制約が多すぎてなんだか使えないし、VBAからWorkbook.SaveAsでUTF-8テキストファイルとして出力しようとしても*1うまいこと行かない。


検索すると、VBAでUTF-8ファイルを作成する場合はADODBを利用するのが一般的らしいけど、これもめんどいというか使い勝手がいまいち。あとはWideCharToMultiByteを直呼びするとか。もうバカかアホかと。たかがUTF-8出力するくらいでなんでこんなめんどいことしなきゃならんのか…。


というわけで作ってみた。UTF-8なんて仕様としてはちょろい*2から普通にゴリゴリ書いた方が早くて確実だったりするのよね…。


MBTextWriterクラス



Option Explicit

Option Base 1
Private opened As Boolean

Private fn As Integer
Sub OpenFile(ByVal FileName As String)
    If opened Then

        ' File is already open

        Error 55

    End If
    If Dir(FileName) <> "" Then

        Kill FileName

    End If
    fn = FreeFile()

    Open FileName For Binary As #fn

    

    opened = True
End Sub
Sub CloseFile()
    If Not opened Then

        ' File not found

        Error 53

    End If
    Close #fn

    

    opened = False
End Sub
Sub WriteUtf8Text(ByVal src As String)
    Dim uc As Long

    Dim dst As String

    Dim buf() As Byte

    Dim i As Long

    Dim hexet2 As Integer, hexet1 As Integer, hexet0 As Integer

    

    If Not opened Then

        ' File not found

        Error 53

    End If
    If src = "" Then Exit Sub
    dst = ""

    

    For i = 1 To Len(src)

        uc = AscW(Mid$(src, i, 1))

        If uc < 0 Then uc = uc + &H10000

        hexet0 = uc Mod 64

        hexet1 = Int(uc / 64) Mod 64

        hexet2 = Int(uc / 4096) Mod 16

        If uc < &H80 Then

            dst = dst & ChrB$(uc)

        ElseIf uc < &H800 Then

            dst = dst & ChrB$(&HC0 + hexet1) & ChrB$(&H80 + hexet0)

        ElseIf uc < &H1000 Then

            dst = dst & ChrB$(&HE0) & ChrB$(&HA0 + hexet1) & ChrB$(&H80 + hexet0)

        Else

            dst = dst & ChrB$(&HE0 + hexet2) & ChrB$(&H80 + hexet1) & ChrB$(&H80 + hexet0)

        End If

    Next i
    ReDim buf(LenB(dst))

    For i = 1 To LenB(dst)

        buf(i) = AscB(MidB$(dst, i, 1))

    Next i

    Put #fn, , buf
End Sub


MBTextWriter呼び出し側



Sub WriteUTF8Test()
    Dim utf8_file As MBTextWriter

    

    Set utf8_file = New MBTextWriter
    utf8_file.OpenFile "test_utf8.txt"

    utf8_file.WriteUtf8Text "UTF-8テキスト: 出力テスト" & vbCrLf

    utf8_file.CloseFile
    Set utf8_file = Nothing
End Sub


要するに1文字ずつスキャンして、UTF-16からUTF-8に変換している。最終的に、Byte配列に格納して、Binaryモードでオープンしたファイルにput。本当、全然大した処理でないね…。
気が向いたらEUC(J)バージョンとかJISバージョンとかも作れるけどとりあえず用がないので今はやらない。

*1:TextCodePage:=65001とか

*2:たとえばこの辺とか参照: UTF-8 - Wikipedia