Uncommented Code for the Walk the SOM Application

Article
10/27/2016
[This sample code uses features that were only implemented in MSXML 6.0.]
' Item types:
Option Explicit
Const SOMITEM_SCHEMA                    = 4*1024
Const SOMITEM_ATTRIBUTE                 = SOMITEM_SCHEMA + 1
Const SOMITEM_ATTRIBUTEGROUP            = SOMITEM_SCHEMA + 2
Const SOMITEM_NOTATION                  = SOMITEM_SCHEMA + 3

Const SOMITEM_ANYTYPE                   = 8*1024
Const SOMITEM_DATATYPE                  = SOMITEM_ANYTYPE+256
Const SOMITEM_SIMPLETYPE                = SOMITEM_DATATYPE+256
Const SOMITEM_COMPLEXTYPE               = 9*1024

Const SOMITEM_PARTICLE                  = 16*1024
Const SOMITEM_ANY                       = SOMITEM_PARTICLE+1
Const SOMITEM_ANYATTRIBUTE              = SOMITEM_PARTICLE+2
Const SOMITEM_ELEMENT                   = SOMITEM_PARTICLE+3
Const SOMITEM_GROUP                     = SOMITEM_PARTICLE+256

Const SOMITEM_ALL                       = SOMITEM_GROUP+1
Const SOMITEM_CHOICE                    = SOMITEM_GROUP+2
Const SOMITEM_SEQUENCE                  = SOMITEM_GROUP+3
Const SOMITEM_EMPTYPARTICLE             = SOMITEM_GROUP+4

' Attribute uses
Const SCHEMAUSE_OPTIONAL   = 0
Const SCHEMAUSE_PROHIBITED = 1
Const SCHEMAUSE_REQUIRED   = 2

Const SCHEMACONTENTTYPE_EMPTY        = 0
Const SCHEMACONTENTTYPE_TEXTONLY     = 1
Const SCHEMACONTENTTYPE_ELEMENTONLY  = 2
Const SCHEMACONTENTTYPE_MIXED        = 3

Public result As String
Public t As Integer
Dim remarks
Private Sub form_load()
Dim nsTarget As String
Dim oSchema As ISchema
Dim oSchemaCache As New XMLSchemaCache60
Dim oAnnotationDoc As New DOMDocument60
Dim oE As ISchemaElement
Dim oA As ISchemaAttribute
Dim oT As ISchemaType

remarks = 1

Set oSchemaCache = CreateObject("Msxml2.XMLSchemaCache.6.0")
Set oAnnotationDoc = CreateObject("Msxml2.DOMDocument.6.0")

' Load the schema.
nsTarget="http://www.example.microsoft.com/po"

oSchemaCache.add nsTarget, "po.xsd"
Set oSchema = oSchemaCache.getSchema(nsTarget)

result = "<xsd:schema xmlns:xsd='http://www.w3.org/2001/XMLSchema'>"+ vbNewLine

For Each oE in oSchema.elements
    result = result + printElement(oE, 0)
Next

For Each oA in oSchema.attributes
    result = result + printAttr(oA, t)
Next

result = result + vbNewLine

For Each oT in oSchema.types
    result = result + processType(oT, 0)
Next

result = result + "</xsd:schema>"

Text1.Text = result
End Sub

' -------------------------------------------------------------------------------------------
Function processType(oType, t)
     Dim res As String
'    res = printTab(t) + printRemark(oType.name)+ vbNewLine
    If oType.itemType = SOMITEM_ANYTYPE Then
        res = res + printTab(t+1) + "<!-- " + oType.name +" -->" 
    End If
    If oType.itemType = SOMITEM_COMPLEXTYPE Then
        res = res + processComplexType(oType, t+1)
    End If
    If oType.itemType = SOMITEM_SIMPLETYPE Then
        res = res + processSimpleType(oType, t+1)
    End If
    processType = res + vbNewLine
End Function

Function processComplexType(oComplex, t)
    Dim res As String
    Dim strAny As String
    Dim oAttr As ISchemaAttribute

    res = printTab(t) + "<xsd:complexType"
    If oComplex.name <> "" Then
        res = res + " name='" + oComplex.name +"'"
    End If
    res = res + ">"

    If oComplex.contentType = SCHEMACONTENTTYPE_EMPTY Then
        res = res + printRemark("emtpy")
    End If
    If oComplex.contentType = SCHEMACONTENTTYPE_TEXTONLY Then
        res = res + printRemark("textonly")
    End If
    If oComplex.contentType =SCHEMACONTENTTYPE_ELEMENTONLY Then
        res = res + printRemark("elementonly")
        res = res + processGroup(oComplex.contentModel, t+1)
    End If
    If oComplex.contentType = SCHEMACONTENTTYPE_MIXED Then
        res = res + printRemark("mixed")
        res = res + processGroup(oComplex.contentModel, t+1)
    End If
    res = res + vbNewline
    If oComplex.baseTypes.length > 0 Then
        res = res + printRestrictions(oComplex, t+1)
    End If
    On Error Resume Next
    StrAny = oComplex.anyAttribute.name
    If Err.number = 0 Then
        res = res + oComplex.anyAttribute.name
    End If

    For Each oAttr in oComplex.attributes
        res = res + printAttr(oAttr, t+1)
    Next

    processComplexType = res + printTab(t) + "</xsd:complexType>"+vbNewline
End Function

Function processSimpleType(oSimple, t)
    Dim res As String
    Dim oType As ISchemaType

    res = printTab(t) + "<xsd:simpleType"
    If oSimple.name <> "" Then
        res = res + " name='" + oSimple.name +"'"
    End If
    res = res + ">"+vbNewline

    If oSimple.baseTypes.length = 1 Then
        res = res + printRestrictions(oSimple, t+1)
    Else
        For Each oType in oSimple.baseTypes
            res = res + "<baseType name='" + printName(oType) +"'>"+vbNewline
        Next
    End If

    processSimpleType = res + printTab(t) + "</xsd:simpleType>"+vbNewline
End Function

Function processGroup(poGroup, t)
    Dim res As String
    res = ""
    ' List elements in the sequence.

    If poGroup.itemType = SOMITEM_ALL Then
        res = res + printTab(t+1) + "<xsd:all>"+vbNewline
        res = res + processChoiceOrSequence(poGroup, t+1)
        res = res + printTab(t+1) + "</xsd:all>"
    End If

    If poGroup.itemType = SOMITEM_CHOICE Then
        res = res + printTab(t+1) + "<xsd:choice>"+vbNewline
        res = res + processChoiceOrSequence(poGroup, t+1)
        res = res + printTab(t+1) + "</xsd:choice>"
    End If

    If poGroup.itemType = SOMITEM_SEQUENCE Then
        res = res + printTab(t+1) + "<xsd:sequence>"+vbNewline
        res = res + processChoiceOrSequence(poGroup, t+1)
        res = res + printTab(t+1) + "</xsd:sequence>"
    End If
    processGroup = res
End Function

Function processChoiceOrSequence(poGroup, t)
    Dim res As String
    Dim item As ISchemaParticle

    res = ""
    For Each item in poGroup.particles
        If item.itemType = SOMITEM_ELEMENT Then
            res = res + printElement(item, t+1)
        End If
        If (item.itemType and SOMITEM_GROUP) = SOMITEM_GROUP Then
            res = res + processGroup(item, t+1)+vbNewline
        End If
        If item.itemType = SOMITEM_ANY Then
            res = res + "any: " + item.name+vbNewline
        End If
    Next
    processChoiceOrSequence = res
End Function

Function printElement(oElement, t)
    Dim res As String
    Dim strRem As String
    Dim oType As ISchemaType

    res = printTab(t) + "<xsd:element "
    If oElement.isReference Then
        res = res + "ref='" + oElement.name + "'" + printParticles(oElement) + ">"
        res = res + "<!-- "
        res = res + " abstract='" & oElement.isAbstract & "'"
        res = res + " -->"
    Else
        Set oType=oElement.type
        res = res + "name='" + oElement.name + "'" + printParticles(oElement)
        res = res + " abstract='" & oElement.isAbstract & "'"
        res = res + " id='" & oElement.id & "'"
        If oType.name = "" Then
            res = res + ">" + vbNewLine 
            If oType.itemType = SOMITEM_COMPLEXTYPE Then
                res = res + printElement + processComplexType(oType, t+1)
            Else
                res = res + processSimpleType(oType, t)
            End If
            res = res + printTab(t) + "</xsd:element>"
        Else
            If printName(oType) <> "xsd:anyType" Then
                res = res + " type='" + printName(oType) + "'"
            End If

            If oType.itemType <> SOMITEM_COMPLEXTYPE Then
                If oType.baseTypes.length = 0 Then
                    res = res + "/>"
                Else
                    res = res + ">" + vbNewLine + processSimpleType(oType, t)
                    res = res + printTab(t) + "</xsd:element>"
                End If
            Else
                res = res + "/>"
            End If
        End If
    End If
    If Not oElement.scope Is Nothing Then
       strRem = "scope:" + printName(oElement.scope)
    End If
    res = res + printRemark(strRem)
    printElement = res
End Function

Function printParticles(oParticle)
    Dim res As String
        If oParticle.minOccurs <> 1 Then 
            res = res + " minOccurs='" & oParticle.minOccurs & "'"
        End If
        If oParticle.maxOccurs <> 1 Then 
            If oParticle.maxOccurs = -1 Then 
                res = res + " maxOccurs='unbounded'"
            Else
                res = res + " maxOccurs='" & oParticle.maxOccurs & "'"
            End If
        End If
        printParticles = res
End Function

Function printAttr(oAttr, t)
        Dim strRem As String
        If oAttr.isReference Then
            printAttr = printAttr + printTab(t) + "<xsd:attribute ref='" + oAttr.name + "'"
        Else
            printAttr = printAttr + printTab(t) + "<xsd:attribute name='" + oAttr.name + "'"
        End If
        If oAttr.type.name <> "" Then
            printAttr = printAttr + " type='" + printName(oAttr.type) + "'"
        End If
        If oAttr.defaultValue <> "" Then
            printAttr = printAttr + " default='" + oAttr.defaultValue + "'"
        End If
        If oAttr.fixedValue <> "" Then
            printAttr = printAttr + " fixed='" + oAttr.fixedValue + "'"
        End If
        If oAttr.use = SCHEMAUSE_OPTIONAL   Then printAttr = printAttr + " use='optional'"
        If oAttr.use = SCHEMAUSE_PROHIBITED Then printAttr = printAttr + " use='prohibited'"
        If oAttr.use = SCHEMAUSE_REQUIRED   Then printAttr = printAttr + " use='required'"
        printAttr = printAttr + "/>"
        If Not oAttr.scope Is Nothing Then
           strRem = "scope:" + printName(oAttr.scope)
        End If
        printAttr = printAttr + printRemark(strRem)
End Function

Function printTab(t)
    Dim strTab As String
    Dim x As Integer

    strTab =""
    for x=0 to t
        strTab=strTab+"  "
    next
    printTab=strTab
End Function

Function printName(item)
    Dim res As String
    Dim item As ISchemaItem
    Dim opattern As Variant

    printName =""
    If (item.itemType and SOMITEM_DATATYPE) = SOMITEM_DATATYPE Then
        printName= "xsd:"
    End If 
    If item.itemType = SOMITEM_ANYTYPE Then
        printName= "xsd:"
    End If 
    printName= printName + item.name
End Function

Function printRestrictions(oType, t)
    Dim res As String
    Dim item As ISchemaItem
    Dim opattern As Variant

    res = ""
    If oType.minExclusive <> "" Then
        res = res + printTab(t+1) + "<xsd:minExclusive value='"+ oType.minExclusive + "'/>" + vbNewLine
    End If
    If oType.minInclusive <> "" Then
        res = res + printTab(t+1) + "<xsd:minInclusive value='"+ oType.minInclusive + "'/>" + vbNewLine
    End If
    If oType.maxExclusive <> "" Then
        res = res + printTab(t+1) + "<xsd:maxExclusive value='"+ oType.maxExclusive + "'/>" + vbNewLine
    End If
    If oType.maxInclusive <> "" Then
        res = res + printTab(t+1) + "<xsd:maxInclusive value='"+ oType.maxInclusive + "'/>" + vbNewLine
    End If
    If oType.totalDigits > -1 Then
        res = res + printTab(t+1) + "<xsd:totalDigits value='" & oType.totalDigits & "'/>" + vbNewLine
    End If
    If oType.fractionDigits > -1 Then
        res = res + printTab(t+1) + "<xsd:fractionDigits value='" & oType.fractionDigits & "'/>" + vbNewLine
    End If
    If oType.length > -1 Then
        res = res + printTab(t+1) + "<xsd:length value='" & oType.length & "'/>" + vbNewLine
    End If
    If oType.minLength > -1 Then
        res = res + printTab(t+1) + "<xsd:minLength value='" & oType.minLength & "'/>" + vbNewLine
    End If
    If oType.maxLength > -1 Then
        res = res + printTab(t+1) + "<xsd:maxLength value='" & oType.maxLength & "'/>" + vbNewLine
    End If
    If oType.enumeration.length > 0 Then
        For Each item in oType.enumeration
            res = res + printTab(t+1) + "<xsd:enumeration value='" + item + "'/>" + vbNewLine
        Next
    End If
    If oType.whitespace > 0 Then
        res = res + printTab(t+1) + "<xsd:whitespace value='" & oType.whitespace & "'/>" + vbNewLine
    End If
    If oType.patterns.length <> 0 Then
        For Each oPattern in oType.patterns
            res = res + printTab(t+1) + "<xsd:pattern value='" + opattern + "'/>" + vbNewLine
        Next
    End If

    printRestrictions = ""
    If res <> "" and oType.baseTypes.length > 0 Then
        printRestrictions = printRestrictions + printTab(t) + "<xsd:restriction base='" + printName(oType.baseTypes(0)) + "'>" + vbNewLine
        printRestrictions = printRestrictions + res
        printRestrictions = printRestrictions + printTab(t) + "</xsd:restriction>" + vbNewLine
    End If

End Function

Function printRemark(r)
    If remarks = 1 Then
        printRemark = "<!-- " + r + " -->"
    End If
    printRemark = printRemark + vbNewLine
End Function
Share via

Uncommented Code for the Walk the SOM Application

Additional resources
