導出爲UTF-8 CSV文件（使用Excel-VBA）

Question

我想導出使用VBA以UTF-8 CSV格式創建的文件。從搜索留言板，我已發現下面的代碼，一個文件轉換爲UTF-8（from this thread）：

Sub SaveAsUTF8() 

    Dim fsT, tFileToOpen, tFileToSave As String 

    tFileToOpen = InputBox("Enter the name and location of the file to convert" & vbCrLf & "With full path and filename ie. C:\MyFolder\ConvertMe.Txt") 
    tFileToSave = InputBox("Enter the name and location of the file to save" & vbCrLf & "With full path and filename ie. C:\MyFolder\SavedAsUTF8.Txt") 

    tFileToOpenPath = tFileToOpen 
    tFileToSavePath = tFileToSave 

Set fsT = CreateObject("ADODB.Stream"): 'Create Stream object 
fsT.Type = 2: 'Specify stream type – we want To save text/string data. 
fsT.Charset = "utf-8": 'Specify charset For the source text data. 

fsT.Open: 'Open the stream 
fsT.LoadFromFile tFileToOpenPath: 'And write the file to the object stream 

fsT.SaveToFile tFileToSavePath, 2: 'Save the data to the named path 

End Sub 

然而，這種代碼只轉換非UTF-8文件以UTF-8。如果我要將文件保存爲非UTF-8格式，然後將其轉換爲UTF-8格式，它將會丟失它包含的所有特殊字符，從而使這個過程毫無意義！

我正在做的是以UTF-8（CSV）格式保存一個打開的文件。有沒有辦法用VBA做到這一點？

n.b.我也在'ozgrid' forum上問過這個問題。如果我找到解決方案，將關閉這兩個線程。

Answer 1

此代碼的更新。我用這一個改變所有的.csv文件中指定的文件夾（標記爲「布龍」），並在另一個文件夾保存爲CSV UTF-8（標記爲「doel」）

Sub SaveAsUTF8() 

Dim fsT As Variant, tFileToOpen As String, tFileToSave As String 
Dim Message As String 
Dim wb As Workbook 
Dim fileName As String 

Set wb = ActiveWorkbook 

With Application 
.ScreenUpdating = False 
.DisplayAlerts = False 
End With 

Message = "Source folder incorrect" 
SourceFolder = wb.Worksheets("Menu").Range("Bron") & "\" 
If Dir(SourceFolder, vbDirectory) = "" Or IsEmpty(SourceFolder) Then GoTo errorhandler 

Message = "Target folder incorrect" 
TargetFolder = wb.Worksheets("Menu").Range("Doel") & "\" 
If Dir(TargetFolder, vbDirectory) = "" Or IsEmpty(TargetFolder) Then GoTo errorhandler 

fileName = Dir(SourceFolder & "\*.csv", vbNormal) 

Message = "No files available." 
If Len(fileName) = 0 Then GoTo errorhandler 

Do Until fileName = "" 

    tFileToOpen = SourceFolder & fileName 
    tFileToSave = TargetFolder & fileName 

    tFileToOpenPath = tFileToOpen 
    tFileToSavePath = tFileToSave 

Set fsT = CreateObject("ADODB.Stream"): 'Create Stream object 
fsT.Type = 2: 'Specify stream type – we want To save text/string data. 
fsT.Charset = "utf-8": 'Specify charset For the source text data. 

fsT.Open: 'Open the stream 
fsT.LoadFromFile tFileToOpenPath: 'And write the file to the object stream 

fsT.SaveToFile tFileToSavePath, 2: 'Save the data to the named path 

fileName = Dir() 

Loop 

Message = "Okay to remove all old files?" 
If QuestionMessage(Message) = False Then 
    GoTo the_end 
Else 
    On Error Resume Next 
    Kill SourceFolder & "*.csv" 
    On Error GoTo errorhandler 
End If 

the_end: 
With Application 
.ScreenUpdating = True 
.DisplayAlerts = True 
End With 
Exit Sub 

errorhandler: 
With Application 
.ScreenUpdating = True 
.DisplayAlerts = True 
End With 
CriticalMessage (Message) 
Exit Sub 

End Sub 

'---------- 

Function CriticalMessage(Message As String) 

MsgBox Message 

End Function 

'---------- 

Function QuestionMessage(Message As String) 

If MsgBox(Message, vbQuestion + vbYesNo) = vbNo Then 
QuestionMessage = False 
Else 
QuestionMessage = True 
End If 

End Function 

Answer 2

這裏是基於Excel VBA - export to UTF-8我的解決辦法，其中user3357963與之前鏈接。它包含用於導出範圍和選擇的宏。

Option Explicit 

Const strDelimiter = """" 
Const strDelimiterEscaped = strDelimiter & strDelimiter 
Const strSeparator = "," 
Const strRowEnd = vbCrLf 
Const strCharset = "utf-8" 

Function CsvFormatString(strRaw As String) As String 

    Dim boolNeedsDelimiting As Boolean 

    boolNeedsDelimiting = InStr(1, strRaw, strDelimiter) > 0 _ 
     Or InStr(1, strRaw, Chr(10)) > 0 _ 
     Or InStr(1, strRaw, strSeparator) > 0 

    CsvFormatString = strRaw 

    If boolNeedsDelimiting Then 
     CsvFormatString = strDelimiter & _ 
      Replace(strRaw, strDelimiter, strDelimiterEscaped) & _ 
      strDelimiter 
    End If 

End Function 

Function CsvFormatRow(rngRow As Range) As String 

    Dim arrCsvRow() As String 
    ReDim arrCsvRow(rngRow.Cells.Count - 1) 
    Dim rngCell As Range 
    Dim lngIndex As Long 

    lngIndex = 0 

    For Each rngCell In rngRow.Cells 
     arrCsvRow(lngIndex) = CsvFormatString(rngCell.Text) 
     lngIndex = lngIndex + 1 
    Next rngCell 


    CsvFormatRow = Join(arrCsvRow, ",") & strRowEnd 

End Function 

Sub CsvExportRange(_ 
     rngRange As Range, _ 
     Optional strFileName As Variant _ 
    ) 

    Dim rngRow As Range 
    Dim objStream As Object 

    If IsMissing(strFileName) Or IsEmpty(strFileName) Then 
     strFileName = Application.GetSaveAsFilename(_ 
      InitialFileName:=ActiveWorkbook.Path & "\" & rngRange.Worksheet.Name & ".csv", _ 
      FileFilter:="CSV (*.csv), *.csv", _ 
      Title:="Export CSV") 
    End If 

    Set objStream = CreateObject("ADODB.Stream") 
    objStream.Type = 2 
    objStream.Charset = strCharset 
    objStream.Open 

    For Each rngRow In rngRange.Rows 
     objStream.WriteText CsvFormatRow(rngRow) 
    Next rngRow 

    objStream.SaveToFile strFileName, 2 
    objStream.Close 

End Sub 

Sub CsvExportSelection() 
    CsvExportRange ActiveWindow.Selection 
End Sub 

Sub CsvExportSheet(varSheetIndex As Variant) 

    Dim wksSheet As Worksheet 
    Set wksSheet = Sheets(varSheetIndex) 

    CsvExportRange wksSheet.UsedRange 

End Sub