Visual Basic syntax Step-by-Step
[This sample application uses features that were only implemented in MSXML 6.0.]
This topic walks you through the Walk the SOM application. The code is interspersed with textual comments that describe each step of the application.
Click here for the Uncommented Code for the Walk the SOM Application (Visual Basic).
The Application
The code begins with some constant declarations in the General Declarations.
Option Explicit
' Item types:
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
Create a schema cache object. This object will be used later to contain the XML Schema document, po.xsd.
Set oSchemaCache = New XMLSchemaCache60
Set oAnnotationDoc = New DOMDocument60
The remarks variable is used to turn on the display of remarks in the result text. Set to 1 so that remarks will be shown.
remarks = 1
' Load the schema.
nsTarget = "http://www.example.microsoft.com/po"
Add the XML schema document to the schema cache, using its add method. A SOM schema object is returned. The SOM interfaces will now be used to explore the schema object.
For more information about the schema cache, see the IXMLDOMSchemaCollectionadd and get methods.
oSchemaCache.Add nsTarget, "po.xsd"
Set oSchema = oSchemaCache.getSchema(nsTarget)
Set oSchema = oSchemaCache.getSchema(nsTarget)
Use the elements collection, from the schema object, to explore the information in the individual elements.
For Each oE In oSchema.elements
result = result & printElement(oE, 0)
Next
Use the attributes collection, from the schema object, to explore the information in the individual elements.
For Each oA In oSchema.Attributes
result = result & printAttr(oA, numTabs)
Next
result = result & vbNewLine
Use the collection of type objects (ISchemaType interface) to explore each type declaration from the schema object.
For Each oT In oSchema.types
result = result & processType(oT, 0)
Next
result = result & "</xsd:schema>"
Text1.Text = result
End Sub
' ---------------------------------------------------------------------
Create a function to examine the itemType property of the type object passed to it. This function will send the type object to the appropriate function for examining the properties of the passed object.
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
' ---------------------------------------------------------------------
Create a function to walk through the properties of a complexType object that is passed to it in the form of a type object.
Function processComplexType(oComplex, numTabs)
Dim res As String
Dim strAny As String
Dim oAttr As ISchemaAttribute
Dim oComplexCast As ISchemaComplexType
Create a complexType object and assign it the value of the type object that was passed in.
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
Because the type might contain other elements, send the content model to the processGroup function that will walk through the contentModel properties.
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
Walk through each attribute declaration in the complex type. The attribute objects that are used are returned from the attributes property of the ISchemaType object.
For Each oAttr In oComplexCast.Attributes
res = res & printAttr(oAttr, numTabs + 1)
Next
processComplexType = res & printTab(numTabs) & "</xsd:complexType>" & vbNewLine
End Function
' ---------------------------------------------------------------------
Create a function to walk through a simpleTypeobject (ISchemaType) interface and get its properties.
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
There are multiple base types. Therefore, send each type in the baseTypes collection to a function that will extract its name property.
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
' ---------------------------------------------------------------------
Create a function to examine the itemType property of the modelGroup object. The function will then send each item from the particles collection to the appropriate function for examining the properties of the item.
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
' ---------------------------------------------------------------------
Create a function to examine the itemType property of the modelGroup object. The function will then send each item from the particles collection to the appropriate function for examining the properties of the item.
Function printElement(oElement, numTabs)
Dim res As String
Dim strRem As String
Dim oType As ISchemaType
res = printTab(numTabs) & "<xsd:element "
Check the isReference property of the element object to see if the element is a reference to a top-level element declaration.
If oElement.isReference Then
res = res & "ref='" & oElement.Name & "'" & printParticles(oElement) & ">"
res = res & "<!-- "
Check the isAbstract property of the element object to see if the element has had its abstract attribute set to true or to false.
res = res & " abstract='" & oElement.isAbstract & "'"
res = res & " -->" & vbNewLine
Else
Get the type information for the element in a type object returned from the type property of the element object.
Set oType = oElement.Type
Send the element object to a function that will extract its particle information from the inherited minOccurs and maxOccurs properties of the element object.
res = res & "name='" & oElement.Name & "'" & printParticles(oElement)
res = res & " abstract='" & oElement.isAbstract & "'"
res = res & " id='" & oElement.id & "'"
If oType.Name = "" Then
res = res & " >" & vbNewLine
Check the itemType enumerated value of the type object to see what interface is needed to extract type information for the element's type.
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
The type has been declared as a separate type declaration. The name property of the type object is not equal to "".
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
Use the scope property of the element object to find out the name of the scope used in the element declaration.
strRem = "scope:" & printName(oElement.scope)
res = res & printTab(numTabs) & printRemark(strRem)
End If
printElement = res
End Function
' ---------------------------------------------------------------------
Create a function to get the particle information from the object that is passed in.
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
' ---------------------------------------------------------------------
Create a function to walk through the properties of an attribute object.
Function printAttr(oAttr, numTabs)
Dim strRem As String
Check the isReference property of the attribute object to see if the attribute is a reference to a top-level element declaration
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
Check to see whether the type used for the attribute is declared in the attribute declaration, or declared separately. The code performs this check by looking at the name property of the type property for the attribute object.
If oAttr.Type.Name <> "" Then
printAttr = printAttr & " type='" & printName(oAttr.Type) & "'"
End If
Check the defaultValue property of the attribute object to see if the defaultValue attribute was defined in the declaration of the attribute.
If oAttr.defaultValue <> "" Then
printAttr = printAttr & " default='" & oAttr.defaultValue & "'"
End If
Check the fixedValue property of the attribute object to see if the fixedValue attribute was defined in the declaration of the attribute.
If oAttr.fixedValue <> "" Then
printAttr = printAttr & " fixed='" & oAttr.fixedValue & "'"
End If
Check the use property of the attribute object to see the restrictions placed on the entry of the attribute into an XML Schema instance document.
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
' ---------------------------------------------------------------------
This function is used to format the output information in a tab structure. No SOM functionality is included in this 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
' ---------------------------------------------------------------------
Create a function to check the type property of an item and get the name of the item. The function uses the name property to return the name. The name property is inherited from the ISchemaItem interface.
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
' ---------------------------------------------------------------------
Create a function to get the restriction information from the type object or the complexType object that is passed to it. Each restriction that returns a string is checked for a NULL value. If the value is not NULL, the restriction value is retrieved from the appropriate property. Each restriction that returns an integer is checked for a value of "–1". This value indicates that the restriction is not used. If the value is greater than "–1", the restriction value is retrieved for the appropriate property. All other restrictions used in this function have comments listed below.
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
Check the length of the enumeration property. If the length is greater than zero, get the value of the enumeration from the collection of enumerations.
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
Check the value of the whitespace property. If the value is greater than zero, get the whitespace value of the type object.
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
' ---------------------------------------------------------------------
This function wraps the value that is passed in the parameter in remark tags.
No SOM functionality is included in this function.
Function printRemark(r)
printRemark = "<!-- " & r & " -->"
If Not IsEmpty(printRemark) Then printRemark = printRemark & vbNewLine