XML To UDT

As stated on Wikipedia, on the entry XML (or Extensible Markup Language) is a markup language that defines a set of rules for encoding documents in a format that is both human-readable and machine-readable. The W3C‘s XML 1.0 Specification and several other related specifications—all of them free open standards—define XML.

And XML schemas are everywhere in the Net. They describe a vast whole of items. From here on, we encounter the problem when developing software that complies with the specification described in the XML, so that it can interoperate data (I/O operations) with objects or XML files.

But most of the time, we only have a bare XML file, no schema.

It would be nice a procedure that can read an XML file (or even the schema on its own) an get it converted to user defined types. For sure we’ll need to code some functions that operate with the UDT, but getting the description into an UDT schema without minimal coding would be really neat.

For this to be achieved, first we’ll need to manage an object that can deal the schema. For this task, the easiest way is doing so with MSXML (v 2.0 or above) library (Tools > References > Microsoft XML vX.x).

Procedure fXML_Node_Parse showing next, will iterate through the nodes, declaring the required UDT. At the end of the code there are some other functions to detect the type of variable we are dealing with (it can fail beeing the data ambiguous, but it will get big part of the job done).

Paste this code inside a module, and call sXML_Parse by any means:

Option Explicit

Private oTmpXMLDoc As MSXML2.DOMDocument
Private iFileOut As Integer
Private aSchema() As String
Private aUDT() As String

'---------------------------
Private Type tVariable
    Name As String
    TypeVar As Long
End Type
Private Type tUDT
    Header As String
    Variable() As tVariable
End Type
'---------------------------

Private Sub sXML_UDT_Clash()
    Dim lgUDT As Long
    Dim aVar() As String

    For lgUDT = LBound(aUDT) To UBound(aUDT)
        aVar() = VBA.Split(aUDT(lgUDT), vbNewLine)
    Next lgUDT
End Sub

Private Sub sXML_Parse()
    Dim strXML As String
    Dim strFullPathFile_XML As String
    Dim lgRetVal As Long
    Dim lgUDT As Long
    Dim lgUDT_Child As Long

    Dim oXMLDoc As MSXML2.DOMDocument
    Dim oXMLNode As MSXML2.IXMLDOMNode
    Dim oXMLElement As MSXML2.IXMLDOMElement
    Dim oXMLChildElement As MSXML2.IXMLDOMElement
    Dim oXMLSubChildElement As MSXML2.IXMLDOMElement

    'On Error GoTo ErrControl

    If oTmpXMLDoc Is Nothing Then
        Set oTmpXMLDoc = New MSXML2.DOMDocument
    End If

    ' Load XML
    strFullPathFile_XML = fSelectFile(VBA.Environ$("UserProfile") & "\Documents\", "*.xml")

    strXML = fFile_Load(strFullPathFile_XML)
    If strXML = vbNullString Then
        Exit Sub
    Else
        If Not oTmpXMLDoc.LoadXML(strXML) Then   'strXML is the string with XML'
            Err.Raise oTmpXMLDoc.parseError.ErrorCode, , oTmpXMLDoc.parseError.reason
        End If
        strXML = vbNullString
    End If

    If oTmpXMLDoc.ChildNodes.Length > 0 Then
        ' Sample on how to operate with a particular node:
        'Dim oXMLChildNode As MSXML2.IXMLDOMNode
        'Debug.Print oXMLNode.SelectSingleNode(oXMLChildNode.nodeName).Text
        'Debug.Print oXMLNode.SelectSingleNode("Y").Text

        '---------------------
        ' Parse XML
        '---------------------
        lgUDT = -1 'Initialize global counter
        For Each oXMLNode In oTmpXMLDoc.ChildNodes
            ' Parse XML node/child
            With oXMLNode
                If .ChildNodes.Length > 0 Then 'Avoid XML declaration (opening line)
                    lgUDT = lgUDT + 1: ReDim Preserve aSchema(lgUDT)
                    ReDim Preserve aUDT(lgUDT)
                    aSchema(lgUDT) = "Type t" & .BaseName & vbNewLine
                    aUDT(lgUDT) = .BaseName
                    For Each oXMLElement In .ChildNodes
                        aSchema(lgUDT) = aSchema(lgUDT) & vbTab & oXMLElement.BaseName & " As t" & oXMLElement.BaseName & vbNewLine
                        lgUDT_Child = UBound(aSchema) + 1
                        ReDim Preserve aSchema(0 To lgUDT_Child)
                        ReDim Preserve aUDT(0 To lgUDT_Child)
                        aSchema(lgUDT_Child) = "Type t" & oXMLElement.BaseName & vbNewLine
                        aUDT(lgUDT_Child) = oXMLElement.BaseName

                        Call fXML_Node_Parse(oXMLElement, lgUDT_Child)
                        aSchema(lgUDT_Child) = aSchema(lgUDT_Child) & "End Type"
                    Next oXMLElement
                    aSchema(lgUDT) = aSchema(lgUDT) & "End Type"
                End If
            End With
        Next oXMLNode

        '---------------------
        ' Sort blocks in order to not declare UDT after used
        '---------------------
        Dim aVar() As String
        Dim lgVar As Long
        Dim lgCheck As Long
        Dim bAdvanced As Boolean
        Dim bLoop As Boolean
        Dim strTmpUDT As String
        Dim strUDT As String
        Do
            For lgUDT = LBound(aSchema) To UBound(aSchema)
                Erase aVar()
                aVar() = VBA.Split(aSchema(lgUDT), vbNewLine)
                For lgVar = (LBound(aVar) + 1) To (UBound(aVar) - 1)
                    aVar(lgVar) = VBA.Mid$(aVar(lgVar), 2, VBA.InStr(1, aVar(lgVar), " As ") - 2)
                    aVar(lgVar) = VBA.Replace$(aVar(lgVar), "()", "")
                Next lgVar

                bAdvanced = False
                For lgVar = (LBound(aVar) + 1) To (UBound(aVar) - 1)
                    For lgCheck = lgUDT - 1 To LBound(aSchema) Step -1
                        If VBA.UCase$(aVar(lgVar)) Like VBA.UCase$(aUDT(lgCheck)) Then
                            bAdvanced = True: Exit For
                        End If
                    Next lgCheck

                    If bAdvanced Then ' Go sort element
                        ' Move clash to over UBound position
                        ReDim Preserve aSchema(LBound(aSchema) To UBound(aSchema) + 1)
                        aSchema(UBound(aSchema)) = aSchema(lgCheck)
                        aSchema(lgCheck) = vbNullString
                        ReDim Preserve aUDT(LBound(aUDT) To UBound(aUDT) + 1)
                        aUDT(UBound(aUDT)) = aUDT(lgCheck)
                        aUDT(lgCheck) = vbNullString

                        ' Move elements from clash to UBound one step back
                        For lgCheck = lgCheck To (UBound(aSchema) - 1)
                            aSchema(lgCheck) = aSchema(lgCheck + 1)
                            aUDT(lgCheck) = aUDT(lgCheck + 1)
                        Next lgCheck
                        ReDim Preserve aSchema(LBound(aSchema) To UBound(aSchema) - 1)
                        ReDim Preserve aUDT(LBound(aUDT) To UBound(aUDT) - 1)

                        Exit For
                    End If
                Next lgVar
                If bAdvanced Then lgUDT = (lgUDT - 1): Exit For
            Next lgUDT

            If lgUDT > UBound(aSchema) Then
                bLoop = bAdvanced
            Else
                bLoop = True
            End If
        Loop While bLoop

        '---------------------
        ' Flip UDT
        '---------------------
        For lgUDT = LBound(aSchema) To (UBound(aSchema) \ 2)
            strTmpUDT = aSchema(lgUDT)
            aSchema(lgUDT) = aSchema(UBound(aSchema) + LBound(aSchema) - lgUDT)
            aSchema(UBound(aSchema) + LBound(aSchema) - lgUDT) = strTmpUDT
        Next lgUDT

        For lgUDT = LBound(aSchema) To UBound(aSchema)
            Debug.Print aSchema(lgUDT)
        Next lgUDT
    End If

ExitProc:
    'Erase aSchema()

    On Error GoTo 0
    Exit Sub
ErrControl:
    lgRetVal = VBA.MsgBox("Couldn't load XML file [" & strFullPathFile_XML & "]", vbCritical, "W A R N I N G")
    GoTo ExitProc
End Sub

Private Function fXML_Node_Parse(ByVal oXMLElement As MSXML2.IXMLDOMElement, _
                                 ByVal lgUDT As Long) As Boolean
' Parse XML oXMLElement

    'On Error GoTo ErrControl

    Dim oXMLChildElement As MSXML2.IXMLDOMElement
    Dim oXMLChildNode As MSXML2.IXMLDOMNode
    Dim lgUDT_Child As Long
    Dim strDeclaration As String
    Dim lgFound As Long
    Dim bMultiple As Boolean
    Dim lgRetVal As Long

    With oXMLElement
        If .ChildNodes.Length > 0 Then
            Set oXMLChildNode = .ChildNodes.NextNode
            For Each oXMLChildElement In .ChildNodes
                With oXMLChildElement
                    If .ChildNodes.Length > 0 Then
                        Set oXMLChildNode = .ChildNodes.NextNode
                        If .ChildNodes.Length = 1 And oXMLChildNode.nodeTypeString = "text" Then
                                               'also: oXMLChildNode.childnodes.length = 0
                            Call fXML_Parse_Text(oXMLChildNode, lgUDT)

                        Else
                            'Check if recursive
                            lgFound = LBound(aSchema) - 1
                            bMultiple = fXML_Element_Found(.BaseName, lgUDT, lgFound)

                            If Not bMultiple Then
                                aSchema(lgUDT) = aSchema(lgUDT) & vbTab & .BaseName & " As t" & .BaseName & vbNewLine

                                ' Parse XML oXMLChildElement
                                lgUDT_Child = UBound(aSchema) + 1
                                ReDim Preserve aSchema(0 To lgUDT_Child)
                                ReDim Preserve aUDT(0 To lgUDT_Child)
                                aSchema(lgUDT_Child) = "Type t" & .BaseName & vbNewLine
                                aUDT(lgUDT_Child) = .BaseName
                                Call fXML_Node_Parse(oXMLChildElement, lgUDT_Child)
                                aSchema(lgUDT_Child) = aSchema(lgUDT_Child) & "End Type"

                            Else
                                If lgFound = lgUDT Then
                                    aSchema(lgUDT) = VBA.Replace(aSchema(lgUDT), _
                                                                 vbTab & .BaseName & " As t" & .BaseName & vbNewLine, _
                                                                 vbTab & .BaseName & "() As t" & .BaseName & vbNewLine)
                                Else
                                    aSchema(lgUDT) = aSchema(lgUDT) & vbTab & .BaseName & " As t" & .BaseName & vbNewLine
                                End If

                            End If
                        End If
                    End If
                End With
            Next oXMLChildElement
        End If
    End With

    fXML_Node_Parse = True

ExitProc:
    On Error GoTo 0
    Exit Function

ErrControl:
    lgRetVal = VBA.MsgBox("Couldn't load XML [" & oXMLElement.BaseName & "]", _
                          vbCritical, _
                          "W A R N I N G")
    GoTo ExitProc
End Function

Private Function fXML_Parse_Text(ByVal oXMLChildNode As MSXML2.IXMLDOMNode, _
                                 ByVal lgUDT As Long)
    Dim strDeclaration As String
    Dim lgFound As Long
    Dim bMultiple As Boolean
    Dim lgRetVal As Long

    With oXMLChildNode
        strDeclaration = VarDeclaration(.Text)
        'Check if recursive
        lgFound = LBound(aSchema) - 1
If .BaseName  "" Then Stop
        bMultiple = fXML_Element_Found(.ParentNode.BaseName, lgUDT, lgFound)
'Stop
        If Not bMultiple Then
            aSchema(lgUDT) = aSchema(lgUDT) & vbTab & .ParentNode.BaseName & " As " & strDeclaration & vbNewLine

        Else
'Stop
            If lgFound = lgUDT Then
                aSchema(lgUDT) = VBA.Replace(aSchema(lgUDT), _
                                             vbTab & .ParentNode.BaseName & " As " & strDeclaration & vbNewLine, _
                                             vbTab & .ParentNode.BaseName & "() As " & strDeclaration & vbNewLine)
            Else
                aSchema(lgUDT) = aSchema(lgUDT) & vbTab & .ParentNode.BaseName & " As " & strDeclaration & vbNewLine
            End If

        End If
    End With
End Function

Private Function fXML_Element_Found(ByVal strBaseName As String, _
                                    ByRef lgSelf As Long, _
                                    ByRef lgFound As Long) As Boolean
    fXML_Element_Found = False

    Dim lgUDT As Long
    Dim aVar() As String

    If Not (Not aUDT) Then
        aVar() = VBA.Split(aSchema(lgSelf), vbNewLine)
        For lgUDT = LBound(aVar) To UBound(aVar)
            aVar(lgUDT) = VBA.Trim$(aVar(lgUDT))
            aVar(lgUDT) = VBA.Replace$(aVar(lgUDT), vbTab, "")
            If VBA.UCase$(aVar(lgUDT)) Like VBA.UCase$(strBaseName) & " *" Then
                lgFound = lgSelf
                fXML_Element_Found = True
                Erase aVar()
                Exit Function
            End If
        Next lgUDT
    End If

    ' Search in the other declarations
    For lgUDT = (UBound(aSchema) - 1) To LBound(aSchema) Step -1
        If Not (Not aUDT) Then
            If aUDT(lgUDT) = strBaseName Then
                lgFound = lgUDT
                fXML_Element_Found = True
                Exit For
            End If
        End If
    Next lgUDT
End Function

Private Function fSelectPath() As String
    Dim strPathBase As String

    'strPathBase = VBA.Environ$("UserProfile") & "\Documents\"
    strPathBase = ActiveWorkbook.Path & "\"
    fSelectPath = strPathBase
End Function

'Private Function FolderSelection() As String
'' Shows the folder picker dialog in order the user to select folder
'    Dim lgRetVal As Long
'
'    'Show the folder picker dialog.
'    With Application.FileDialog(msoFileDialogFolderPicker)
'        .Title = "Select folder"
'        .Show
'        If .SelectedItems.Count = 0 Then
'            lgRetVal = MsgBox("You haven't selected a folder!", _
'                              vbExclamation, "Canceled")
'            Exit Function
'        Else
'            FolderSelection = .SelectedItems(1) & "\"
'        End If
'    End With
'End Function

Private Function fSelectFile(Optional ByRef strPathBase As String = vbNullString, _
                             Optional ByRef strExtension As String = "*.xml", _
                             Optional ByRef bNewFile As Boolean = False) As String
' Shows the file picker dialog in order the user to select folder

    Dim lgRetVal As Long

    'Show the folder picker dialog.
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Select file"
        .Show
        .AllowMultiSelect = False
        '.Filters.Add Description:="XML files", Extensions:="*.xml"
        '.Filters.Add Description:="All files", Extensions:="*.*"

        If .SelectedItems.Count = 0 Then
            lgRetVal = MsgBox("You haven't selected a file!", _
                              vbExclamation, "Canceled")
            Exit Function
        Else
            fSelectFile = .SelectedItems(1)
        End If
    End With
End Function

Private Function fFile_Load(ByRef strFullPathFile As String) As String
    Dim strFile As String
    Dim strLine As String
    Dim iFileIn As Integer
    Dim lgItem As Long

    iFileIn = VBA.FreeFile
    Open strFullPathFile For Input Shared As #iFileIn
    Do Until EOF(iFileIn)
        Line Input #iFileIn, strLine
        strFile = strFile & strLine
    Loop
    Close #iFileIn

    fFile_Load = strFile
End Function

Private Function IsDouble(ByVal value As Variant) As Boolean
    IsDouble = (IsNumeric(value) And Not IsLong(value))
End Function

Private Function IsLong(ByVal value As Variant) As Boolean
    IsLong = (VarType(value) = vbLong)
End Function

Private Function IsString(ByVal value As Variant) As Boolean
    IsString = (VarType(value) = vbString)
End Function

'Private Function IsInteger(ByVal value As Variant) As Boolean
'    IsInteger = (VarType(value) = vbInteger)
'End Function

Private Function VarDeclaration(ByVal strVarCheck As String) As String
    If IsDouble(strVarCheck) Then
        VarDeclaration = "Double"
    ElseIf IsLong(strVarCheck) Then
        VarDeclaration = "Long"
    ElseIf IsDate(strVarCheck) Then
        VarDeclaration = "Date"
    ElseIf IsString(strVarCheck) Then
        VarDeclaration = "String"
    End If
End Function

UDT declarations should be shown in the “Inmediate window”

From this point, you can code some procedures to write/read an XML structure linked to the UDT schema. I will not show here how to get these functionalities, but I should point that most of the code to get them can be recycled from the sXML_Parse function. Do your homework! 😉

Finally, we’ll also consider of interest to get some functions coded to deal with arrays of complex data (UDT variables), as VBA doesn’t have any specific, out of Library, Directory and Collection objects -which I avoid as they are far from optimized when dealing with big arrays-. We can imitate the JavaScript sentences, so it’ll be easier in the future to do a port to other programming languages.

‘ Array UDT functions ‘https://www.w3schools.com/js/js_array_methods.asp

Here are exposed the templates for building these functions

Option Explicit

'!!!!!!!!!!!!!!!!!!
Private Enum estrUDTName
    Value1
End Enum
Private Type strVarType
    Test As Boolean
End Type
Private Type tstrUDTName
    strVarType As strVarType
End Type
Public Const g_Base As Long = 0
'!!!!!!!!!!!!!!!!!!

Private Function fstrUDTName_Slice(ByRef astrUDTName() As tstrUDTName, _
                                   Optional ByVal lgFrom As Long = 0, _
                                   Optional ByVal lgTo As Long = -1) As tstrUDTName()
' _Slice/Get : Return the elements in array, from item lgFrom to item lgTo
    Dim aSlice() As tstrUDTName
    Dim lgItem As Long
    Dim lgSlice As Long

    If Not (Not astrUDTName) Then
        If lgFrom >= lgTo Then
            If lgFrom <= LBound(astrUDTName) Then lgFrom = LBound(astrUDTName)
            If lgTo <= UBound(astrUDTName) Then lgTo = UBound(astrUDTName)
        End If

        lgSlice = g_Base - 1
        ReDim aSlice(g_Base To lgTo - lgFrom + 1 - g_Base)
        For lgItem = lgFrom To lgTo
            lgSlice = lgSlice + 1
            aSlice(lgSlice) = astrUDTName(lgItem)
        Next lgItem

        fstrUDTName_Slice = aSlice()
        Erase aSlice()
    End If
End Function

Private Function fstrUDTName_Delete(ByRef astrUDTName() As tstrUDTName, _
                                    Optional ByVal lgStart As Long = 0, _
                                    Optional ByVal lgItems As Long = 1) As Boolean
' _Delete : erase content (leave blank) items in the middle
    Dim aBlankstrUDTName As tstrUDTName
    Dim lgItem As Long

    If Not (Not astrUDTName) Then
        If lgStart  UBound(astrUDTName) - lgStart + 1 Then lgItems = UBound(astrUDTName) - lgStart + 1

        For lgItem = lgStart To UBound(astrUDTName)
            astrUDTName(lgItem) = aBlankstrUDTName
            If lgItem > (lgStart + lgItems + 1 - g_Base) Then Exit For
        Next lgItem

        fstrUDTName_Delete = True
    End If
End Function

Private Function fstrUDTName_Splice(ByRef astrUDTName() As tstrUDTName, _
                                    ByRef AddstrUDTName() As tstrUDTName, _
                                    Optional ByVal lgStart As Long = 0, _
                                    Optional ByVal lgItems As Long = 1) As tstrUDTName()
'  The first parameter defines the elements that should be added (spliced).
'  The second parameter defines the position where new elements should be added (spliced in).
'  The third parameter defines how many elements should be removed.
'  The splice() method returns an array with the deleted items:

    Dim aSplice() As tstrUDTName
    Dim aTmpSplice() As tstrUDTName
    Dim lgItem As Long
    Dim lgSplice As Long
    Dim lgAddings As Long

    If Not (Not astrUDTName) Then
        If lgStart  UBound(astrUDTName) - lgStart + 1 Then lgItems = UBound(astrUDTName) - lgStart + 1

        If Not (Not AddstrUDTName) Then
Stop
            lgAddings = UBound(AddstrUDTName) - LBound(AddstrUDTName) + 1
        End If

        If lgItems = (UBound(astrUDTName) - LBound(astrUDTName) + 1) Then
            aSplice() = astrUDTName()
            Erase astrUDTName()

        Else
            lgSplice = g_Base - 1
            ReDim aSplice(g_Base To lgItems + g_Base - 1 + lgAddings)

            aTmpSplice() = aSplice()
            ' Get starting items (and allocated space for new items)
            ReDim Preserve aTmpSplice(g_Base To UBound(astrUDTName) - lgItems)

            ' Get removed items aSplice
            For lgItem = lgStart To UBound(astrUDTName)
                lgSplice = lgSplice + 1
                aSplice(lgSplice) = astrUDTName(lgItem)
                If lgSplice > (lgItems + 1 - g_Base) Then Exit For
            Next lgItem

            lgSplice = lgStart - 1
 '!!!!!!!!!!!!!!!!!!!!
            ' Add items
            'For lgItem = lgStart To lgStart + lgAddings - 1
            '    lgSplice = lgSplice + 1
            '    aSplice(lgSplice) = astrUDTName(lgItem)
            '    If lgSplice > (lgStart + lgAddings - 1) Then Exit For
            'Next lgItem
 '!!!!!!!!!!!!!!!!!!!!

            ' Get final items back
            For lgItem = (lgStart + lgItems) To UBound(astrUDTName)
                lgSplice = lgSplice + 1
                aTmpSplice(lgSplice) = astrUDTName(lgItem)
                If lgSplice > (lgItems + 1 - g_Base) Then Exit For
                'If lgSplice > ubound(aTmpSplice) Then Exit For
            Next lgItem
            Erase astrUDTName() ' needed???
            astrUDTName() = aTmpSplice()
        End If

        fstrUDTName_Splice = aSplice()
        Erase aSplice()
        Erase aTmpSplice()
    End If
End Function

Private Function fstrUDTName_Push(ByRef astrUDTName() As tstrUDTName, _
                                  ByRef AddstrUDTName As tstrUDTName) As Long
' Push : Add items to the end of an array, returns the new array length:

    If Not (Not astrUDTName) Then
        ReDim Preserve astrUDTName(LBound(astrUDTName) To UBound(astrUDTName) + 1)
    Else
        ReDim Preserve astrUDTName(LBound(astrUDTName) To UBound(astrUDTName) + 1)
    End If
    astrUDTName(UBound(astrUDTName)) = AddstrUDTName

    fstrUDTName_Push = UBound(astrUDTName) + LBound(astrUDTName) + 1
End Function

Private Function fstrUDTName_Pop(ByRef astrUDTName() As tstrUDTName) As tstrUDTName
' _Pop : Remove an item from the end of an array, and returns the value that was "popped out":

    If Not (Not astrUDTName) Then
        fstrUDTName_Pop = astrUDTName(UBound(astrUDTName))
        If LBound(astrUDTName) = UBound(astrUDTName) Then
            Erase astrUDTName()
        Else
            ReDim Preserve astrUDTName(LBound(astrUDTName) To UBound(astrUDTName) - 1)
        End If
    End If
End Function

Private Function fstrUDTName_Unshift(ByRef astrUDTName() As tstrUDTName, _
                                     ByRef AddstrUDTName As tstrUDTName) As Long
' _Unshift() : Add items to the beginning of an array, returns the new array length

    Dim aTmpstrUDTName() As tstrUDTName

    If Not (Not astrUDTName) Then
        ReDim Preserve astrUDTName(LBound(astrUDTName) To UBound(astrUDTName) + 1)
    Else
        ReDim Preserve aTmpstrUDTName(LBound(astrUDTName) To UBound(astrUDTName) + 1)
        aTmpstrUDTName(LBound(astrUDTName)) = AddstrUDTName
        For lgItem = LBound(astrUDTName) To UBound(astrUDTName)
            aTmpstrUDTName(lgItem + 1) = astrUDTName(lgItem)
        Next lgItem
        astrUDTName() = aTmpstrUDTName()
        Erase aTmpstrUDTName()
    End If

    fstrUDTName_Unshift = UBound(astrUDTName) + LBound(astrUDTName) + 1
End Function

Private Function fstrUDTName_Shift(ByRef astrUDTName() As tstrUDTName) As tstrUDTName()
' _Shift() : Remove an item from the beginning of an array, returns the string that was "shifted out":

    Dim aTmpstrUDTName() As tstrUDTName

    If Not (Not astrUDTName) Then
        fstrUDTName_Shift = astrUDTName(LBound(astrUDTName))
        If LBound(astrUDTName) = UBound(astrUDTName) Then
            Erase astrUDTName()
        Else
            ReDim Preserve aTmpstrUDTName(LBound(astrUDTName) To UBound(astrUDTName) - 1)
            For lgItem = LBound(astrUDTName) + 1 To UBound(astrUDTName)
                aTmpstrUDTName(lgItem - 1) = astrUDTName(lgItem)
            Next lgItem
            astrUDTName() = aTmpstrUDTName()
            Erase aTmpstrUDTName()
        End If
    End If
End Function

Private Function fstrUDTName_ReDim(ByRef astrUDTName() As tstrUDTName) As tstrUDTName()
' _ReDim()

End Function

Private Function fstrUDTName_Concat(ByRef astrUDTName() As tstrUDTName) As tstrUDTName()
' _Concat

End Function

Private Function fstrUDTName_Swap(ByRef astrUDTName() As tstrUDTName) As tstrUDTName()
' _Swap

End Function

Private Function fstrUDTName_Flip(ByRef astrUDTName() As tstrUDTName) As tstrUDTName()
' _Flip

End Function

Private Function fstrUDTName_Flat(ByRef astrUDTName() As tstrUDTName) As tstrUDTName()
' _Flat()

End Function

Private Function fstrUDTName_FlatMap(ByRef astrUDTName() As tstrUDTName) As tstrUDTName()
' _FlatMap()

End Function

'---------------------------------------------------
' Array data functions:
'---------------------------------------------------
Private Function fstrUDTName_strVar_Get(ByRef astrUDTName() As tstrUDTName) As strVarType()
    Dim astrVar() As strVarType
    Dim lgItem As Long

    If Not (Not astrUDTName) Then
        ReDim astrVar(LBound(astrUDTName) To UBound(astrUDTName))
        For lgItem = LBound(astrUDTName) To UBound(astrUDTName)
            astrVar(lgItem) = astrUDTName(lgItem).strVarType
        Next lgItem
        fstrUDTName_strVar_Get = astrVar()
    End If
End Function

Private Function fstrUDTName_Min(ByRef astrUDTName() As tstrUDTName, _
                                 ByRef Key As estrUDTName) As Long
    Dim lgPos As Long

    Select Case Key
'        Case "X"
'            Call fDblMin(aValue, lgPos)
'            fstrUDTName_Min = lgPos
    End Select
End Function

Private Function fstrUDTName_Max(ByRef astrUDTName() As tstrUDTName, _
                                 ByRef Key As estrUDTName) As Long
    Dim lgPos As Long

    Select Case Key
'        Case "X"
'            Call fDblMax(aValue, lgPos)
'            fstrUDTName_Max = lgPos
    End Select
End Function

' _Join
'"Private Function f" & strUDTName & "_" & strVar & "_Join(ByRef a" & strUDTName & " As t" & strUDTName, _
                                                           ByVal Separator As String) As String"
' _Find: "Private Function f" & strUDTName & "_" & strVar & "_Find(ByVal Key As String) As Long()"
' _Sort: "Private Function f" & strUDTName & "_" & strVar & "_Sort(Optional ByVal lgFrom As Long = 0, Optional ByVal lgTo As Long = -1) As Boolean"

'Select Case strTypeVar
'    Case "String"
'    Case "Double"
'    Case "Single"
'    Case "Long"
'    Case "Integer"
'    Case "Boolean"
'    Case "Byte"
'End Select

There are some caveats:

  • Unicode characters, that not met UTF-8 codification (i.e. áéí…àè…).
  • Comments inside the XML, that is “” strings. They are not correctly handled by the MSXML library, so you should rip them off before parsing the XML string to the loader.

For the first one, I could be solved with the code in this post. For the second one, I managed to do it by code, following:

So for the non UTF-8 files, do something like this:

''' WinApi function that maps a UTF-16 (wide character) string to a new character string
#If VBA7 Then
Private Declare PtrSafe Function WideCharToMultiByte Lib "kernel32" ( _
    ByVal CodePage As Long, _
    ByVal dwFlags As Long, _
    ByVal lpWideCharStr As LongPtr, _
    ByVal cchWideChar As Long, _
    ByVal lpMultiByteStr As LongPtr, _
    ByVal cbMultiByte As Long, _
    ByVal lpDefaultChar As Long, _
    ByVal lpUsedDefaultChar As Long _
    ) As Long
#Else
Private Declare Function WideCharToMultiByte Lib "kernel32" ( _
    ByVal CodePage As Long, _
    ByVal dwFlags As Long, _
    ByVal lpWideCharStr As Long, _
    ByVal cchWideChar As Long, _
    ByVal lpMultiByteStr As Long, _
    ByVal cbMultiByte As Long, _
    ByVal lpDefaultChar As Long, _
    ByVal lpUsedDefaultChar As Long _
    ) As Long
#End If

''' Maps a character string to a UTF-16 (wide character) string
#If VBA7 Then
Private Declare PtrSafe Function MultiByteToWideChar Lib "kernel32" ( _
    ByVal CodePage As Long, _
    ByVal dwFlags As Long, _
    ByVal lpMultiByteStr As LongPtr, _
    ByVal cchMultiByte As Long, _
    ByVal lpWideCharStr As LongPtr, _
    ByVal cchWideChar As Long _
    ) As Long
#Else
Private Declare Function MultiByteToWideChar Lib "kernel32" ( _
    ByVal CodePage As Long, _
    ByVal dwFlags As Long, _
    ByVal lpMultiByteStr As Long, _
    ByVal cchMultiByte As Long, _
    ByVal lpWideCharStr As Long, _
    ByVal cchWideChar As Long _
    ) As Long
#End If

' CodePage constant for UTF-8
Private Const CP_UTF8 = 65001

Private Function fFile_Load_UTF8(Optional ByRef strFullPathFile As String = vbNullString) As String
' Will load any file not UTF-8 codification to UTF-8 codification inside VBA
    Dim strUnicode As String
    Dim strUTF8 As String
    Dim aUTF8() As Byte
    Dim iFileIn As Integer

    strFullPathFile = fSelectFile
    ReDim aUTF8(0 To VBA.FileLen(strFullPathFile) - 1)
    iFileIn = VBA.FreeFile
    Open strFullPathFile For Binary As #iFileIn
    Get #iFileIn, , aUTF8()
    Close #iFileIn
    fFile_Load_UTF8 = Utf8BytesToString(aUTF8())
End Function

Private Function BytesLength(abBytes() As Byte) As Long
''' Return length of byte array or zero if uninitialized
' https://www.di-mgt.com.au/howto-convert-vba-unicode-to-utf8.html
    ' Trap error if array is uninitialized
    On Error Resume Next
    BytesLength = UBound(abBytes) - LBound(abBytes) + 1
End Function

Private Function Utf8BytesToString(abUtf8Array() As Byte) As String
''' Return VBA "Unicode" string from byte array encoded in UTF-8
' https://www.di-mgt.com.au/howto-convert-vba-unicode-to-utf8.html
    Dim nBytes As Long
    Dim nChars As Long
    Dim strOut As String

    Utf8BytesToString = ""

    ' Catch uninitialized input array
    nBytes = BytesLength(abUtf8Array)
    If nBytes  Reference to "Microsoft Scripting Runtime"
    Set oFSO = CreateObject("Scripting.FileSystemObject")

'--------------------
    Dim var_txt_file As Object
    Set var_txt_file = oFSO.GetFile(strFullPathFile).OpenAsTextStream(ForReading, TristateTrue)
    xFile_Load_UTF8 = var_txt_file.ReadLine
    var_txt_file.Close
'--------------------

'    Dim oTextStream As Scripting.TextStream
'    Dim aUnicode() As String
'    Dim lgLine As Long
'    Dim strUTF8 As String
'
'    With oFSO
'        Set oTextStream = .OpenTextFile(strFullPathFile, ForReading, False, TristateTrue)
'        aUnicode() = VBA.Split(oTextStream.ReadAll(), vbCrLf)
'        Set oTextStream = Nothing
'        For lgLine = LBound(aUnicode) To UBound(aUnicode)
'            strUTF8 = strUTF8 & vbCrLf & aUnicode(lgLine)
'        Next lgLine
'        Erase aUnicode()
'        xFile_Load_UTF8 = strUTF8
'    End With
'    Set oFSO = Nothing
End Function

And for the comments problem, use this:

Private Function fXML_Uncomment(ByRef strFullPathFile_XSD As String) As String
' There seems to be a problem parsing schemas, as they have comment items:
' "" that are not read by MSMXL object
' We have to split the XSD file into sections... and then reunite in a whole
Dim strXML As String
Dim strXMLOrphan As String
Dim aLine() As String
Dim aBlock() As String
Dim lgLine As Long
Dim lgBlock As Long
Dim lgPosComment As Long

strXML = fFile_Load(strFullPathFile_XSD)
aLine() = VBA.Split(strXML, vbNewLine)

lgBlock = g_Base - 1
For lgLine = (LBound(aLine) + 1) To UBound(aLine)
lgBlock = lgBlock + 1
ReDim Preserve aBlock(g_Base To lgBlock)

aLine(lgLine) = aLine(lgLine) & strXMLOrphan: strXMLOrphan = vbNullString
lgPosComment = VBA.InStr(1, aLine(lgLine), " 0
If VBA.Trim$(aLine(lgLine)) vbNullString Then
aBlock(lgBlock) = aBlock(lgBlock) & aLine(lgLine) & vbNewLine
End If
lgLine = lgLine + 1
If lgLine > UBound(aLine) Then: lgLine = lgLine - 1: lgPosComment = 1: Exit Do
lgPosComment = VBA.InStr(1, aLine(lgLine), "<!--")
DoEvents
Loop
aBlock(lgBlock) = aBlock(lgBlock) & VBA.Mid$(aLine(lgLine), 1, lgPosComment - 1)

If VBA.InStr(aLine(lgLine), " 0 Then
' Avoid empty blocks
If VBA.Len(aBlock(lgBlock)) ") + 3
Do Until lgPosComment > 3
lgPosComment = 1
lgLine = lgLine + 1
If lgLine > UBound(aLine) Then: lgLine = lgLine - 1: lgPosComment = 1: Exit Do
lgPosComment = VBA.InStr(lgPosComment, aLine(lgLine), "-->") + 3
DoEvents
Loop
strXMLOrphan = VBA.Mid$(aLine(lgLine), lgPosComment) & vbNewLine
End If
Next lgLine

fXML_Uncomment = VBA.Join(aBlock(), vbNewLine)
End Function
[/sourcecode]

Leave a Reply

Your email address will not be published. Required fields are marked *