まえがき
ActiveX Data Objects(ADODB)がないOffice 2016 for Macにおいて、VBAでUTF-8なテキストファイルを出力する方法です。
最初妥協策としてUTF-16で出力していましたが、その後意地になってUTF-8版を作りましたので公開します。
2020/10/6追記
コードに不具合がありますので、ご利用の方はコメント欄もご参照ください。
コード
utf8.xlsm
Option Base 0
' 文字列をUTF-8でPutする
' 引数:
' fileNum: Openステートメントで指定したファイル番号
' str: 出力する文字列
' 備考:
' ファイルは Open 〜 For Binary で開かれていること
Sub PutUTF8String(ByVal fileNum As Integer, ByRef str As String)
Dim byteUTF8() As Byte ' 文字をUTF-8エンコードしたものを格納する
Dim c, d As String ' 変換する文字 (dはサロゲートペア下位用)
Dim i, w, v As Integer ' ループカウンタと文字コード取得用
Dim u As Long ' Unicode化した文字コード
' For 〜 Next ではなく Do 〜 Loop なのはループ中でカウンタを飛ばすため
i = 1
Do While i <= Len(str)
c = Mid(str, i, 1)
w = AscW(c)
if w >= &HD800 And w < &HDBFF then
' サロゲートペア上位の場合はカウンタを進めて下位も取得する
' ToDo: サロゲートペア下位の値チェック
i = i + 1
d = Mid(str, i, 1)
v = AscW(d)
' サロゲートペアのデコード
u = &H10000& + ((w And &HFFFF&) - &HD800&) * &H400& + ((v And &HFFFF&) - &HDC00&)
Else
' 符号ありで表現された文字コードを符号なし表現へ
u = w And &HFFFF&
End If
byteUTF8() = Unicode2UTF8(u)
Put #fileNum, , byteUTF8
i = i + 1
Loop
End Sub
' UnicodeをUTF-8にエンコードする
' 引数:
' u: Unicode文字コード
' 戻値:
' UTF-8エンコードした文字のByte配列
Function Unicode2UTF8(u As Long) As Byte()
Dim byteUTF8() As Byte
Select Case u
Case Is < &H80&
ReDim byteUTF8(0)
byteUTF8(0) = CByte(u)
Case Is < &H800&
ReDim byteUTF8(1)
byteUTF8(0) = CByte(((u And &H7F0&) / 64) + 192)
byteUTF8(1) = CByte((u And &H3F&) + 128)
Case Is < &H10000&
ReDim byteUTF8(2)
byteUTF8(0) = CByte(((u And &HF000&) / 4096) + 224)
byteUTF8(1) = CByte(((u And &HFC0&) / 64) + 128)
byteUTF8(2) = CByte((u And &H3F&) + 128)
Case Is < &H200000&
ReDim byteUTF8(3)
byteUTF8(0) = CByte(((u And &H1C0000&) / 262144) + 240)
byteUTF8(1) = CByte(((u And &H3F000&) / 4096) + 128)
byteUTF8(2) = CByte(((u And &HFC0&) / 64) + 128)
byteUTF8(3) = CByte((u And &H3F&) + 128)
Case Else
' UTF-8で5バイト以上になる範囲はエラー代わりに1バイトの0を返す
ReDim byteUTF8(0)
byteUTF8(0) = 0
End Select
Unicode2UTF8 = byteUTF8()
End Function
' サンプル
' 選択中ワークシートのA1セルの内容をブックと同ディレクトリの test.txt に出力
Sub WriteFileTest()
Dim FilePath As String
Dim UnicodeString As String
FilePath = ThisWorkbook.Path & "/test.txt"
UnicodeString = Range("A1").Value
' ファイルがすでに存在する場合は削除
' これを忘れると既存ファイルの一部が出力ファイル末尾に残ったりする
If Dir(FilePath) <> "" Then
Kill FilePath
End If
Open FilePath For Binary Access Write As #1
PutUTF8String 1, UnicodeString
Close #1
End Sub
実行結果
- Excelのマクロに上記コードを登録
- A1セルに「123 abcABC§©® ａｂｃＡＢＣあいうアイウｱｲｳ亜唖娃弌丐丕髙杮鷗𩸽😀😁😂👩👩👦👦」をペースト
* `WriteFileTest`を実行
* 出力されたファイルをテキストエディットで開いた結果
* 出力されたファイルをダンプした結果
$ od -t x1 test.txt
0000000 31 32 33 20 61 62 63 41 42 43 c2 a7 c2 a9 c2 ae
0000020 e3 80 80 ef bd 81 ef bd 82 ef bd 83 ef bc a1 ef
0000040 bc a2 ef bc a3 e3 81 82 e3 81 84 e3 81 86 e3 82
0000060 a2 e3 82 a4 e3 82 a6 ef bd b1 ef bd b2 ef bd b3
0000100 e4 ba 9c e5 94 96 e5 a8 83 e5 bc 8c e4 b8 90 e4
0000120 b8 95 e9 ab 99 e6 9d ae e9 b7 97 f0 a9 b8 bd f0
0000140 9f 98 80 f0 9f 98 81 f0 9f 98 82 f0 9f 91 a9 e2
0000160 80 8d f0 9f 91 a9 e2 80 8d f0 9f 91 a6 e2 80 8d
0000200 f0 9f 91 a6
0000204
やっていること
- 文字列を1文字ずつばらす
- ばらした文字をAscWにかけてUnicode値を取得する
- サロゲートペアだった場合はデコードする
- 取得したUnicode値をUTF-8にエンコードしてByte配列に格納する
- Byte配列をPutする
備考とあとがき
U+200000以上の文字はゼロ文字に変換します。
サロゲートペア下位の値範囲チェックは省略していますのでご注意ください。
動作確認はmacOS Sierra 10.12.6 + Excel for Mac 16.12(180410) Office365版で行いました。
UTF-8のエンコードはSelect Caseを使わずに書けそうな気もしますが、今後の課題とさせてください‥‥‥
参考
VBAでサロゲートペア対応Len
[VBAで絵文字💖]
(https://qiita.com/masaoki/items/3488320842a9c3f9fc4e)