SaveAsUTF8CSV.bas

SaveAsUTF8CSV.bas

Option Explicit

Sub SaveAsUTF8CSV()

    '==============================
    ' 使用しているデータ範囲の取得
    '==============================

    Dim maxRow As Long
    Dim maxCol As Long

    With ActiveSheet.UsedRange
        maxRow = .Row + .Rows.Count - 1
        maxCol = .Column + .Columns.Count - 1
    End With

    '==============================
    ' ストリームの準備
    '==============================

    Dim outStream As ADODB.Stream
    Set outStream = New ADODB.Stream

    'エンコーディングを指定
    With outStream
        .Type = adTypeText
        .Charset = "UTF-8"
        .LineSeparator = adLF
    End With

    outStream.Open

    '==============================
    ' ストリームにデータを流し込む
    '==============================

    Dim r As Long
    Dim c As Long
    Dim line As String
    
    '1 行ずつ処理
    For r = 1 To maxRow

        '1 列目はカンマなし
        line = ActiveSheet.Cells(r, 1)
        
        '2 列目以降
        For c = 2 To maxCol
            line = line & "," & ActiveSheet.Cells(r, c)
        Next
        
        'r 行目のデータを Stream に出力
        outStream.WriteText line, adWriteLine
    Next

    '==============================
    ' 先頭の BOM を削除
    '==============================
    
    'BOM の分 3 バイトをスキップ
    outStream.Position = 0
    outStream.Type = adTypeBinary
    'outStream.Position = 3
    outStream.Position = 0

    'コピー用のストリーム
    Dim csvStream As ADODB.Stream
    Set csvStream = New ADODB.Stream

    'バイナリモードで開く
    csvStream.Type = adTypeBinary
    csvStream.Open

    'BOM の後からデータをコピー
    outStream.CopyTo csvStream

    '==============================
    ' ストリームのデータを書き出す
    '==============================

    Dim fileName As String
    fileName = ActiveSheet.Name & ".csv"


'-------------------------------------
    Debug.Print "------------------StateMotionExportCsvMacro-------------------------------------"
    
    Dim csvFilePath As String
    Dim ParentDirName As String
    
    ' ファイル名の取得（拡張子を除く）
    fileName = Left(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, ".", -1, vbTextCompare) - 1)
        
    '親ディレクトリ(リポジトリの直下)
    ParentDirName = Left(ActiveWorkbook.Path, InStrRev(ActiveWorkbook.Path, "\") - 1)
    Debug.Print "ParentDirName" & ParentDirName & vbNewLine
    '親親ディレクトリ(github)
    ParentDirName = Left(ParentDirName, InStrRev(ParentDirName, "\") - 1)
    Debug.Print "ParentDirName" & ParentDirName & vbNewLine
    
    
    
    ' CSVファイルパスの作成
    csvFilePath = ActiveWorkbook.Path & "\" & fileName & ".csv"
    csvFilePath = ParentDirName & "\" & "3DAsset\Assets\Tools\Motion\Editor\ExcelMotionAttachCSV" & "\" & fileName & "_ActionSkill_motionAttach" & ".csv"
    csvFilePath = ParentDirName & "\" & "3DAsset\Assets\Tools\Motion\Editor\ExcelMotionAttachCSV" & "\" & "character" & "_ActionSkill_motionAttach" & ".csv"
'---------------------------------------

    'ファイルに保存
    csvStream.SaveToFile csvFilePath, adSaveCreateOverWrite

    'ストリームの後始末
    csvStream.Close
    outStream.Close

End Sub