Uncommented Code for the Walk the SOM Application (Visual Basic)

Article
10/27/2016
[This sample application code uses features that were only implemented in MSXML 6.0.]
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 numTabs As Integer
Dim remarks


Private Sub form_load()

Dim nsTarget As String
Dim oSchema As ISchema
Dim oSchemaCache As XMLSchemaCache60
Dim oAnnotationDoc As DOMDocument60
Dim oE As ISchemaElement
Dim oA As ISchemaAttribute
Dim oT As ISchemaType

Set oSchemaCache = New XMLSchemaCache60
Set oAnnotationDoc = New DOMDocument60

remarks = 1
' 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, numTabs)
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, numTabs)
    Dim res As String
'    res = printTab(numTabs) & printRemark(oType.name)& vbNewLine
    If oType.itemType = SOMITEM_ANYTYPE Then
        res = res & printTab(numTabs + 1) & "<!-- " & oType.Name & " -->" & vbNewLine
    End If
    If oType.itemType = SOMITEM_COMPLEXTYPE Then
        res = res & processComplexType(oType, numTabs + 1)
    End If
    If oType.itemType = SOMITEM_SIMPLETYPE Then
        res = res & processSimpleType(oType, numTabs + 1)
    End If
    processType = res & vbNewLine
End Function

Function processComplexType(oComplex, numTabs)
    Dim res As String
    Dim strAny As String
    Dim oAttr As ISchemaAttribute
    Dim oComplexCast As ISchemaComplexType
    Set oComplexCast = oComplex
    res = printTab(numTabs) & "<xsd:complexType"
    If oComplexCast.Name <> "" Then
        res = res & " name='" & oComplexCast.Name & "'"
    End If
    res = res & ">" & vbNewLine

    If oComplexCast.contentType = SCHEMACONTENTTYPE_EMPTY Then
        res = res & printTab(numTabs) & printRemark("emtpy")
    End If
    If oComplexCast.contentType = SCHEMACONTENTTYPE_TEXTONLY Then
        res = res & printTab(numTabs) & printRemark("textonly")
    End If
    If oComplexCast.contentType = SCHEMACONTENTTYPE_ELEMENTONLY Then
        res = res & printTab(numTabs) & printRemark("elementonly")
        res = res & processGroup(oComplexCast.contentModel, numTabs + 1)
    End If
    If oComplexCast.contentType = SCHEMACONTENTTYPE_MIXED Then
        res = res & printTab(numTabs) & printRemark("mixed")
        res = res & processGroup(oComplexCast.contentModel, numTabs + 1)
    End If
    res = res & vbNewLine
    res = res & printRestrictions(oComplexCast, numTabs + 1)

    On Error Resume Next
    strAny = oComplexCast.anyAttribute.Name
    If Err.Number = 0 Then
        res = res & oComplexCast.anyAttribute.Name
    End If

    For Each oAttr In oComplexCast.Attributes
        res = res & printAttr(oAttr, numTabs + 1)
    Next

    processComplexType = res & printTab(numTabs) & "</xsd:complexType>" & vbNewLine
End Function

Function processSimpleType(oSimple, numTabs)
    Dim res As String
    Dim oType As ISchemaType
    res = printTab(numTabs) & "<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, numTabs + 1)
    Else
        For Each oType In oSimple.baseTypes
            res = res & "<baseType name='" & printName(oType) & "'>" & vbNewLine
        Next
    End If

    processSimpleType = res & printTab(numTabs) & "</xsd:simpleType>" & vbNewLine
End Function

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

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

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

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

Function processChoiceOrSequence(poGroup, numTabs)
    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, numTabs + 1)
        End If
        If (item.itemType And SOMITEM_GROUP) = SOMITEM_GROUP Then
            res = res & processGroup(item, numTabs + 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, numTabs)
    Dim res As String
    Dim strRem As String
    Dim oType As ISchemaType
    res = printTab(numTabs) & "<xsd:element "
    If oElement.isReference Then
        res = res & "ref='" & oElement.Name & "'" & printParticles(oElement) & ">"
        res = res & "<!-- "
        res = res & " abstract='" & oElement.isAbstract & "'"
        res = res & " -->" & vbNewLine
    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, numTabs + 1)
            Else
                res = res & processSimpleType(oType, numTabs)
            End If
            res = res & printTab(numTabs) & "</xsd:element>" & vbNewLine
        Else
            If printName(oType) <> "xsd:anyType" Then
                res = res & " type='" & printName(oType) & "'"
            End If

            If oType.itemType <> SOMITEM_COMPLEXTYPE Then
                If printRestrictions(oType, 0) = "" Then
                    res = res & "/>" & vbNewLine
                Else
                    res = res & ">" & vbNewLine & processSimpleType(oType, numTabs)
                    res = res & printTab(numTabs) & "</xsd:element>"
                End If
            Else
                res = res & "/>" & vbNewLine
            End If
        End If
    End If
    If Not oElement.scope Is Nothing Then
        strRem = "scope:" & printName(oElement.scope)
        res = res & printTab(numTabs) & printRemark(strRem)
    End If
    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, numTabs)
    Dim strRem As String
        If oAttr.isReference Then
            printAttr = printAttr & printTab(numTabs) & "<xsd:attribute ref='" & oAttr.Name & "'"
        Else
            printAttr = printAttr & printTab(numTabs) & "<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 & "/>" & vbNewLine
        If Not oAttr.scope Is Nothing Then
            strRem = "scope:" & printName(oAttr.scope)
            printAttr = printAttr & printTab(numTabs) & printRemark(strRem)
        End If
        'strRem = "scope:" & printName(oElement.scope)

End Function

Function printTab(numTabs)
    Dim strTab As String
    Dim x As Integer
    strTab = ""
    For x = 0 To numTabs
        strTab = strTab & "   "
    Next
    printTab = strTab
End Function

Function printName(item)
    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, numTabs)
    Dim res As String
    Dim oItem As ISchemaItem
    Dim strPattern As Variant
    Dim strItem As String

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

    printRestrictions = ""
    If res <> "" And oType.baseTypes.length > 0 Then
       printRestrictions = printRestrictions & printTab(numTabs) & "<xsd:restriction base='" & _
          printName(oType.baseTypes(0)) & "'>" & vbNewLine
        printRestrictions = printRestrictions & res
        printRestrictions = printRestrictions & printTab(numTabs) & "</xsd:restriction>" & vbNewLine
    End If

End Function

Function printRemark(r)
        printRemark = "<!-- " & r & " -->"
    If Not IsEmpty(printRemark) Then printRemark = printRemark & vbNewLine
End Function
Partager via

Uncommented Code for the Walk the SOM Application (Visual Basic)

Ressources supplémentaires
