Hatena::ブログ(Diary)

miauの避難所

2011-02-03

UTF-8 でファイル保存する処理

VBAWSHプログラミングでは ADODB.Stream を使って文字コード変換するテクニックがよく知られていますが、UTF-8 で保存すると BOM(Byte Order Mark)がついてしまうようで。

解決策を探すと、

あたりに載ってたんですが、ADODB.Stream を二回 CreateObject してたりしてちょっと冗長に感じたので、少し書き換えて使っています。


完成品

ファイル保存以外で余計な処理も入ってますが、サブルーチン全体を載せておきます。

' 指定されたファイルに指定された文字列を出力する
Public Sub FilePutContents(ByVal sFileName As String, sBuffer As String, Optional sEncoding As String, Optional bSaveToWorkbookPath As Boolean)
    Dim oFso As Object
    Dim oFile As Object
    
    Set oFso = CreateObject("Scripting.FileSystemObject")
    
    ' フラグが指定された場合はワークブックのパスに保存する
    If bSaveToWorkbookPath Then
        sFileName = oFso.GetParentFolderName(ActiveWorkbook.FullName) + "\" + sFileName
    End If

    If sEncoding <> "" Then
        ' エンコーディングが指定された場合は ADODB.Stream を利用して文字コードを変換する
        Dim oAdo As Object
        Set oAdo = CreateObject("ADODB.Stream")
        oAdo.Type = adTypeText
        oAdo.Charset = sEncoding
        
        oAdo.Open
        oAdo.WriteText sBuffer
        
        ' UTF-8 であれば BOM つきで出力されているはずなので削る
        If LCase(sEncoding) = "utf-8" Then
            ' 出力された BOM をスキップして読み込み直す
            oAdo.Position = 0   ' Type の変更には Position が 0 である必要あり
            oAdo.Type = adTypeBinary
            oAdo.Position = 3   ' 先頭の 3 bytes(BOM)をスキップ
            Dim sEncodedBuffer As Variant
            sEncodedBuffer = oAdo.Read()
            
            ' ストリームの先頭に戻って内容を再度書きだす
            oAdo.Position = 0
            oAdo.Write sEncodedBuffer
            oAdo.SetEos     ' ストリームの最後にゴミが残っているので削る
        End If
        oAdo.saveToFile (sFileName), adSaveCreateOverWrite
        oAdo.Close
    Else
        ' エンコーディングが指定されていない場合は FileSystemObject で出力する
        Set oFile = oFso.CreateTextFile(sFileName, True)
        oFile.Write sBuffer
        oFile.Close
    End If
End Sub

Position を 0 に戻したり、SetEos() でストリームを終端したりという部分は、

を参考にしました。あいかわらず頼りになるページですね・・・。

スパム対策のためのダミーです。もし見えても何も入力しないでください
ゲスト


画像認証

トラックバック - http://d.hatena.ne.jp/miau/20110203/1296706718
リンク元