excel to xml save output in UTF-8

Question

Я пытаюсь создать макрос VBA, который преобразует лист excel в xml. Проблема в том, что данные excel содержат специальные символы. Я искал здесь, на форуме, какую-то помощь, и думаю, что решение ADOB.stream - это решение, которое может решить мою проблему. Но я не могу интегрировать это в свой код VBA. До сих пор я получил следующий код:

Public Sub ExcelToXML() 

On Error GoTo ErrorHandler 


Dim colIndex As Integer 
Dim rwIndex As Integer 
Dim asCols() As String 
Dim oWorkSheet As Worksheet 
Dim sName As String 
Dim lCols As Long, lRows As Long 
Dim iFileNum As Integer 


Set oWorkSheet = ThisWorkbook.Worksheets(1) 
sName = oWorkSheet.Name 
lCols = oWorkSheet.Columns.Count 
lRows = oWorkSheet.Rows.Count 

Set objstream = CreateObject("ADODB.Stream") 

objstream.Charset = "utf-8" 
objstream.Mode = 3 
objstream.Type = 2 
objstream.Open 

ReDim asCols(lCols) As String 

iFileNum = FreeFile 
Open "C:\temp\test5.xml" For Output As #iFileNum 

Worksheets("Sheet1").Range("A1:Z1").Replace _ 
What:=" ", Replacement:="_", _ 
SearchOrder:=xlByColumns, MatchCase:=True 

For i = 0 To lCols - 1 
'Assumes no blank column names 
If Trim(Cells(1, i + 1).Value) = "" Then Exit For 
asCols(i) = Cells(1, i + 1).Value 
Next i 

If i = 0 Then GoTo ErrorHandler 
lCols = i 

objstream.WriteText "<?xml version=""1.0"" encoding=""UTF-8""?>" 
objstream.WriteText "<" & "DATA" & ">" 
For i = 2 To lRows 
If Trim(Cells(i, 1).Value) = "" Then Exit For 
obj.stream.WriteText "<" & "PROC" & ">" 

For j = 1 To lCols 

    If Trim(Cells(i, j).Value) <> "" Then 
     objstream.WriteText " <" & asCols(j - 1) & ">" 
     objstream.WriteText Trim(Cells(i, j).Value) 
     objstream.WriteText "</" & asCols(j - 1) & ">" 
     DoEvents 'OPTIONAL 
    End If 
Next j 
objstream.WriteText " </" & "PROC" & ">" 
Next i 

objstream.WriteText "</" & "DATA" & ">" 

ErrorHandler: 
If iFileNum > 0 Then Close #iFileNum 

objstream.SaveToFile "C:\temp\test6.xml", 2 
objstream.Close 
Set AdoS = Nothing 


Exit Sub 

End Sub 

Выходной файл, к сожалению, пуст. Заранее благодарю вас за любую помощь, которую вы можете мне дать!

Answer 1

Не пытайтесь создавать XML-файлы вручную - есть уже очень надежные инструменты, которые вы можете использовать для этого. В этом случае я бы использовал объекты MSXML2. Они поддерживают UTF8 изначально, поэтому вам не нужно работать с кодировкой символов или файл IO вообще. Структура кода в основном так же, как писать текст непосредственно, но вы добавляете узлы вместо того, чтобы писать <node>, value, </node> и пытается сохранить структуру прямо:

'Add a reference to Microsoft XML, v6.0 
Sub ExcelToXML() 
    Worksheets("Sheet1").Range("A1:Z1").Replace _ 
     What:=" ", Replacement:="_", _ 
     SearchOrder:=xlByColumns, MatchCase:=True 

    With New DOMDocument 
     'Add XML header 
     .appendChild .createProcessingInstruction("xml", "version=""1.0"" encoding=""utf-8""") 
     'Add the root node 
     Dim root As IXMLDOMElement 
     Set root = .createElement("DATA") 
     .appendChild root 
     'Work with an array, not the actual worksheet. 
     Dim data() As Variant 
     data = Worksheets("Sheet1").UsedRange.Value 
     For r = LBound(data, 1) + 1 To UBound(data, 1) 
      If Trim$(data(r, 1)) = vbNullString Then Exit For 
      Dim proc As IXMLDOMElement 
      'Create a PROC node for the row. 
      Set proc = root.appendChild(.createElement("PROC")) 
      For c = LBound(data, 2) To UBound(data, 2) 
       If Trim$(data(r, c)) <> vbNullString Then 
        'Add a child for each column. 
        Dim child As IXMLDOMElement 
        Set child = proc.appendChild(.createElement(data(1, c))) 
        child.appendChild .createTextNode(Trim$(data(r, c))) 
       End If 
      Next 
     Next 
     'Write the file. 
     .Save "C:\temp\test6.xml" 
    End With 
End Sub