windows-server-2003/admin/pchealth/authtools/prodtools/applets/hhts2mdb/hhts.bas

Attribute VB_Name = "HHTs"
Option Explicit

Private Const HHT_TAXONOMY_C As String = "METADATA/TAXONOMY_ENTRIES/TAXONOMY_ENTRY"
Private Const HHT_STOPSIGN_C As String = "METADATA/STOPSIGN_ENTRIES/STOPSIGN"
Private Const HHT_STOPWORD_C As String = "METADATA/STOPWORD_ENTRIES/STOPWORD"
Private Const HHT_SYNSET_C As String = "METADATA/SYNTABLE/SYNSET"
Private Const HHT_OPERATOR_C As String = "METADATA/OPERATOR_ENTRIES/OPERATOR"
Private Const HHT_FTS_C As String = "METADATA/FTS"
Private Const HHT_SCOPE_DEFINITION_C As String = "METADATA/SCOPE_DEFINITION"
Private Const HHT_INDEX_C As String = "METADATA/INDEX"
Private Const HHT_HELPIMAGE_C As String = "METADATA/HELPIMAGE"
Private Const HHT_EXTENSION_C As String = ".HHT"

Public Sub ImportHHTs2MDB( _
    ByVal i_strFolder As String, _
    ByVal i_strDatabase As String, _
    ByVal i_intSKU As Long, _
    ByVal i_blnIgnoreTaxonomy As Boolean _
)
    On Error GoTo LError
    
    OpenDatabaseAndSetSKU i_strDatabase, i_intSKU
    p_ProcessFolder i_strFolder, i_blnIgnoreTaxonomy
    FinalizeDatabase

LEnd:

    Exit Sub

LError:

    frmMain.Output Err.Description, LOGGING_TYPE_ERROR_E
    Err.Raise Err.Number

End Sub

Private Sub p_ProcessFolder( _
    ByVal i_strFolder As String, _
    ByVal i_blnIgnoreTaxonomy As Boolean _
)
    On Error GoTo LError

    Dim FSO As Scripting.FileSystemObject
    Dim Folder As Scripting.Folder
    Dim File As Scripting.File
    Dim DOMNodeHHT As MSXML2.DOMDocument

    Set FSO = New Scripting.FileSystemObject
    Set Folder = FSO.GetFolder(i_strFolder)

    For Each File In Folder.Files
        If (InStr(1, File.Name, HHT_EXTENSION_C, vbTextCompare) <> 0) Then
            Set DOMNodeHHT = p_LoadHht(File.Path)
            frmMain.Output "Importing file " & File.Name, LOGGING_TYPE_NORMAL_E
            p_ImportHHT DOMNodeHHT, i_blnIgnoreTaxonomy
        End If
    Next

LEnd:

    Exit Sub

LError:
    
    Err.Raise E_FAIL, , Err.Description

End Sub

Private Function p_LoadHht( _
    ByVal i_strHhtFile As String _
) As MSXML2.IXMLDOMNode
    
    On Error GoTo LError
    
    Dim DOMDocHHT As MSXML2.DOMDocument
    
    Set DOMDocHHT = New MSXML2.DOMDocument
    DOMDocHHT.async = False
    DOMDocHHT.Load i_strHhtFile
    
    If (DOMDocHHT.parseError <> 0) Then
        p_DisplayParseError DOMDocHHT.parseError
        GoTo LError
    End If
    
    Set p_LoadHht = DOMDocHHT

LEnd:
    
    Exit Function

LError:
    
    Err.Raise E_FAIL, , "Unable to read HHT file " & i_strHhtFile & ": " & Err.Description

End Function

Private Sub p_ImportHHT( _
    ByVal i_DOMNodeHHT As MSXML2.IXMLDOMNode, _
    ByVal i_blnIgnoreTaxonomy As Boolean _
)
    On Error GoTo LError

    Dim DOMNodeList As MSXML2.IXMLDOMNodeList
    Dim DOMNode As MSXML2.IXMLDOMNode
    Dim strXML As String
    Dim arrNode() As String
    Dim intIndex As Long

    If (Not i_blnIgnoreTaxonomy) Then
        Set DOMNodeList = i_DOMNodeHHT.selectNodes(HHT_TAXONOMY_C)
    
        For Each DOMNode In DOMNodeList
            DoEvents
            ImportTaxonomyEntry DOMNode
        Next
    End If
        
    Set DOMNodeList = i_DOMNodeHHT.selectNodes(HHT_OPERATOR_C)
    ImportOperators DOMNodeList

    Set DOMNodeList = i_DOMNodeHHT.selectNodes(HHT_STOPSIGN_C)

    For Each DOMNode In DOMNodeList
        DoEvents
        ImportStopSign DOMNode
    Next
    
    Set DOMNodeList = i_DOMNodeHHT.selectNodes(HHT_STOPWORD_C)

    For Each DOMNode In DOMNodeList
        DoEvents
        ImportStopWord DOMNode
    Next
    
    Set DOMNodeList = i_DOMNodeHHT.selectNodes(HHT_SYNSET_C)

    For Each DOMNode In DOMNodeList
        DoEvents
        ImportSynset DOMNode
    Next
    
    ReDim arrNode(3)
    arrNode(0) = HHT_FTS_C
    arrNode(1) = HHT_SCOPE_DEFINITION_C
    arrNode(2) = HHT_INDEX_C
    arrNode(3) = HHT_HELPIMAGE_C
    
    For intIndex = LBound(arrNode) To UBound(arrNode)
        Set DOMNode = i_DOMNodeHHT.selectSingleNode(arrNode(intIndex))
        If (Not DOMNode Is Nothing) Then
            strXML = strXML & vbCrLf & DOMNode.XML
        End If
    Next
    
    SetDomFragment strXML

LEnd:

    Exit Sub

LError:
    
    Err.Raise E_FAIL, , "ImportHHT failed: " & Err.Description

End Sub

Private Sub p_DisplayParseError( _
    ByRef i_ParseError As MSXML2.IXMLDOMParseError _
)

    Dim strError As String
    
    With i_ParseError
        strError = "Error: " & .reason & _
            "Line: " & .Line & vbCrLf & _
            "Linepos: " & .linepos & vbCrLf & _
            "srcText: " & .srcText
    End With

    frmMain.Output strError, LOGGING_TYPE_ERROR_E

End Sub