UTF-8 BOMなしでCSV保存

'
' ブックをCSV（UTF-8）形式で名前を付けて保存する。
' その際、BOMなしのファイルも併せて作成する。
' 既にファイルがある場合は上書きするので注意。
'
Sub sample()

    ' アラートを消しておく（SaveAsの際、既にファイルがある場合に上書きになる）
    Application.DisplayAlerts = False


    ' FSO準備
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")


    ' ダイアログを表示して保存先ファイル名を取得
    Dim csvFileName As Variant
    
    csvFileName = Application.GetSaveAsFilename(FileFilter:="CSVファイル,*.csv")
    If csvFileName = False Then
        Exit Sub
    End If
    
    
    ' 一時ファイル用のファイル名を生成
    Dim tempFileName As String
    
    With fso
        tempFileName = .GetSpecialFolder(2) & "\" & .GetBaseName(.GetTempName) & ".csv"
    End With
    
    
    ' 一時ファイルとしてCSVファイルで保存（UTF-8 BOMあり）
    ActiveWorkbook.SaveAs Filename:=tempFileName, FileFormat:=xlCSVUTF8, CreateBackup:=False
    
    
    ' 続けて保存先ファイル名で保存しなおす（UTF-8 BOMあり）
    ActiveWorkbook.SaveAs Filename:=csvFileName, FileFormat:=xlCSVUTF8, CreateBackup:=False



    ' ここから一時ファイルを元にBOMなしのファイルを作っていく
    
    ' BOMなし用のファイル名を生成
    Dim csvFileNameNoBom As String
    With fso
        csvFileNameNoBom = .GetParentFolderName(csvFileName) & "\" & Replace(.GetFileName(csvFileName), ".csv", "（BOMなし）.csv")
    End With


    ' Stream1　OPEN
    Dim stream1 As Object
    Set stream1 = CreateObject("ADODB.Stream")
    stream1.Type = 1             ' ファイルのタイプ(1:バイナリ 2:テキスト)
    stream1.Open
    
    
    ' Stream1　一時ファイルを開く
    stream1.LoadFromFile tempFileName
    
    
    ' Stream1　BOM分だけカーソルを進める
    stream1.Position = 3
    
    
    ' Stream2　OPEN
    Dim stream2 As Object
    Set stream2 = CreateObject("ADODB.Stream")
    stream2.Type = 1             ' ファイルのタイプ(1:バイナリ 2:テキスト)
    stream2.Open
    
    
    ' Stream1 から Stream2 にデータを流し込む
    ' この時点でBOMがない状態で写される
    stream2.Write stream1.Read
    
    
    ' Stream2　ファイルに出力する
    ' 第二引数 : 1.新規作成、2.上書き保存
    stream2.SaveToFile csvFileNameNoBom, 2
        
        
    ' Stream　Close
    stream1.Close
    stream2.Close
    
    
    ' 一時ファイル削除
    Kill tempFileName

End Sub