Excel VBA - 导出为UTF-8

Question

Excel VBA - 导出为UTF-8

3

我创建的宏可以正常工作，我只需要解决保存问题。现在会弹出一个窗口询问我要保存到哪里，但是我想将其保存在默认名称和路径下并进行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

- CustomX

据我所知，使用ExportToTextFile时无法确定编码。您将不得不手动构建带有分隔符的字符串，并通过诸如ADODB.Stream之类的对象以所需的编码保存到文件中。或者使用OpenOffice :) - user857521

唉 :( 我试着创建一个简单的版本，将Z列复制到一个新工作表中，使用粘贴特殊值，将文档保存为 .txt。但它搞乱了我的最终文档和我的Excel文档。 - CustomX

1个回答

网页内容由stack overflow 提供, 点击上面的

可以查看英文原文，
原文链接

- user857521 · Accepted Answer

这是我用来传递http网页的方法，它会返回一个正确编码的字符串。

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") 的东西，但我相信您可以根据自己的需求进行调整。

此方法适用于字符串，并直接输出文本文件。

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

更新：下面的代码已经更新，可以从一个范围创建分隔符字符串，对该字符串进行编码并保存到文件中。

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