windows-server-2003/admin/pchealth/authtools/prodtools/authdatabase/taxonomy.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "Taxonomy"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"No"
Option Explicit

Public Event ReportStatus(ByVal strStatus As String, ByRef blnCancel As Boolean)

Public Sub GetURIs( _
    ByVal o_dict As Scripting.Dictionary _
)
    Dim rs As ADODB.Recordset
    Dim strQuery As String
    Dim strURI As String
    
    CheckDatabaseVersion
    
    Set rs = New ADODB.Recordset

    strQuery = "" & _
        "SELECT DISTINCT ContentURI " & _
        "FROM Taxonomy "
    
    rs.Open strQuery, g_cnn, adOpenStatic, adLockReadOnly
    
    Do While (Not rs.EOF)
        strURI = Trim$(rs("ContentURI") & "")
        If (strURI <> "") Then
            If (Not o_dict.Exists(strURI)) Then
                o_dict.Add strURI, True
            End If
        End If
        rs.MoveNext
    Loop

End Sub

Public Sub GetTitlesForKeyword( _
    ByVal i_intKID As Long, _
    ByVal o_rs As ADODB.Recordset _
)
    Dim strQuery As String
    
    CheckDatabaseVersion
    
    CloseRecordSet o_rs
    
    ' ADO uses % as a wildcard character in SQL statements whereas Access uses *.
    strQuery = "" & _
        "SELECT * " & _
        "FROM Taxonomy " & _
        "WHERE (Keywords Like ""% " & i_intKID & " %"")"
    
    o_rs.Open strQuery, g_cnn, adOpenStatic, adLockReadOnly

End Sub

Public Sub GetNodeDetails( _
    ByVal i_intTID As Long, _
    ByVal o_rs As ADODB.Recordset _
)
    
    Dim strQuery As String
    
    CheckDatabaseVersion
    
    CloseRecordSet o_rs
    
    strQuery = "" & _
        "SELECT * " & _
        "FROM Taxonomy " & _
        "WHERE (TID=" & i_intTID & ")"
        
    o_rs.Open strQuery, g_cnn, adOpenStatic, adLockPessimistic
        
End Sub

Public Sub GetNodeChildren( _
    ByVal i_intTID As Long, _
    ByVal o_rs As ADODB.Recordset _
)
    
    Dim strQuery As String
    
    CheckDatabaseVersion
    
    CloseRecordSet o_rs
    
    strQuery = "" & _
        "SELECT * " & _
        "FROM Taxonomy " & _
        "WHERE ((ParentTID=" & i_intTID & ") " & _
        "AND (TID<>" & ROOT_TID_C & ")) " & _
        "ORDER BY TID"
        
    o_rs.Open strQuery, g_cnn, adOpenStatic, adLockReadOnly
        
End Sub

Public Function GetTypes( _
) As Variant()

    Dim strQuery As String
    Dim rs As ADODB.Recordset
    Dim arrTypes() As Variant
    Dim intIndex As Long
    Dim intTypeID As Long
    Dim strDescription As String
    
    CheckDatabaseVersion
    
    Set rs = New ADODB.Recordset
    
    strQuery = "" & _
        "SELECT * " & _
        "FROM Types " & _
        "ORDER BY Description"
        
    rs.Open strQuery, g_cnn, adOpenStatic, adLockReadOnly
    
    ReDim arrTypes(rs.RecordCount - 1)
    
    intIndex = 0
    
    Do While (Not rs.EOF)
        intTypeID = rs("TypeID")
        strDescription = rs("Description") & ""
        arrTypes(intIndex) = Array(intTypeID, strDescription)
        intIndex = intIndex + 1
        rs.MoveNext
    Loop

    GetTypes = arrTypes

End Function

Private Function p_CreateTaxonomyElement( _
    ByVal i_DOMDoc As MSXML2.DOMDocument, _
    ByVal i_rs As ADODB.Recordset _
) As MSXML2.IXMLDOMElement

    Dim Element As MSXML2.IXMLDOMElement
    
    Set Element = i_DOMDoc.createElement(HHT_TAXONOMY_ENTRY_C)
            
    With Element
        .setAttribute HHT_TITLE_C, i_rs("ENUTitle") & ""
        .setAttribute HHT_URI_C, i_rs("ContentURI") & ""
        .setAttribute HHT_ICONURI_C, i_rs("IconURI") & ""
        .setAttribute HHT_DESCRIPTION_C, i_rs("ENUDescription") & ""
        .setAttribute HHT_TYPE_C, IIf(IsNull(i_rs("Type")), 0, i_rs("Type"))
        .setAttribute HHT_VISIBLE_C, IIf(i_rs("Visible"), "True", "False")
        .setAttribute HHT_SUBSITE_C, IIf(i_rs("SubSite"), "True", "False")
        
        .setAttribute HHT_tid_C, i_rs("TID")
        .setAttribute HHT_comments_C, i_rs("Comments") & ""
        .setAttribute HHT_locinclude_C, i_rs("LocInclude") & ""
        .setAttribute HHT_skus_C, i_rs("SKUs")
        .setAttribute HHT_modifiedtime_C, i_rs("ModifiedTime")
        .setAttribute HHT_username_C, i_rs("Username")
        .setAttribute HHT_leaf_C, IIf(i_rs("Leaf"), "True", "False")
        .setAttribute HHT_parenttid_C, i_rs("ParentTID")
        .setAttribute HHT_basefile_C, i_rs("BaseFile") & ""
        .setAttribute HHT_keywords_C, i_rs("Keywords") & ""
        .setAttribute HHT_orderunderparent_C, i_rs("OrderUnderParent")
        .setAttribute HHT_authoringgroup_C, i_rs("AuthoringGroup")
        .setAttribute HHT_ENTRY_C, i_rs("Entry") & ""
        .setAttribute HHT_NAVIGATIONMODEL_C, NavModelString(i_rs("NavigationModel") & "")
    End With
    
    Set p_CreateTaxonomyElement = Element

End Function

Public Sub FixOrderingNumbers()
    
    Dim rsLock As ADODB.Recordset
    Dim rs As ADODB.Recordset
    Dim strQuery As String
    Dim intParentTID As Long
    Dim intLastParentTID As Long
    Dim intOrderUnderParent As Long
    
    CheckDatabaseVersion
    LockTable LOCK_TABLE_TAXONOMY, rsLock
    
    Set rs = New ADODB.Recordset

    strQuery = "" & _
        "SELECT * " & _
        "FROM Taxonomy " & _
        "ORDER BY ParentTID, OrderUnderParent"
        
    rs.Open strQuery, g_cnn, adOpenForwardOnly, adLockPessimistic
    
    intLastParentTID = INVALID_ID_C
    
    Do While (Not rs.EOF)
        
        intParentTID = rs("ParentTID")
        
        If (intParentTID <> intLastParentTID) Then
            intLastParentTID = intParentTID
            intOrderUnderParent = 0
        End If
        
        If (rs("TID") <> ROOT_TID_C) Then
            intOrderUnderParent = intOrderUnderParent + PREFERRED_ORDER_DELTA_C
            rs("OrderUnderParent") = intOrderUnderParent
            rs.Update
        End If
        
        rs.MoveNext
    Loop

End Sub

Public Function GetCategory( _
    ByRef i_DOMNode As MSXML2.IXMLDOMNode _
) As String

    Dim DOMNode As MSXML2.IXMLDOMNode
    Dim DOMNodeParent As MSXML2.IXMLDOMNode
    Dim intTID As Long
    Dim strParentCategory As String
    Dim strParentEntry As String
    
    If (i_DOMNode.nodeName <> HHT_TAXONOMY_ENTRY_C) Then
        Exit Function
    End If
    
    intTID = XMLGetAttribute(i_DOMNode, HHT_tid_C)
    
    If (intTID = ROOT_TID_C) Then
        Exit Function
    End If
        
    Set DOMNodeParent = i_DOMNode.parentNode
    
    If (DOMNodeParent Is Nothing) Then
        Exit Function
    End If

    strParentCategory = GetCategory(DOMNodeParent)
    strParentEntry = XMLGetAttribute(DOMNodeParent, HHT_ENTRY_C)
    
    If (XMLGetAttribute(DOMNodeParent, HHT_tid_C) = ROOT_TID_C) Then
        strParentEntry = ""
    End If

    If (strParentCategory = "") Then
        GetCategory = strParentEntry
    Else
        GetCategory = strParentCategory & "/" & strParentEntry
    End If

End Function

Private Sub p_CreateKeywordElements( _
    ByRef u_DOMNode As MSXML2.IXMLDOMNode, _
    ByRef i_colKeywords As Collection _
)

    Dim strKeywords As String
    Dim strKeyword As String
    Dim arrKeywords() As String
    Dim strKID As String
    Dim intIndex As Long
    Dim DOMDoc As MSXML2.DOMDocument
    Dim Element As MSXML2.IXMLDOMElement
    
    strKeywords = XMLGetAttribute(u_DOMNode, HHT_keywords_C)
    
    arrKeywords = Split(strKeywords, " ")
    
    Set DOMDoc = u_DOMNode.ownerDocument

    For intIndex = LBound(arrKeywords) To UBound(arrKeywords)
        strKID = arrKeywords(intIndex)
        If (strKID = "") Then
            GoTo LForEnd
        End If
        If (Not CollectionContainsKey(i_colKeywords, strKID)) Then
            GoTo LForEnd
        End If
        strKeyword = i_colKeywords(strKID)
        
        Set Element = DOMDoc.createElement(HHT_KEYWORD_C)
        Element.Text = XMLEscape(strKeyword)
        u_DOMNode.appendChild Element
LForEnd:
    Next

End Sub

Private Sub p_SetRealSKUs( _
    ByRef u_DOMNode As MSXML2.IXMLDOMNode, _
    ByVal i_enumAllowedSKUs As SKU_E _
)

    Dim enumSKUs As SKU_E
    Dim DOMNode As MSXML2.IXMLDOMNode
    
    DoEvents
        
    If (u_DOMNode.nodeName <> HHT_TAXONOMY_ENTRY_C) Then
        Exit Sub
    End If

    enumSKUs = XMLGetAttribute(u_DOMNode, HHT_skus_C)
    enumSKUs = enumSKUs And i_enumAllowedSKUs
    
    XMLSetAttribute u_DOMNode, HHT_skus_C, enumSKUs
    
    For Each DOMNode In u_DOMNode.childNodes
        p_SetRealSKUs DOMNode, enumSKUs
    Next

End Sub

Private Sub p_SetAttributes( _
    ByRef u_DOMNode As MSXML2.IXMLDOMNode, _
    ByRef i_colKeywords As Collection, _
    ByRef i_strCategory As String _
)
    
    Dim DOMNode As MSXML2.IXMLDOMNode
    Dim strEntry As String
    Dim strCategory As String
    Dim intTID As Long
    Dim blnLeaf As Boolean
    
    DoEvents
    
    If (u_DOMNode.nodeName <> HHT_TAXONOMY_ENTRY_C) Then
        Exit Sub
    End If

    p_RaiseEventAndLookForCancel "Setting keywords and category of " & _
        XMLGetAttribute(u_DOMNode, HHT_TITLE_C)
        
    blnLeaf = XMLGetAttribute(u_DOMNode, HHT_leaf_C)

    If (blnLeaf) Then
        p_CreateKeywordElements u_DOMNode, i_colKeywords
    End If
    
    XMLSetAttribute u_DOMNode, HHT_ACTION_C, HHTVAL_ADD_C
    XMLSetAttribute u_DOMNode, HHT_CATEGORY_C, i_strCategory
    
    If (blnLeaf) Then
        Exit Sub
    End If
    
    strEntry = XMLGetAttribute(u_DOMNode, HHT_ENTRY_C)
    
    If (i_strCategory = "") Then
        strCategory = strEntry
    Else
        strCategory = i_strCategory & "/" & strEntry
    End If
    
    intTID = XMLGetAttribute(u_DOMNode, HHT_tid_C)
    
    If (intTID = ROOT_TID_C) Then
        strCategory = ""
    End If

    For Each DOMNode In u_DOMNode.childNodes
        p_SetAttributes DOMNode, i_colKeywords, strCategory
    Next

End Sub

Public Sub SetCategory2AndEntry( _
    ByRef u_DOMNode As MSXML2.IXMLDOMNode, _
    ByRef i_strCategory As String _
)
    
    Dim DOMNode As MSXML2.IXMLDOMNode
    Dim strEntry As String
    Dim strCategory As String
    Dim intTID As Long
    Dim blnLeaf As Boolean
    
    DoEvents
    
    If (u_DOMNode.nodeName <> HHT_TAXONOMY_ENTRY_C) Then
        Exit Sub
    End If
    
    blnLeaf = XMLGetAttribute(u_DOMNode, HHT_leaf_C)
    
    If (blnLeaf) Then
        Exit Sub
    End If

    strEntry = XMLGetAttribute(u_DOMNode, HHT_ENTRY_C)
    
    If (i_strCategory = "") Then
        strCategory = strEntry
    Else
        strCategory = i_strCategory & "/" & strEntry
    End If
    
    intTID = XMLGetAttribute(u_DOMNode, HHT_tid_C)
    
    If (intTID = ROOT_TID_C) Then
        strCategory = ""
    End If
    
    XMLSetAttribute u_DOMNode, HHT_category2_C, strCategory

    For Each DOMNode In u_DOMNode.childNodes
        SetCategory2AndEntry DOMNode, strCategory
    Next

End Sub

Private Sub p_SetOrderingInfo( _
    ByRef u_DOMNode As MSXML2.IXMLDOMNode _
)
    Dim DOMNodeSibling As MSXML2.IXMLDOMNode
    Dim DOMNode As MSXML2.IXMLDOMNode
    Dim strEntry As String
    Dim strURI As String
    
    DoEvents
        
    If (u_DOMNode.nodeName <> HHT_TAXONOMY_ENTRY_C) Then
        Exit Sub
    End If

    Set DOMNodeSibling = u_DOMNode.previousSibling
    
    If (DOMNodeSibling Is Nothing) Then
        XMLSetAttribute u_DOMNode, HHT_INSERTMODE_C, HHTVAL_TOP_C
    Else
        strEntry = XMLGetAttribute(DOMNodeSibling, HHT_ENTRY_C)
        strURI = XMLGetAttribute(DOMNodeSibling, HHT_URI_C)
        
        If (strEntry <> "") Then
            XMLSetAttribute u_DOMNode, HHT_INSERTMODE_C, HHTVAL_AFTER_NODE_C
            XMLSetAttribute u_DOMNode, HHT_INSERTLOCATION_C, strEntry
        ElseIf (strURI <> "") Then
            XMLSetAttribute u_DOMNode, HHT_INSERTMODE_C, HHTVAL_AFTER_TOPIC_C
            XMLSetAttribute u_DOMNode, HHT_INSERTLOCATION_C, strURI
        End If
    End If
    
    For Each DOMNode In u_DOMNode.childNodes
        p_SetOrderingInfo DOMNode
    Next

End Sub

Private Sub p_RemoveNodesWithOtherSKUs( _
    ByRef u_DOMNode As MSXML2.IXMLDOMNode, _
    ByVal i_enumRequiredSKUs As SKU_E _
)

    Dim enumSKUs As SKU_E
    Dim DOMNode As MSXML2.IXMLDOMNode
    
    DoEvents
            
    If (u_DOMNode.nodeName <> HHT_TAXONOMY_ENTRY_C) Then
        Exit Sub
    End If

    enumSKUs = XMLGetAttribute(u_DOMNode, HHT_skus_C)
    
    If ((enumSKUs And i_enumRequiredSKUs) <> i_enumRequiredSKUs) Then
        If ((enumSKUs And i_enumRequiredSKUs) <> 0) Then
            WriteLog "Skipping " & XMLGetAttribute(u_DOMNode, HHT_TITLE_C) & _
                " because it doesn't have all required SKUs"
        End If
        u_DOMNode.parentNode.removeChild u_DOMNode
        Exit Sub
    End If
    
    For Each DOMNode In u_DOMNode.childNodes
        p_RemoveNodesWithOtherSKUs DOMNode, i_enumRequiredSKUs
    Next

End Sub

Private Sub p_FlattenHHT( _
    ByRef u_DOMNode As MSXML2.IXMLDOMNode, _
    ByRef u_DOMNodeEntries As MSXML2.IXMLDOMNode _
)
    
    Dim DOMNode As MSXML2.IXMLDOMNode
    Dim intTID As Long
    
    DoEvents
    
    If (u_DOMNode.nodeName <> HHT_TAXONOMY_ENTRY_C) Then
        Exit Sub
    End If
    
    u_DOMNode.parentNode.removeChild u_DOMNode
        
    intTID = XMLGetAttribute(u_DOMNode, HHT_tid_C)

    If (intTID <> ROOT_TID_C) Then
        u_DOMNodeEntries.appendChild u_DOMNode
    End If
    
    For Each DOMNode In u_DOMNode.childNodes
        p_FlattenHHT DOMNode, u_DOMNodeEntries
    Next

End Sub

Private Sub p_RemoveAttributes( _
    ByRef u_DOMElement As MSXML2.IXMLDOMElement, _
    ByVal i_blnWinMe As Boolean, _
    ByVal i_blnAuthoringGroupHHT As Boolean _
)
    
    Dim Attr As MSXML2.IXMLDOMAttribute
    Dim DOMNode As MSXML2.IXMLDOMNode
    Dim blnLeaf As Boolean
    
    DoEvents

    If (u_DOMElement.nodeName <> HHT_TAXONOMY_ENTRY_C) Then
        If (u_DOMElement.nodeName <> HHT_TAXONOMY_ENTRIES_C) Then
            Exit Sub
        End If
    End If

    For Each Attr In u_DOMElement.Attributes
        Select Case Attr.Name
        Case HHT_tid_C, HHT_locinclude_C, HHT_modifiedtime_C, HHT_comments_C, _
            HHT_parenttid_C, HHT_basefile_C, HHT_keywords_C, HHT_orderunderparent_C, _
            HHT_allowedskus_C, HHT_username_C
            
            u_DOMElement.removeAttribute Attr.Name
        Case HHT_skus_C, HHT_authoringgroup_C
            If (Not i_blnAuthoringGroupHHT) Then
                u_DOMElement.removeAttribute Attr.Name
            End If
        Case HHT_leaf_C
            blnLeaf = Attr.Value
            u_DOMElement.removeAttribute Attr.Name
            If (blnLeaf) Then
                u_DOMElement.removeAttribute HHT_ENTRY_C
            End If
        Case HHT_VISIBLE_C
            If (i_blnWinMe) Then
                u_DOMElement.removeAttribute HHT_VISIBLE_C
            End If
        End Select
    Next
        
    For Each DOMNode In u_DOMElement.childNodes
        p_RemoveAttributes DOMNode, i_blnWinMe, i_blnAuthoringGroupHHT
    Next

End Sub

Public Sub p_RemoveNullTopicURIs( _
    ByRef u_DOMNodeEntries As MSXML2.IXMLDOMNode _
)

    Dim DOMNode As MSXML2.IXMLDOMNode
    
    For Each DOMNode In u_DOMNodeEntries.childNodes
        If (XMLGetAttribute(DOMNode, HHT_ENTRY_C) = "") Then
            If (XMLGetAttribute(DOMNode, HHT_URI_C) = "") Then
                WriteLog "Topic has no URI, and will not be output"
                WriteLog "Title: " & XMLGetAttribute(DOMNode, HHT_TITLE_C)
                WriteLog "Category: " & XMLGetAttribute(DOMNode, HHT_CATEGORY_C)
                u_DOMNodeEntries.removeChild DOMNode
            End If
        End If
    Next

End Sub

Public Sub TransformHHTTov10( _
    ByRef u_DOMNode As MSXML2.IXMLDOMNode, _
    ByRef i_colKeywords As Collection, _
    ByRef i_strCategory As String, _
    ByVal i_intAllowedSKUs As Long, _
    ByRef u_DOMNodeEntries As MSXML2.IXMLDOMNode, _
    ByVal i_intRequiredSKUs As Long, _
    ByVal i_blnAuthoringGroupHHT As Boolean _
)
    p_RaiseEventAndLookForCancel "Transforming HHT"

    p_SetRealSKUs u_DOMNode, i_intAllowedSKUs
    
    p_SetAttributes u_DOMNode, i_colKeywords, i_strCategory
    
    If (i_intRequiredSKUs <> ALL_SKUS_C) Then
        p_RaiseEventAndLookForCancel "Removing Nodes/Topics from other SKUs"
        p_RemoveNodesWithOtherSKUs u_DOMNode, i_intRequiredSKUs
    End If
        
    If (i_blnAuthoringGroupHHT) Then
        p_RaiseEventAndLookForCancel "Setting ordering info"
        p_SetOrderingInfo u_DOMNode
    End If

    p_RaiseEventAndLookForCancel "Transforming HHT"
    p_FlattenHHT u_DOMNode, u_DOMNodeEntries

    p_RemoveAttributes u_DOMNodeEntries, _
        IIf((i_intRequiredSKUs = SKU_WINDOWS_MILLENNIUM_E), True, False), _
        i_blnAuthoringGroupHHT
        
    p_RemoveNullTopicURIs u_DOMNodeEntries

End Sub

Private Sub p_AddChild( _
    ByRef u_DOMNodeParent As MSXML2.IXMLDOMElement, _
    ByRef i_DOMNode As MSXML2.IXMLDOMNode _
)

    Dim DOMNodeList As MSXML2.IXMLDOMNodeList
    Dim DOMDocument As MSXML2.DOMDocument
    Dim strQuery As String
    Dim intOrderUnderParent As Long
    
    intOrderUnderParent = XMLGetAttribute(i_DOMNode, HHT_orderunderparent_C)
    
    strQuery = "child::TAXONOMY_ENTRY[" & _
        "attribute::" & HHT_orderunderparent_C & _
        " > " & intOrderUnderParent & "]"
        
    Set DOMDocument = u_DOMNodeParent.ownerDocument
    DOMDocument.setProperty "SelectionLanguage", "XPath"
    
    Set DOMNodeList = u_DOMNodeParent.selectNodes(strQuery)
    
    If (DOMNodeList.length <> 0) Then
        u_DOMNodeParent.insertBefore i_DOMNode, DOMNodeList(0)
    Else
        u_DOMNodeParent.appendChild i_DOMNode
    End If

End Sub

Public Function GetTaxonomyInXml() As MSXML2.IXMLDOMNode
    
    Dim rs As ADODB.Recordset
    Dim strQuery As String
    Dim DOMDoc As MSXML2.DOMDocument
    Dim DOMNode As MSXML2.IXMLDOMNode
    Dim Element As MSXML2.IXMLDOMElement
    Dim dictTaxonomy As Scripting.Dictionary
    Dim intTID As Long
    Dim intParentTID As Long
    Dim vntKey As Variant
    
    CheckDatabaseVersion
    
    Set DOMDoc = New MSXML2.DOMDocument
    Set DOMNode = HhtPreamble(DOMDoc, True)
    Set dictTaxonomy = New Scripting.Dictionary
    
    Set rs = New ADODB.Recordset

    strQuery = "" & _
        "SELECT * " & _
        "FROM Taxonomy " & _
        "ORDER BY ParentTID, OrderUnderParent"
        
    rs.Open strQuery, g_cnn, adOpenForwardOnly, adLockPessimistic
    
    Do While (Not rs.EOF)
        Set Element = p_CreateTaxonomyElement(DOMDoc, rs)
        dictTaxonomy.Add rs("TID").Value, Array(rs("ParentTID").Value, Element)
        p_RaiseEventAndLookForCancel "Reading title: " & rs("ENUTitle")
        rs.MoveNext
    Loop
    
    For Each vntKey In dictTaxonomy.Keys
        intParentTID = dictTaxonomy(vntKey)(0)
        
        If (vntKey = ROOT_TID_C) Then
            GoTo LForEnd
        End If
        
        If (Not dictTaxonomy.Exists(intParentTID)) Then
            GoTo LForEnd
        End If
        
        Set Element = dictTaxonomy(intParentTID)(1)
        Element.appendChild dictTaxonomy(vntKey)(1)
LForEnd:
    Next
    
    If (dictTaxonomy.Exists(ROOT_TID_C)) Then
        DOMNode.appendChild dictTaxonomy(ROOT_TID_C)(1)
    End If
    
    Set GetTaxonomyInXml = DOMDoc

End Function

Public Sub Move( _
    ByVal i_intTID As Long, _
    ByVal i_intRefTID As Long, _
    ByVal i_blnAbove As Boolean, _
    ByVal i_dtmReadTime As Date, _
    ByRef o_intOrderUnderParent As Long, _
    Optional ByVal i_intAuthoringGroup As Long = INVALID_ID_C _
)

    On Error GoTo LErrorHandler
    g_cnn.BeginTrans

    Dim rsLock As ADODB.Recordset
    Dim rs As ADODB.Recordset
    Dim intOrderUnderParent As Long
    Dim intParentTID As Long
    Dim intAuthoringGroup As Long
    
    CheckDatabaseVersion
    LockTable LOCK_TABLE_TAXONOMY, rsLock
    
    Set rs = New ADODB.Recordset
    GetNodeDetails i_intTID, rs
    
    If (rs.EOF) Then
        GoTo LEnd
    End If
    
    CheckForSameAuthoringGroup rs("AuthoringGroup"), i_intAuthoringGroup
    
    If (i_dtmReadTime <> 0) Then
        If (i_dtmReadTime <> rs("ModifiedTime")) Then
            ' Someone else has modified this Node since caller last read it.
            Err.Raise errNodeOrTopicAlreadyModified
        End If
    End If

    If (p_RefNodeIsADescendent(i_intTID, i_intRefTID)) Then
        Err.Raise errRefNodeCannotBeDescendent
    End If
    
    p_GetNewOrderAndParentTID i_intTID, i_intRefTID, i_blnAbove, intOrderUnderParent, _
        intParentTID
    
    If ((intParentTID = rs("ParentTID")) And _
        (intOrderUnderParent = rs("OrderUnderParent"))) Then
        ' Nothing has changed
        GoTo LEnd
    End If
        
    If (i_intAuthoringGroup = INVALID_ID_C) Then
        intAuthoringGroup = g_clsParameters.AuthoringGroup
    Else
        intAuthoringGroup = i_intAuthoringGroup
    End If

    rs("ModifiedTime") = Now
    rs("Username") = g_strUserName
    rs("ParentTID") = intParentTID
    rs("OrderUnderParent") = intOrderUnderParent
    rs("AuthoringGroup") = intAuthoringGroup
    rs.Update
    
    o_intOrderUnderParent = intOrderUnderParent
    
LEnd:

    g_cnn.CommitTrans
    Exit Sub
    
LErrorHandler:

    g_cnn.RollbackTrans
    Err.Raise Err.Number, Err.Source, Err.Description

End Sub

Public Sub MoveInto( _
    ByVal i_intTID As Long, _
    ByVal i_intParentTID As Long, _
    ByVal i_dtmReadTime As Date, _
    ByRef o_intOrderUnderParent As Long _
)

    On Error GoTo LErrorHandler
    g_cnn.BeginTrans

    Dim rsLock As ADODB.Recordset
    Dim rs As ADODB.Recordset
    Dim rsParent As ADODB.Recordset
    Dim intOrderUnderParent As Long
    
    CheckDatabaseVersion
    LockTable LOCK_TABLE_TAXONOMY, rsLock
    
    Set rs = New ADODB.Recordset
    GetNodeDetails i_intTID, rs
    
    If (rs.EOF) Then
        GoTo LEnd
    End If
    
    CheckForSameAuthoringGroup rs("AuthoringGroup")

    If (i_dtmReadTime <> 0) Then
        If (i_dtmReadTime <> rs("ModifiedTime")) Then
            ' Someone else has modified this Node since caller last read it.
            Err.Raise errNodeOrTopicAlreadyModified
        End If
    End If
    
    If (i_intParentTID = rs("ParentTID")) Then
        ' Nothing has changed
        GoTo LEnd
    End If

    If (p_RefNodeIsADescendent(i_intTID, i_intParentTID)) Then
        Err.Raise errRefNodeCannotBeDescendent
    End If
    
    Set rsParent = New ADODB.Recordset
    GetNodeDetails i_intParentTID, rsParent
    
    If (rsParent("Leaf")) Then
        Err.Raise errParentCannotBeLeaf
    End If
    
    intOrderUnderParent = p_GetNewOrderForLastChild(i_intParentTID)
    
    rs("ModifiedTime") = Now
    rs("Username") = g_strUserName
    rs("ParentTID") = i_intParentTID
    rs("OrderUnderParent") = intOrderUnderParent
    rs("AuthoringGroup") = g_clsParameters.AuthoringGroup
    rs.Update
    
    o_intOrderUnderParent = intOrderUnderParent
    
LEnd:

    g_cnn.CommitTrans
    Exit Sub
    
LErrorHandler:

    g_cnn.RollbackTrans
    Err.Raise Err.Number, Err.Source, Err.Description

End Sub

Public Sub CreateTaxonomyEntries( _
    ByRef u_DOMNode As MSXML2.IXMLDOMNode, _
    ByVal i_intParentTID As Long, _
    ByVal i_blnFast As Boolean _
)

    Dim rsLock As ADODB.Recordset
    
    LockTable LOCK_TABLE_TAXONOMY, rsLock
    
    p_CreateTaxonomyEntries u_DOMNode, i_intParentTID, i_blnFast

End Sub

Private Sub p_CreateTaxonomyEntries( _
    ByRef u_DOMNode As MSXML2.IXMLDOMNode, _
    ByVal i_intParentTID As Long, _
    ByVal i_blnFast As Boolean _
)

    Dim rsLock As ADODB.Recordset
    Dim strTitle As String
    Dim strDescription As String
    Dim intType As Long
    Dim intNavModel As Long
    Dim strURI As String
    Dim strIconURI As String
    Dim intSKUs As Long
    Dim blnLeaf As Boolean
    Dim strLocInclude As String
    Dim blnVisible As Boolean
    Dim blnSubSite As Boolean
    Dim strKeywords As String
    Dim strBaseFile As String
    Dim strEntry As String
    Dim DOMNode As MSXML2.IXMLDOMNode
    Dim ModifiedDOMNodes As MSXML2.IXMLDOMNode
    Dim DOMNodeChild As MSXML2.IXMLDOMNode
    Dim intTID As Long

    strTitle = XMLGetAttribute(u_DOMNode, HHT_TITLE_C)
    strDescription = XMLGetAttribute(u_DOMNode, HHT_DESCRIPTION_C)
    intType = XMLGetAttribute(u_DOMNode, HHT_TYPE_C)
    intNavModel = NavModelNumber(XMLGetAttribute(u_DOMNode, HHT_NAVIGATIONMODEL_C))
    strURI = XMLGetAttribute(u_DOMNode, HHT_URI_C)
    strIconURI = XMLGetAttribute(u_DOMNode, HHT_ICONURI_C)
    intSKUs = XMLGetAttribute(u_DOMNode, HHT_skus_C)
    blnLeaf = XMLGetAttribute(u_DOMNode, HHT_leaf_C)
    strLocInclude = XMLGetAttribute(u_DOMNode, HHT_locinclude_C)
    blnVisible = XMLGetAttribute(u_DOMNode, HHT_VISIBLE_C)
    blnSubSite = XMLGetAttribute(u_DOMNode, HHT_SUBSITE_C)
    strKeywords = XMLGetAttribute(u_DOMNode, HHT_keywords_C)
    strBaseFile = XMLGetAttribute(u_DOMNode, HHT_basefile_C)
    strEntry = XMLGetAttribute(u_DOMNode, HHT_ENTRY_C)
    
    p_RaiseEventAndLookForCancel "Creating Title: " & strTitle
    DoEvents
    
    If (i_blnFast) Then
        p_CreateFast False, strTitle, strDescription, intType, intNavModel, strURI, strIconURI, _
            intSKUs, blnLeaf, i_intParentTID, strLocInclude, blnVisible, blnSubSite, _
            strKeywords, strBaseFile, "", strEntry, u_DOMNode.ownerDocument, DOMNode, _
            INVALID_ID_C
    Else
        p_Create False, strTitle, strDescription, intType, intNavModel, strURI, strIconURI, _
            intSKUs, blnLeaf, i_intParentTID, strLocInclude, blnVisible, blnSubSite, _
            strKeywords, strBaseFile, "", strEntry, u_DOMNode.ownerDocument, DOMNode, _
            ModifiedDOMNodes
    End If
    
    XMLCopyAttributes DOMNode, u_DOMNode
    intTID = XMLGetAttribute(DOMNode, HHT_tid_C)
    
    If (Not u_DOMNode.firstChild Is Nothing) Then
        For Each DOMNodeChild In u_DOMNode.childNodes
                p_CreateTaxonomyEntries DOMNodeChild, intTID, i_blnFast
        Next
    End If

End Sub

Private Sub p_CreateURIKeywordsTable()

    Dim oc As ADOX.Catalog
    Dim strTable As String
    Dim tbl As ADOX.Table
    Dim col As ADOX.Column
    Dim idx As ADOX.Index
    
    Set oc = New ADOX.Catalog
    Set oc.ActiveConnection = g_cnn
    
    strTable = "URIKeywords"
    
    If (Not TableExists(oc, strTable)) Then
    
        Set tbl = New ADOX.Table
        
        With tbl
            
            .Name = strTable
            Set .ParentCatalog = oc
            
            .Columns.Append "URI", adVarWChar
        
            Set col = New ADOX.Column
            With col
                Set .ParentCatalog = oc
                .Name = "MergedKeywords"
                .Type = adLongVarWChar ' Memo field
                .Properties("Jet OLEDB:Allow Zero Length").Value = True
            End With
            .Columns.Append col
            
            Set idx = New ADOX.Index
            With idx
                .Name = "URI"
                .Columns.Append "URI"
                .PrimaryKey = True
            End With
            .Indexes.Append idx
        
        End With
        
        oc.Tables.Append tbl
        Set oc = Nothing
    
    End If
    
End Sub

Public Sub PropagateKeywords()

    On Error GoTo LErrorHandler
    g_cnn.BeginTrans
    
    Dim rsLock As ADODB.Recordset
    Dim oc As ADOX.Catalog
    Dim rs As ADODB.Recordset
    Dim strQuery As String
    Dim strURI As String
    Dim strKeywords As String
    Dim dictURIs As Scripting.Dictionary
    Dim vntKey As Variant
    
    CheckDatabaseVersion
    LockTable LOCK_TABLE_TAXONOMY, rsLock
    
    Set rs = New ADODB.Recordset
    
    strQuery = "" & _
        "SELECT * " & _
        "FROM Taxonomy " & _
        "WHERE (ContentURI <> """")" & _
        "ORDER BY TID "
        
    rs.Open strQuery, g_cnn, adOpenStatic, adLockPessimistic
    
    Set dictURIs = New Scripting.Dictionary
    
    Do While (Not rs.EOF)
        
        DoEvents
        
        strURI = Trim$(LCase$(rs("ContentURI") & ""))
        strKeywords = rs("Keywords") & ""
        
        If (dictURIs.Exists(strURI)) Then
            strKeywords = p_MergeKeywords(dictURIs(strURI), strKeywords)
            dictURIs.Remove strURI
        End If
        
        dictURIs.Add strURI, strKeywords
        
        rs.MoveNext
        
    Loop
    
    p_CreateURIKeywordsTable
    
    rs.Close
    rs.Open "DELETE * FROM URIKeywords", g_cnn, adOpenStatic, adLockOptimistic
    rs.Open "SELECT * FROM URIKeywords", g_cnn, adOpenStatic, adLockOptimistic

    ' Create a table that shows what the Keywords should be for each URI
    For Each vntKey In dictURIs.Keys
        rs.AddNew
        rs("URI") = vntKey
        rs("MergedKeywords") = dictURIs.Item(vntKey)
        rs.Update
    Next
    
    rs.Close
    
    ' Create a table that shows the TID, Keywords pair for each row that needs to change.
    strQuery = "" & _
        "SELECT Taxonomy.TID, URIKeywords.MergedKeywords INTO TIDKeywords " & _
        "FROM " & _
        "   Taxonomy INNER JOIN URIKeywords " & _
        "   ON Taxonomy.ContentURI = URIKeywords.URI " & _
        "WHERE ((Taxonomy.ContentURI <> """") " & _
        "AND    (Taxonomy.Keywords <> URIKeywords.MergedKeywords)) "

    rs.Open strQuery, g_cnn, adOpenStatic, adLockOptimistic

    ' Change the rows that need to change.
    strQuery = "" & _
        "UPDATE " & _
        "Taxonomy INNER JOIN TIDKeywords ON Taxonomy.TID = TIDKeywords.TID " & _
        "SET " & _
        "   Taxonomy.Keywords = TIDKeywords.MergedKeywords, " & _
        "   Taxonomy.ModifiedTime = #" & Now & "#, " & _
        "   Taxonomy.Username = """ & g_strUserName & """"

    rs.Open strQuery, g_cnn, adOpenStatic, adLockPessimistic

LEnd:
        
    g_cnn.CommitTrans

    Set oc = New ADOX.Catalog
    Set oc.ActiveConnection = g_cnn

    DeleteTable oc, "URIKeywords"
    DeleteTable oc, "TIDKeywords"

    Exit Sub
    
LErrorHandler:

    g_cnn.RollbackTrans
    Err.Raise Err.Number, Err.Source, Err.Description

End Sub

Public Sub CreateFast( _
    ByVal i_strTitle As String, _
    ByVal i_strDescription As String, _
    ByVal i_intType As Long, _
    ByVal i_intNavModel As Long, _
    ByVal i_strURI As String, _
    ByVal i_strIconURI As String, _
    ByVal i_intSelectedSKUs As Long, _
    ByVal i_blnLeaf As Boolean, _
    ByVal i_intParentTID As Long, _
    ByVal i_strLocInclude As String, _
    ByVal i_blnVisible As Boolean, _
    ByVal i_blnSubSite As Boolean, _
    ByVal i_strKeywords As String, _
    ByVal i_strBaseFile As String, _
    ByVal i_strComments As String, _
    ByVal i_strEntry As String, _
    ByRef i_DOMDoc As MSXML2.DOMDocument, _
    ByRef o_DOMNode As MSXML2.IXMLDOMNode, _
    Optional ByVal i_intAuthoringGroup As Long = INVALID_ID_C _
)

    p_CreateFast True, i_strTitle, i_strDescription, i_intType, i_intNavModel, i_strURI, _
        i_strIconURI, i_intSelectedSKUs, i_blnLeaf, i_intParentTID, i_strLocInclude, _
        i_blnVisible, i_blnSubSite, i_strKeywords, i_strBaseFile, _
        i_strComments, i_strEntry, i_DOMDoc, o_DOMNode, i_intAuthoringGroup

End Sub

Private Sub p_CreateFast( _
    ByVal i_blnLock As Boolean, _
    ByVal i_strTitle As String, _
    ByVal i_strDescription As String, _
    ByVal i_intType As Long, _
    ByVal i_intNavModel As Long, _
    ByVal i_strURI As String, _
    ByVal i_strIconURI As String, _
    ByVal i_intSelectedSKUs As Long, _
    ByVal i_blnLeaf As Boolean, _
    ByVal i_intParentTID As Long, _
    ByVal i_strLocInclude As String, _
    ByVal i_blnVisible As Boolean, _
    ByVal i_blnSubSite As Boolean, _
    ByVal i_strKeywords As String, _
    ByVal i_strBaseFile As String, _
    ByVal i_strComments As String, _
    ByVal i_strEntry As String, _
    ByRef i_DOMDoc As MSXML2.DOMDocument, _
    ByRef o_DOMNode As MSXML2.IXMLDOMNode, _
    ByVal i_intAuthoringGroup As Long _
)

    ' Same as Create, except that we skip the following:
    '   p_ValidateTitle
    '   p_ValidateDescription
    '   FormatKeywordsForTaxonomy
    '   p_GetMergedKeywords
    '   p_PropagateKeywords

    Dim rsLock As ADODB.Recordset
    Dim rs As ADODB.Recordset
    Dim strQuery As String
    Dim intOrderUnderParent As Long
    Dim intAuthoringGroup As Long
    Dim strEntry As String
    Dim strKeywords As String
    
    CheckDatabaseVersion
    If (i_blnLock) Then
        LockTable LOCK_TABLE_TAXONOMY, rsLock
    End If
    
    Set rs = New ADODB.Recordset
    
    strQuery = "" & _
        "SELECT * " & _
        "FROM Taxonomy "
        
    rs.Open strQuery, g_cnn, adOpenStatic, adLockPessimistic
    
    If (rs.RecordCount > 0) Then
        rs.MoveLast
    End If
    
    intOrderUnderParent = p_GetNewOrderForLastChild(i_intParentTID)
    
    If (i_intAuthoringGroup = INVALID_ID_C) Then
        intAuthoringGroup = g_clsParameters.AuthoringGroup
    Else
        intAuthoringGroup = i_intAuthoringGroup
    End If
        
    If (Not i_blnLeaf) Then
        strEntry = Mangle(i_strEntry & "")
        
        If (strEntry = "") Then
            strEntry = Mangle(i_strTitle)
        End If
    Else
        strKeywords = i_strKeywords & ""
    End If
    
    If (Len(i_strDescription) > 255) Then
        WriteLog "Truncating Description"
        WriteLog "URI: " & i_strURI
        WriteLog "Description: " & i_strDescription
        WriteLog ""
        i_strDescription = Mid$(i_strDescription, 1, 255)
    End If

    rs.AddNew
    rs("ModifiedTime") = Now
    rs("Username") = g_strUserName
    ' As a fix for a weird "multiple-step OLE DB operation" error, I have appended & "" to
    ' all strings.
    rs("Comments") = i_strComments & ""
    rs("ENUTitle") = i_strTitle & ""
    rs("ENUDescription") = i_strDescription & ""
    rs("Type") = i_intType
    
    If (Not i_blnLeaf) Then
        rs("NavigationModel") = i_intNavModel
    End If
    
    rs("ContentURI") = i_strURI & ""
    rs("IconURI") = i_strIconURI & ""
    rs("SKUs") = i_intSelectedSKUs
    rs("ParentTID") = i_intParentTID
    rs("Leaf") = i_blnLeaf
    rs("BaseFile") = i_strBaseFile & ""
    rs("LocInclude") = i_strLocInclude & ""
    rs("Visible") = i_blnVisible
    rs("SubSite") = i_blnSubSite
    rs("Keywords") = strKeywords
    rs("OrderUnderParent") = intOrderUnderParent
    rs("AuthoringGroup") = intAuthoringGroup
    rs("Entry") = strEntry
    rs.Update
    
    Set o_DOMNode = p_CreateTaxonomyElement(i_DOMDoc, rs)

End Sub

Private Function p_GetMidOrder( _
    ByVal i_intOrder1 As Long, _
    ByVal i_intOrder2 As Long _
) As Long
    
    ' Never return i_intOrder1 or i_intOrder2.
    
    If (i_intOrder2 <= i_intOrder1 + 1) Then
        Err.Raise errOutOfOrderingNumbers
    End If
    
    ' i_intOrder1  i_intOrder2  p_GetMidOrder
    ' 5            7            6
    ' 5            8            7

    p_GetMidOrder = i_intOrder1 + (i_intOrder2 - i_intOrder1 + 1) \ 2

End Function

Private Function p_GetNextOrder( _
    ByVal i_intOrder As Long _
) As Long
    
    ' Never return i_intOrder itself.
    
    Dim intOrder1 As Long
    Dim intOrder2 As Long

    If (i_intOrder = 0) Then
        p_GetNextOrder = PREFERRED_ORDER_DELTA_C
        Exit Function
    End If
    
    If (i_intOrder = MAX_ORDER_C) Then
        Err.Raise errOutOfOrderingNumbers
    End If
    
    intOrder1 = i_intOrder + PREFERRED_ORDER_DELTA_C
    
    ' i_intOrder   MAX_ORDER_C  intOrder2
    ' 5            6            6
    ' 5            7            6
    ' 5            8            7
    intOrder2 = i_intOrder + (MAX_ORDER_C - i_intOrder + 1) \ 2
    
    If (intOrder1 <= intOrder2) Then
        p_GetNextOrder = intOrder1
    Else
        p_GetNextOrder = intOrder2
    End If

End Function

Private Sub p_GetNewOrderAndParentTID( _
    ByRef i_intTID As Long, _
    ByRef i_intRefTID As Long, _
    ByVal i_blnAbove As Boolean, _
    ByRef o_intOrderUnderParent As Long, _
    ByRef o_intParentTID As Long _
)

    Dim strQuery As String
    Dim rs As ADODB.Recordset
    Dim strSign As String
    Dim strOrdering As String
    Dim intRefOrderUnderParent As Long
    
    Set rs = New ADODB.Recordset
    
    strQuery = "" & _
        "SELECT * " & _
        "FROM Taxonomy " & _
        "WHERE (TID = " & i_intRefTID & ")"
        
    rs.Open strQuery, g_cnn, adOpenStatic, adLockReadOnly
    
    If (rs.EOF) Then
        Err.Raise errDoesNotExist
    End If
    
    o_intParentTID = rs("ParentTID")
    
    If (i_blnAbove) Then
        strSign = "<"
        strOrdering = "DESC"
    Else
        strSign = ">"
    End If
    
    intRefOrderUnderParent = rs("OrderUnderParent")
    
    strQuery = "" & _
        "SELECT * " & _
        "FROM Taxonomy " & _
        "WHERE ((ParentTID = " & rs("ParentTID") & ") " & _
        "AND (OrderUnderParent " & strSign & intRefOrderUnderParent & "))" & _
        "ORDER BY OrderUnderParent " & strOrdering

    rs.Close
    rs.Open strQuery, g_cnn, adOpenStatic, adLockReadOnly
    
    If (rs.EOF) Then
        If (i_blnAbove) Then
            o_intOrderUnderParent = p_GetMidOrder(0, intRefOrderUnderParent)
        Else
            o_intOrderUnderParent = p_GetNextOrder(intRefOrderUnderParent)
        End If
        Exit Sub
    End If
    
    If (rs("TID") = i_intTID) Then
        o_intOrderUnderParent = rs("OrderUnderParent")
        Exit Sub
    End If
        
    If (i_blnAbove) Then
        o_intOrderUnderParent = p_GetMidOrder(rs("OrderUnderParent"), intRefOrderUnderParent)
    Else
        o_intOrderUnderParent = p_GetMidOrder(intRefOrderUnderParent, rs("OrderUnderParent"))
    End If

End Sub

Private Function p_GetNewOrderForLastChild( _
    ByRef i_intTID As Long _
) As Long

    Dim strQuery As String
    Dim rs As ADODB.Recordset
    Dim intOrderOfLastChild As Long
    
    Set rs = New ADODB.Recordset
    
    strQuery = "" & _
        "SELECT Max(OrderUnderParent) as MaxOrderUnderParent " & _
        "FROM Taxonomy " & _
        "WHERE (ParentTID=" & i_intTID & ")"
        
    rs.Open strQuery, g_cnn, adOpenStatic, adLockReadOnly
    
    If (Not rs.EOF) Then
        If (Not IsNull(rs("MaxOrderUnderParent"))) Then
            intOrderOfLastChild = rs("MaxOrderUnderParent")
        End If
    End If
    
    p_GetNewOrderForLastChild = p_GetNextOrder(intOrderOfLastChild)

End Function

Public Sub Create( _
    ByVal i_strTitle As String, _
    ByVal i_strDescription As String, _
    ByVal i_intType As Long, _
    ByVal i_intNavModel As Long, _
    ByVal i_strURI As String, _
    ByVal i_strIconURI As String, _
    ByVal i_intSelectedSKUs As Long, _
    ByVal i_blnLeaf As Boolean, _
    ByVal i_intParentTID As Long, _
    ByVal i_strLocInclude As String, _
    ByVal i_blnVisible As Boolean, _
    ByVal i_blnSubSite As Boolean, _
    ByVal i_strKeywords As String, _
    ByVal i_strBaseFile As String, _
    ByVal i_strComments As String, _
    ByVal i_strEntry As String, _
    ByRef i_DOMDoc As MSXML2.DOMDocument, _
    ByRef o_DOMNode As MSXML2.IXMLDOMNode, _
    ByRef o_ModifiedDOMNodes As MSXML2.IXMLDOMNode _
)

    p_Create True, i_strTitle, i_strDescription, i_intType, i_intNavModel, i_strURI, _
        i_strIconURI, i_intSelectedSKUs, i_blnLeaf, i_intParentTID, i_strLocInclude, _
        i_blnVisible, i_blnSubSite, i_strKeywords, i_strBaseFile, _
        i_strComments, i_strEntry, i_DOMDoc, o_DOMNode, o_ModifiedDOMNodes

End Sub

Private Sub p_Create( _
    ByVal i_blnLock As Boolean, _
    ByVal i_strTitle As String, _
    ByVal i_strDescription As String, _
    ByVal i_intType As Long, _
    ByVal i_intNavModel As Long, _
    ByVal i_strURI As String, _
    ByVal i_strIconURI As String, _
    ByVal i_intSelectedSKUs As Long, _
    ByVal i_blnLeaf As Boolean, _
    ByVal i_intParentTID As Long, _
    ByVal i_strLocInclude As String, _
    ByVal i_blnVisible As Boolean, _
    ByVal i_blnSubSite As Boolean, _
    ByVal i_strKeywords As String, _
    ByVal i_strBaseFile As String, _
    ByVal i_strComments As String, _
    ByVal i_strEntry As String, _
    ByRef i_DOMDoc As MSXML2.DOMDocument, _
    ByRef o_DOMNode As MSXML2.IXMLDOMNode, _
    ByRef o_ModifiedDOMNodes As MSXML2.IXMLDOMNode _
)

    Dim rsLock As ADODB.Recordset
    Dim rs As ADODB.Recordset
    Dim strQuery As String
    Dim intTID As Long
    Dim strKeywords As String
    Dim intOrderUnderParent As Long
    Dim strEntry As String
    
    CheckDatabaseVersion
    
    If (i_blnLock) Then
        LockTable LOCK_TABLE_TAXONOMY, rsLock
    End If
    
    ' Do some validation to see if the Title is acceptable.
    
    p_ValidateTitle i_strTitle
    
    ' Do some validation to see if the Description is acceptable.
    
    p_ValidateDescription i_strDescription
    
    ' Convert i_strKeywords into canonical format
    
    strKeywords = FormatKeywordsForTaxonomy(i_strKeywords)
    
    strKeywords = p_GetMergedKeywords(i_strURI, i_strKeywords, "")
    
    ' Create a new record in the database
    
    intOrderUnderParent = p_GetNewOrderForLastChild(i_intParentTID)
    
    Set rs = New ADODB.Recordset
    
    strQuery = "" & _
        "SELECT * " & _
        "FROM Taxonomy "
        
    rs.Open strQuery, g_cnn, adOpenStatic, adLockPessimistic
    
    If (rs.RecordCount > 0) Then
        rs.MoveLast
    End If
    
    If (Not i_blnLeaf) Then
        strEntry = Mangle(i_strEntry & "")
        
        If (strEntry = "") Then
            strEntry = Mangle(i_strTitle)
        End If
        strKeywords = ""
    End If
    
    rs.AddNew
    rs("ModifiedTime") = Now
    rs("Username") = g_strUserName
    ' & "" is a workaround for a weird OLEDB error when setting Comments to an empty string
    rs("Comments") = i_strComments & ""
    rs("ENUTitle") = i_strTitle
    rs("ENUDescription") = i_strDescription
    rs("Type") = i_intType
    
    If (Not i_blnLeaf) Then
        rs("NavigationModel") = i_intNavModel
    End If
    
    rs("ContentURI") = i_strURI
    rs("IconURI") = i_strIconURI
    rs("SKUs") = i_intSelectedSKUs
    rs("ParentTID") = i_intParentTID
    rs("Leaf") = i_blnLeaf
    rs("BaseFile") = i_strBaseFile
    rs("LocInclude") = i_strLocInclude
    rs("Visible") = i_blnVisible
    rs("SubSite") = i_blnSubSite
    rs("Keywords") = strKeywords
    rs("OrderUnderParent") = intOrderUnderParent
    rs("AuthoringGroup") = g_clsParameters.AuthoringGroup
    rs("Entry") = strEntry
    rs.Update
    
    Set o_DOMNode = p_CreateTaxonomyElement(i_DOMDoc, rs)
    
    p_PropagateKeywords i_strURI, strKeywords, o_ModifiedDOMNodes

End Sub

Public Sub SetKeywords( _
    ByVal i_intTID As Long, _
    ByVal i_strURI As String, _
    ByVal i_strKeywords As String, _
    ByVal i_dtmReadTime As Date, _
    ByRef i_DOMDoc As MSXML2.DOMDocument, _
    ByRef o_DOMNode As MSXML2.IXMLDOMNode, _
    ByRef o_ModifiedDOMNodes As MSXML2.IXMLDOMNode _
)
    
    On Error GoTo LErrorHandler
    g_cnn.BeginTrans
    
    Dim rsLock As ADODB.Recordset
    Dim rs As ADODB.Recordset
    
    CheckDatabaseVersion
    LockTable LOCK_TABLE_TAXONOMY, rsLock

    ' Does the record exist?
    
    Set rs = New ADODB.Recordset
    GetNodeDetails i_intTID, rs
    
    If (rs.EOF) Then
        GoTo LEnd
    End If
    
    CheckForSameAuthoringGroup rs("AuthoringGroup")
        
    If (i_dtmReadTime <> 0) Then
        If (i_dtmReadTime <> rs("ModifiedTime")) Then
            ' Someone else has modified this Node since caller last read it.
            Err.Raise errNodeOrTopicAlreadyModified
        End If
    End If
    
    rs("ModifiedTime") = Now
    rs("Username") = g_strUserName
    rs("Keywords") = i_strKeywords
    rs.Update
    
    Set o_DOMNode = p_CreateTaxonomyElement(i_DOMDoc, rs)
    
    p_PropagateKeywords i_strURI, i_strKeywords, o_ModifiedDOMNodes

LEnd:

    g_cnn.CommitTrans
    Exit Sub
    
LErrorHandler:

    g_cnn.RollbackTrans
    Err.Raise Err.Number, Err.Source, Err.Description
    
End Sub

Public Sub Update( _
    ByVal i_intTID As Long, _
    ByVal i_strTitle As String, _
    ByVal i_strDescription As String, _
    ByVal i_intType As Long, _
    ByVal i_intNavModel As Long, _
    ByVal i_strURI As String, _
    ByVal i_strIconURI As String, _
    ByVal i_intSelectedSKUs As Long, _
    ByVal i_strLocInclude As String, _
    ByVal i_blnVisible As Boolean, _
    ByVal i_blnSubSite As Boolean, _
    ByVal i_strKeywords As String, _
    ByVal i_strDeletedKeywords As String, _
    ByVal i_strComments As String, _
    ByVal i_strEntry As String, _
    ByVal i_dtmReadTime As Date, _
    ByRef i_DOMDoc As MSXML2.DOMDocument, _
    ByRef o_DOMNode As MSXML2.IXMLDOMNode, _
    ByRef o_ModifiedDOMNodes As MSXML2.IXMLDOMNode _
)
    
    On Error GoTo LErrorHandler
    g_cnn.BeginTrans
    
    Dim rsLock As ADODB.Recordset
    Dim rs As ADODB.Recordset
    Dim strKeywords As String
    Dim strEntry As String
    
    CheckDatabaseVersion
    LockTable LOCK_TABLE_TAXONOMY, rsLock
    
    ' Do some validation to see if the Title is acceptable.
    
    p_ValidateTitle i_strTitle
    
    ' Do some validation to see if the Description is acceptable.
    
    p_ValidateDescription i_strDescription
    
    ' Convert i_strKeywords into canonical format
    
    strKeywords = FormatKeywordsForTaxonomy(i_strKeywords)
    
    strKeywords = p_GetMergedKeywords(i_strURI, i_strKeywords, i_strDeletedKeywords)

    ' Does the record exist?
    
    Set rs = New ADODB.Recordset
    GetNodeDetails i_intTID, rs
    
    If (rs.EOF) Then
        GoTo LEnd
    End If
    
    CheckForSameAuthoringGroup rs("AuthoringGroup")
        
    If (i_dtmReadTime <> 0) Then
        If (i_dtmReadTime <> rs("ModifiedTime")) Then
            ' Someone else has modified this Node since caller last read it.
            Err.Raise errNodeOrTopicAlreadyModified
        End If
    End If
    
    If (Not rs("Leaf")) Then
        strEntry = Mangle(i_strEntry & "")
        
        If (strEntry = "") Then
            strEntry = Mangle(i_strTitle)
        End If
        
        strKeywords = ""
    End If

    rs("ModifiedTime") = Now
    rs("Username") = g_strUserName
    rs("ENUTitle") = i_strTitle
    rs("ENUDescription") = i_strDescription
    rs("Type") = i_intType
    
    If (Not rs("Leaf")) Then
        rs("NavigationModel") = i_intNavModel
    End If
    
    rs("ContentURI") = i_strURI
    rs("IconURI") = i_strIconURI
    ' & "" is a workaround for a weird OLEDB error when setting Comments to an empty string
    rs("Comments") = i_strComments & ""
    rs("SKUs") = i_intSelectedSKUs
    rs("LocInclude") = i_strLocInclude
    rs("Visible") = i_blnVisible
    rs("SubSite") = i_blnSubSite
    rs("Keywords") = strKeywords
    rs("AuthoringGroup") = g_clsParameters.AuthoringGroup
    rs("Entry") = strEntry
    rs.Update
    
    Set o_DOMNode = p_CreateTaxonomyElement(i_DOMDoc, rs)
    
    p_PropagateKeywords i_strURI, strKeywords, o_ModifiedDOMNodes

LEnd:

    g_cnn.CommitTrans
    Exit Sub
    
LErrorHandler:

    g_cnn.RollbackTrans
    Err.Raise Err.Number, Err.Source, Err.Description
    
End Sub

Private Sub p_DeleteDescendents( _
    ByVal i_intTID As Long _
)

    On Error Resume Next
    
    Dim rs As ADODB.Recordset
    Dim strQuery As String
    Dim intTID As Long

    Set rs = New ADODB.Recordset

    If (intTID <> ROOT_TID_C) Then
        p_RaiseEventAndLookForCancel "Deleting TID " & i_intTID
        strQuery = "DELETE * FROM Taxonomy WHERE (TID = " & i_intTID & ")"
        rs.Open strQuery, g_cnn, adOpenStatic, adLockPessimistic
    End If
    
    strQuery = "" & _
        "SELECT * " & _
        "FROM Taxonomy " & _
        "WHERE (ParentTID=" & i_intTID & ")"
    rs.Open strQuery, g_cnn, adOpenStatic, adLockPessimistic
    
    Do While (Not rs.EOF)
        intTID = rs("TID")
        If (intTID <> ROOT_TID_C) Then
            p_DeleteDescendents intTID
        End If
        ' I keep on getting errors on MoveNext saying that the record has been deleted.
        ' If I continue, things work. Hence the On Error Resume Next above.
        rs.MoveNext
    Loop

End Sub

Public Sub Delete( _
    ByVal i_intTID As Long, _
    ByVal i_dtmReadTime As Date _
)
    
    On Error GoTo LErrorHandler
    g_cnn.BeginTrans

    Dim rsLock As ADODB.Recordset
    Dim rs As ADODB.Recordset
            
    CheckDatabaseVersion
    LockTable LOCK_TABLE_TAXONOMY, rsLock

    Set rs = New ADODB.Recordset
    GetNodeDetails i_intTID, rs
    
    ' Does an entry exist?
    
    If (rs.EOF) Then
        GoTo LEnd
    End If
    
    CheckForSameAuthoringGroup rs("AuthoringGroup")
        
    If (i_dtmReadTime <> 0) Then
        If (i_dtmReadTime <> rs("ModifiedTime")) Then
            ' Someone else has modified this Node since caller last read it.
            Err.Raise errNodeOrTopicAlreadyModified
        End If
    End If
    
    p_DeleteDescendents i_intTID

LEnd:

    g_cnn.CommitTrans
    Exit Sub
    
LErrorHandler:

    g_cnn.RollbackTrans
    Err.Raise Err.Number, Err.Source, Err.Description

End Sub

Private Function p_GetMergedKeywords( _
    ByRef i_strURI As String, _
    ByRef i_strKeywords As String, _
    ByRef i_strDeletedKeywords As String _
) As String
    
    Dim strURI As String
    Dim strQuery As String
    Dim rs As ADODB.Recordset
    
    p_GetMergedKeywords = i_strKeywords
    
    strURI = Trim$(i_strURI)
    
    If (strURI = "") Then
        Exit Function
    End If
    
    Set rs = New ADODB.Recordset
         
    strQuery = "" & _
        "SELECT * " & _
        "FROM Taxonomy " & _
        "WHERE (ContentURI = """ & strURI & """)"
    
    rs.Open strQuery, g_cnn, adOpenStatic, adLockReadOnly
    
    Do While (Not rs.EOF)
        p_GetMergedKeywords = p_GetMergedKeywords & rs("Keywords")
        rs.MoveNext
    Loop
    
    p_GetMergedKeywords = p_GetKeywordString(p_GetMergedKeywords, i_strDeletedKeywords)

End Function

Private Sub p_PropagateKeywords( _
    ByRef i_strURI As String, _
    ByRef i_strKeywords As String, _
    ByRef o_ModifiedDOMNodes As MSXML2.IXMLDOMNode _
)

    Dim strURI As String
    Dim strQuery As String
    Dim rs As ADODB.Recordset
    Dim intTID As Long
    Dim DOMDoc As MSXML2.DOMDocument
    Dim Node As MSXML2.IXMLDOMNode
    Dim Element As MSXML2.IXMLDOMElement
    Dim colTaxonomy As Collection
    
    Set DOMDoc = New MSXML2.DOMDocument
    Set o_ModifiedDOMNodes = HhtPreamble(DOMDoc, True)
    Set colTaxonomy = New Collection
    
    strURI = Trim$(i_strURI)
    
    If (strURI = "") Then
        Exit Sub
    End If
    
    Set rs = New ADODB.Recordset
         
    strQuery = "" & _
        "SELECT * " & _
        "FROM Taxonomy " & _
        "WHERE (ContentURI = """ & strURI & """)"
    
    rs.Open strQuery, g_cnn, adOpenStatic, adLockReadOnly
    
'    Doing this without the CollectionContainsKey check causes a weird bug.
'    This bug doesn't manifest itself if I slow things down with a Debug.Print
'    right here. Otherwise, it adds the new Records created by p_SetKeywords to
'    rs, even though rs is Static.

    Do While (Not rs.EOF)
        intTID = rs("TID")

        If (Not CollectionContainsKey(colTaxonomy, intTID)) Then
            
            colTaxonomy.Add True, CStr(intTID)

            If (rs("Keywords") <> i_strKeywords) Then
                p_SetKeywords intTID, i_strKeywords
                Set Element = p_CreateTaxonomyElement(DOMDoc, rs)
                XMLSetAttribute Element, HHT_keywords_C, i_strKeywords
                XMLSetAttribute Element, HHT_modifiedtime_C, Now
                XMLSetAttribute Element, HHT_username_C, g_strUserName
                o_ModifiedDOMNodes.appendChild Element
            End If
            
        End If

        rs.MoveNext
    Loop

End Sub

Private Sub p_SetKeywords( _
    ByVal i_intTID As Long, _
    ByRef i_strKeywords As String _
)
    
    On Error GoTo LErrorHandler
    g_cnn.BeginTrans
    
    Dim rs As ADODB.Recordset
    
    Set rs = New ADODB.Recordset
    GetNodeDetails i_intTID, rs
    
    If (rs.EOF) Then
        GoTo LEnd
    End If
    
    rs("ModifiedTime") = Now
    rs("Username") = g_strUserName
    rs("Keywords") = i_strKeywords
    rs("AuthoringGroup") = g_clsParameters.AuthoringGroup
    rs.Update

LEnd:

    g_cnn.CommitTrans
    Exit Sub
    
LErrorHandler:

    g_cnn.RollbackTrans
    Err.Raise Err.Number, Err.Source, Err.Description

End Sub

Private Function p_MergeKeywords( _
    ByRef i_strKeywords1 As String, _
    ByRef i_strKeywords2 As String _
) As String
    
    ' Assumption: KIDs in i_strKeywords1 and i_strKeywords2 are sorted.

    Dim arrKIDs1() As String
    Dim arrKIDs2() As String
    Dim intIndex1 As Long
    Dim intIndex2 As Long
    Dim intKID1 As Long
    Dim intKID2 As Long
    Dim strKeywords As String
    
    arrKIDs1 = Split(i_strKeywords1, " ")
    arrKIDs2 = Split(i_strKeywords2, " ")
    
    strKeywords = " "
    
    intIndex2 = LBound(arrKIDs2)
    
    For intIndex1 = LBound(arrKIDs1) To UBound(arrKIDs1)
        
        If (arrKIDs1(intIndex1) = "") Then
            GoTo LForEnd
        End If
        
        intKID1 = arrKIDs1(intIndex1)
        
        Do While (intIndex2 <= UBound(arrKIDs2))
            
            If (arrKIDs2(intIndex2) = "") Then
                GoTo LWhileEnd1
            End If
            
            intKID2 = arrKIDs2(intIndex2)
            
            If (intKID1 < intKID2) Then
                Exit Do
            ElseIf (intKID1 = intKID2) Then
                GoTo LWhileEnd1
            Else
                strKeywords = strKeywords & intKID2 & " "
            End If
LWhileEnd1:
            intIndex2 = intIndex2 + 1
        Loop
        
        strKeywords = strKeywords & intKID1 & " "
        
LForEnd:
        
    Next
    
    Do While (intIndex2 <= UBound(arrKIDs2))
            
        If (arrKIDs2(intIndex2) = "") Then
            GoTo LWhileEnd2
        End If
        
        intKID2 = arrKIDs2(intIndex2)
        
        strKeywords = strKeywords & intKID2 & " "

LWhileEnd2:
        
        intIndex2 = intIndex2 + 1
    Loop
    
    If (strKeywords = " ") Then
        p_MergeKeywords = ""
    Else
        p_MergeKeywords = strKeywords
    End If

End Function

Private Function p_GetKeywordString( _
    ByVal i_strKeywords As String, _
    ByVal i_strExcludedKeywords As String _
) As String

    ' Assumption: KIDs in i_strExcludedKeywords are sorted.
    ' Keywords in i_strKeywords are not sorted and may contain duplicates.

    Dim arrKIDs1() As String
    Dim arrKIDs2() As String
    Dim intIndex1 As Long
    Dim intIndex2 As Long
    Dim intKID1 As Long
    Dim intKID2 As Long
    Dim strKeywords As String
    
    strKeywords = FormatKeywordsForTaxonomy(i_strKeywords)
    
    If (strKeywords = "") Then
        p_GetKeywordString = ""
        Exit Function
    End If
    
    arrKIDs1 = Split(strKeywords, " ")
    arrKIDs2 = Split(i_strExcludedKeywords, " ")
    
    strKeywords = " "
    
    For intIndex1 = LBound(arrKIDs1) To UBound(arrKIDs1)
        
        If (arrKIDs1(intIndex1) = "") Then
            GoTo LForEnd
        End If
        
        intKID1 = arrKIDs1(intIndex1)
        
        Do While (intIndex2 <= UBound(arrKIDs2))
            
            If (arrKIDs2(intIndex2) = "") Then
                GoTo LWhileEnd
            End If
            
            intKID2 = arrKIDs2(intIndex2)
            
            If (intKID1 < intKID2) Then
                Exit Do
            ElseIf (intKID1 = intKID2) Then
                ' This keyword needs to be skipped.
                GoTo LForEnd
            End If
LWhileEnd:
            intIndex2 = intIndex2 + 1
        Loop
        
        strKeywords = strKeywords & intKID1 & " "
        
LForEnd:
        
    Next
    
    If (strKeywords = " ") Then
        p_GetKeywordString = ""
    Else
        p_GetKeywordString = strKeywords
    End If

End Function

Public Sub KeywordifyTitles( _
    ByVal i_intTID As Long _
)
    On Error GoTo LErrorHandler
    g_cnn.BeginTrans

    Dim rsLock As ADODB.Recordset
    Dim clsKeywordifier As Keywordifier
    Dim intAG As Long
    
    CheckDatabaseVersion
    LockTable LOCK_TABLE_TAXONOMY, rsLock
    
    Set clsKeywordifier = New Keywordifier
    
    intAG = g_clsParameters.AuthoringGroup
    p_KeywordifyTitles i_intTID, intAG, clsKeywordifier
    
LEnd:

    g_cnn.CommitTrans
    Exit Sub
    
LErrorHandler:

    g_cnn.RollbackTrans
    Err.Raise Err.Number, Err.Source, Err.Description

End Sub

Private Sub p_KeywordifyTitles( _
    ByVal i_intTID As Long, _
    ByVal i_intAG As Long, _
    ByRef i_clsKeywordifier As Keywordifier _
)
    Dim rs As ADODB.Recordset
    Dim strQuery As String
    Dim strTitle As String
    Dim strOldKeywords As String
    Dim strAddlKeywords As String
    Dim strNewKeywords As String
    Dim intTID As Long

    ' Does the record exist?
    
    Set rs = New ADODB.Recordset
    GetNodeDetails i_intTID, rs
    
    If (rs.EOF) Then
        Exit Sub
    End If
    
    If (rs("ContentURI") <> "") And (i_intAG = rs("AuthoringGroup") And (rs("Leaf") = True)) Then
        strOldKeywords = rs("Keywords")
        strTitle = rs("ENUTitle")
        p_RaiseEventAndLookForCancel "Creating keywords from " & strTitle
        strAddlKeywords = i_clsKeywordifier.CreateKeywordsFromTitle(strTitle)
        strNewKeywords = p_MergeKeywords(strOldKeywords, strAddlKeywords)
        
        If (strNewKeywords <> strOldKeywords) Then
            rs("Keywords") = strNewKeywords
            rs("ModifiedTime") = Now
            rs("Username") = g_strUserName
            rs.Update
        End If
    End If
    
    rs.Close
    strQuery = "" & _
        "SELECT * " & _
        "FROM Taxonomy " & _
        "WHERE (ParentTID=" & i_intTID & ")"
    rs.Open strQuery, g_cnn, adOpenStatic, adLockPessimistic
    
    Do While (Not rs.EOF)
        intTID = rs("TID")
        If (intTID <> ROOT_TID_C) Then
            p_KeywordifyTitles intTID, i_intAG, i_clsKeywordifier
        End If
        rs.MoveNext
    Loop

End Sub

Private Function p_RefNodeIsADescendent( _
    ByVal i_intTID As Long, _
    ByVal i_intRefTID As Long _
) As Boolean
    
    Dim intTID As Long
    Dim rs As ADODB.Recordset
    Dim strQuery As String
    
    CheckDatabaseVersion
    
    Set rs = New ADODB.Recordset
    
    If (i_intTID = i_intRefTID) Then
        p_RefNodeIsADescendent = True
        Exit Function
    End If
    
    p_RefNodeIsADescendent = False
    
    intTID = i_intRefTID
    
    Do While (intTID <> ROOT_TID_C)
    
        strQuery = "" & _
            "SELECT * " & _
            "FROM Taxonomy " & _
            "WHERE (TID=" & intTID & ")"
        
        rs.Open strQuery, g_cnn, adOpenForwardOnly, adLockReadOnly
        
        If (rs.EOF) Then
            Exit Function
        End If
        
        If (rs("ParentTID") = i_intTID) Then
            p_RefNodeIsADescendent = True
            Exit Function
        End If

        intTID = rs("ParentTID")
        
        rs.Close

    Loop

End Function

Private Sub p_ValidateTitle( _
    ByVal i_strTitle As String _
)
    
    If (ContainsGarbage(i_strTitle)) Then
        Err.Raise errContainsGarbageChar
    ElseIf (Len(i_strTitle) > MAX_TITLE_LENGTH_C) Then
        Err.Raise errTooLong
    End If

End Sub

Private Sub p_ValidateDescription( _
    ByVal i_strDescription As String _
)
    
    If (ContainsGarbage(i_strDescription)) Then
        Err.Raise errContainsGarbageChar
    End If

End Sub

Private Sub p_RaiseEventAndLookForCancel( _
    ByVal strStatus As String _
)
    Dim blnCancel As Boolean
    
    blnCancel = False
    RaiseEvent ReportStatus(strStatus, blnCancel)
    If (blnCancel) Then
        Err.Raise errCancel
    End If

End Sub