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.
''' 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]