Excel VBA – 导出为UTF-8

我创build的macros工作正常，我只需要解决储蓄业务。 现在我得到一个popup窗口询问我在哪里保存它，但我希望它保存在一个默认的名称和pathAND编码UTF-8。

这是我使用的完整代码，底部保存我设想的文件。

Public Sub ExportToTextFile(FName As String, Sep As String, SelectionOnly As Boolean, AppendData As Boolean) Dim WholeLine As String Dim fnum As Integer Dim RowNdx As Long Dim ColNdx As Integer Dim StartRow As Long Dim EndRow As Long Dim StartCol As Integer Dim EndCol As Integer Dim CellValue As String Dim teller As Integer 'Teller aangemaakt ter controle voor het aantal velden 'teller = 1 Application.ScreenUpdating = False On Error GoTo EndMacro: fnum = FreeFile If SelectionOnly = True Then With Selection StartRow = .Cells(1).Row StartCol = .Cells(26).Column EndRow = .Cells(.Cells.Count).Row EndCol = .Cells(.Cells.Count).Column End With Else With ActiveSheet.UsedRange StartRow = .Cells(1).Row StartCol = .Cells(26).Column EndRow = .Cells(.Cells.Count).Row EndCol = .Cells(26).Column End With End If If AppendData = True Then Open FName For Append Access Write As #fnum Else Open FName For Output Access Write As #fnum End If For RowNdx = StartRow To EndRow WholeLine = "" For ColNdx = StartCol To EndCol If Cells(RowNdx, ColNdx).Value = "" Then CellValue = "" Else CellValue = Cells(RowNdx, ColNdx).Value End If WholeLine = WholeLine & CellValue & Sep Next ColNdx WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep)) Print #fnum, WholeLine, "" 'Print #fnum, teller, WholeLine, "" 'teller = teller + 1 Next RowNdx EndMacro: On Error GoTo 0 Application.ScreenUpdating = True Close #fnum End Sub Sub Dump4Mini() Dim FileName As Variant Dim Sep As String FileName = Application.GetSaveAsFilename(InitialFileName:=Blank, filefilter:="Text (*.txt),*.txt") If FileName = False Then Exit Sub End If Sep = "|" If Sep = vbNullString Then Exit Sub End If Debug.Print "FileName: " & FileName, "Separator: " & Sep ExportToTextFile FName:=CStr(FileName), Sep:=CStr(Sep), SelectionOnly:=False, AppendData:=False End Sub 

Answer 1

这是我用来传递http网页，它返回一个正确的编码的string

 Public Function UTF8(ByVal http As Object) As String Dim BinaryStream Const adTypeBinary = 1 Const adTypeText = 2 Const adModeReadWrite = 3 Set BinaryStream = CreateObject("ADODB.Stream") With BinaryStream .Type = adTypeBinary .Open .Write http.responseBody 'Change stream type To binary .Position = 0 .Type = adTypeText 'Specify charset For the source text '.Charset = "iso-8859-1" 'unicode .Charset = "utf-8" 'or utf-16 'Open the stream And get binary data from the object UTF8 = .ReadText End With End Function 

在这种情况下， http是Set http = CreateObject("Microsoft.XMLHTTP")但我相信你可以适应你的需求。

这与string一起工作，并直接输出文本文件

 Option Explicit Sub test() Dim filePath As String Dim fileName As String Dim charToEncode As String Dim success As Boolean filePath = "C:\Users\ooo\Desktop\" fileName = "test.txt" charToEncode = "Télécom" success = ConvertToUTF8thenSaveToFile(charToEncode, filePath, fileName) If success Then MsgBox ("Success") Else MsgBox ("Failed") End If End Sub Function ConvertToUTF8thenSaveToFile(ByVal charToEncode As String, _ ByVal filePath As String, ByVal fileName As String) As Boolean Dim fsT As Object Dim adodbStream As Object On Error GoTo Err: Set adodbStream = CreateObject("ADODB.Stream") With adodbStream .Type = 2 'Stream type .Charset = "utf-8" 'or utf-16 etc .Open .WriteText charToEncode .SaveToFile filePath & fileName, 2 'Save binary data To disk End With ConvertToUTF8thenSaveToFile = True On Error GoTo 0 Exit Function Err: ConvertToUTF8thenSaveToFile = False End Function 

更新：下面的代码已被更新，以创build一个范围的分隔string，编码string并保存到文件。

 Option Explicit Sub test() Dim filePath As String Dim fileName As String Dim charToEncode As String Dim encodingType As String Dim success As Boolean Dim rngArray() As Variant filePath = "C:\Users\ooo\Desktop\" fileName = "test.csv" rngArray = Sheet1.Range("A1:E10000").Value encodingType = "utf-8" charToEncode = DelimitRange(rngArray) success = ConvertToUTF8thenSaveToFile(charToEncode, filePath, fileName, encodingType) If success Then MsgBox ("Success") Else MsgBox ("Failed") End If End Sub Function ConvertToUTF8thenSaveToFile(ByVal charToEncode As String, _ ByVal filePath As String, ByVal fileName As String, ByVal encodingCharSet As String) As Boolean Dim fsT As Object Dim adodbStream As Object On Error GoTo Err: Set adodbStream = CreateObject("ADODB.Stream") With adodbStream .Type = 2 'Stream type .Charset = encodingCharSet 'or utf-16 etc .Open .WriteText charToEncode .SaveToFile filePath & fileName, 2 'Save binary data To disk End With ConvertToUTF8thenSaveToFile = True On Error GoTo 0 Exit Function Err: ConvertToUTF8thenSaveToFile = False End Function Function DelimitRange(ByVal XLArray As Variant) As String Const delimiter As String = "," Const lineFeed As String = vbCrLf Const removeExisitingDelimiter As Boolean = True Dim rowCount As Long Dim colCount As Long Dim tempString As String For rowCount = LBound(XLArray, 1) To UBound(XLArray, 1) For colCount = LBound(XLArray, 2) To UBound(XLArray, 2) If removeExisitingDelimiter Then tempString = tempString & Replace(XLArray(rowCount, colCount), delimiter, vbNullString) Else tempString = tempString & XLArray(rowCount, colCount) End If 'Don't add delimiter to column end If colCount < UBound(XLArray, 2) Then tempString = tempString & delimiter Next colCount 'Add linefeed If rowCount < UBound(XLArray, 1) Then tempString = tempString & lineFeed Next rowCount DelimitRange = tempString End Function