CODEWITHSUNDEEP
excelutf-8vba
Herbert
Herbert

Reputation: 15

excel to xml save output in UTF-8

I trying to create a VBA macro that converts an excel sheet to xml. The problem is that the excel data contains special characters. I searched here in the forum for some help and guess the ADOB.stream-solution is the one that could solve my problem. But I'm not able to integrate this into my VBA code. So far I got the following code:

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

The output file is unfortunately empty. Thank you in advance for any assistance you can give me!

Upvotes: 1

Views: 1816

Answers (1)

Comintern
Comintern

Reputation: 22185

Don't try to create XML files manually - there are already very robust tools that you can use to do it for you. In this case, I'd use the MSXML2 objects. These support UTF8 natively, so you don't need to work about the character encoding or the file IO at all. The code structure is basically the same as writing text directly, but you add nodes instead of writing <node>, value, </node> and trying to keep the structure straight:

 '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

Upvotes: 1

Related Questions