masalibの日記

システム開発、運用と猫の写真ブログです

エクセルVBAでUTF-8ファイル出力する

VBAでは単純なテキストのオブジェクトでは
UTF-8の出力できないそうで・・・orz
参考サイト
http://d.hatena.ne.jp/niemands/20090316/1237225383
コチラのサイトを参考にプログラムを作りました
 
プログラム仕様としては
1行目がタイトルで
2行目以降がデータ
そのデータを読み込んでその内容、
UTF-8CSVに出力するというものです
 
このソースにあとはボタンを対応すれば
CSV出力できるプログラムです
 

ソースは以下のとおり
 

Sub dsp_file()

  
    Dim myTmp As String             '出力するデータ
    Dim bErrorFlag As String
    Dim w As Worksheet
    Dim i As Long, j As Long
    Dim xlAPP As Application        ' Applicationオブジェクト
    Dim X(1 To 23) As Variant        ' 書き出すレコード内容
    Dim GYO As Long                 ' 収容するセルの行
    Dim GYOMAX As Long              ' データが収容された最終行
    Dim lngREC As Long              ' レコード件数カウンタ
    Dim COL As Long                 ' カラム(Work)
    Dim myPath As String            'フォルダパス
    Dim Stream                      'UTF-8に出力するための変数
    
    Const adTypeText = 2            '出力するためのConst
    Const adSaveCreateOverWrite = 2 '出力するためのConst
       
    '*** 保存するパスの設定 start
    Dim ShellApp As Object
    Dim oFolder As Object
    Set ShellApp = CreateObject("Shell.Application")
    Set oFolder = ShellApp.BrowseForFolder(0, "フォルダ選択", 1)
    myPath = oFolder.items.Item.Path
    
    If Dir(myPath, vbDirectory) = "" Then
        MsgBox "保存するフォルダがありません。保存フォルダ: " & myPath
        Exit Sub
    End If
    '*** 保存するパスの設定 End
    
    
    '***  収容最終行の判定(Excel認知の最終行から上に向かってデータがある行を探す) start
    GYOMAX = Cells(65536, 1).End(xlUp).Row
    If GYOMAX < 2 Then
        xlAPP.StatusBar = False
        MsgBox "2行目からデータを入力してください。", , cnsTitle
        Exit Sub
    End If
    
    '***  収容最終行の判定 End
    
    '***  最初のデータをセット
    GYO = 2
    
    '*** UTF-8で出力するためのADOを読み込み start
    Set Stream = CreateObject("ADODB.Stream")
    Stream.Open
    Stream.Type = adTypeText
    Stream.Charset = "UTF-8"
    '*** UTF-8で出力するためのADOを読み込み End
    
    
  
    ' 最終行まで繰り返す
    Do Until GYO > GYOMAX
        bErrorFlag = "0"
        Erase X         ' 初期化                                        ' ①
        ' 内容をレコードにセット(先頭は2行目)
        For COL = 1 To 22
            X(COL) = Replace(Cells(GYO, COL).Value, vbLf, vbCrLf)         ' ②
        Next COL
                      
        '***出力用の内容初期化
        myTmp = ""
              
        '***表示順:1
        myTmp = myTmp & """" & X(1) & """" & vbTab
                    
        '1行ずつ書き込む
        Stream.WriteText myTmp, adWriteLine
        GYO = GYO + 1
    
    Loop
   
    'オブジェクトの内容をファイルに保存
    Stream.SaveToFile (myPath & "\XXXXXX.csv"), adSaveCreateOverWrite
       
    'オブジェクトを閉じる
    Stream.Close
    
    'メモリからオブジェクトを削除する
    Set Stream = Nothing
   
    MsgBox myPath & "に取り込み用の楽曲ファイル(csv)を作成しました。"

End Sub