VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmMain 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "QueryPrioritizer"
   ClientHeight    =   6015
   ClientLeft      =   3075
   ClientTop       =   2340
   ClientWidth     =   9855
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   6015
   ScaleWidth      =   9855
   Begin VB.CommandButton cmdBrowseQueries 
      Caption         =   "&Queries File..."
      Height          =   375
      Left            =   8625
      TabIndex        =   10
      Top             =   240
      Width           =   1125
   End
   Begin VB.TextBox txtXlsFile 
      Height          =   375
      Left            =   120
      TabIndex        =   9
      Top             =   270
      Width           =   8430
   End
   Begin VB.TextBox txtLog 
      Height          =   3600
      Left            =   30
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   8
      Top             =   1920
      Width           =   9765
   End
   Begin MSComctlLib.ProgressBar prgBar 
      Height          =   210
      Left            =   0
      TabIndex        =   7
      Top             =   5565
      Visible         =   0   'False
      Width           =   9810
      _ExtentX        =   17304
      _ExtentY        =   370
      _Version        =   393216
      Appearance      =   1
   End
   Begin MSComctlLib.StatusBar stbProgress 
      Align           =   2  'Align Bottom
      Height          =   210
      Left            =   0
      TabIndex        =   6
      Top             =   5805
      Width           =   9855
      _ExtentX        =   17383
      _ExtentY        =   370
      Style           =   1
      _Version        =   393216
      BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628} 
         NumPanels       =   1
         BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
         EndProperty
      EndProperty
   End
   Begin VB.CommandButton cmdSave 
      Caption         =   "&Output cab..."
      Height          =   375
      Left            =   8625
      TabIndex        =   5
      Top             =   1020
      Width           =   1140
   End
   Begin VB.TextBox txtSaveCab 
      Height          =   375
      Left            =   120
      TabIndex        =   4
      Top             =   1020
      Width           =   8430
   End
   Begin MSComDlg.CommonDialog dlg 
      Left            =   3480
      Top             =   1395
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.CommandButton cmdBrowse 
      Caption         =   "&Input Cab..."
      Height          =   375
      Left            =   8625
      TabIndex        =   3
      Top             =   630
      Width           =   1125
   End
   Begin VB.CommandButton cmdClose 
      Caption         =   "&Close"
      Height          =   375
      Left            =   8910
      TabIndex        =   2
      Top             =   1440
      Width           =   855
   End
   Begin VB.CommandButton cmdGo 
      Caption         =   "&OK"
      Height          =   375
      Left            =   7950
      TabIndex        =   1
      Top             =   1440
      Width           =   855
   End
   Begin VB.TextBox txtCabFile 
      Height          =   375
      Left            =   120
      TabIndex        =   0
      Top             =   645
      Width           =   8430
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
' Utility Stuff, all this could go to a COM Object and be distributed
' like this.
Private m_WsShell As IWshShell              ' Used to Shell and Wait for Sub-Processes
Private m_fso As Scripting.FileSystemObject ' For filesystem operations

Enum ProcessingState
    PROC_PROCESSING = 2 ^ 0
    PROC_STOP_PROCESSING_NOW = 2 ^ 2
    PROC_PROCESSING_STOPPED = 2 ^ 3
End Enum

Private Sub Form_Initialize()
    Set m_WsShell = CreateObject("Wscript.Shell")
    Set m_fso = New Scripting.FileSystemObject
End Sub

Private Sub Form_Load()
    
    Me.Caption = App.EXEName & ": Prioritized Keyword creation tool"
    
    WriteLog Me.Caption, False
    WriteLog String$(60, "="), False
    
    cmdGo.Default = True
    cmdClose.Cancel = True
    
'    If (Len(Trim$(Command$)) > 0) Then
'
'        If Not ParseOpts() Then
'            Unload Me
'            GoTo Common_Exit
'        End If
'
'        Me.cmdGo.Enabled = False
'        Me.Show Modal:=False
'
'        cmdGo_Click
'        cmdClose_Click
'    End If
    
Common_Exit:

End Sub


Sub WriteLog(strMsg As String, Optional ByVal bWriteToStatusBar As Boolean = True)

    With Me
        .txtLog = .txtLog & vbCrLf & strMsg
        If (bWriteToStatusBar) Then
            .stbProgress.SimpleText = strMsg
        End If
    End With
    DoEvents
    
End Sub

Sub WriteStatus(strMsg As String)

    With Me
        .stbProgress.SimpleText = strMsg
    End With
    DoEvents
    
End Sub

Private Function p_getTemplateName( _
        ByVal strBase As String, _
        Optional ByVal strFolder As String = "", _
        Optional ByVal strExt As String = "", _
        Optional ByVal strPreAmble As String = "", _
        Optional ByVal strTrailer As String = "" _
        ) As String
    Dim strCandidateFileName As String
    
    Dim lX As Long: lX = 1

    Do
        strCandidateFileName = _
            IIf(strFolder = "", m_fso.GetParentFolderName(strBase), strFolder) & "\" & _
            strPreAmble & _
            m_fso.GetBaseName(strBase) & _
            strTrailer & IIf(lX > 1, "_" & lX, "") & "." & _
            IIf(strExt = "", m_fso.GetExtensionName(strBase), strExt)
            
        lX = lX + 1
    Loop While (m_fso.FileExists(strCandidateFileName))
    
    p_getTemplateName = m_fso.GetFileName(strCandidateFileName)

End Function

Private Sub SetRunningState(ByVal bRunning As Boolean)
    With Me
        .cmdGo.Enabled = Not bRunning
        .cmdBrowse.Enabled = Not bRunning
        .cmdSave.Enabled = Not bRunning
        .txtXlsFile.Enabled = Not bRunning
        .txtSaveCab.Enabled = Not bRunning
        If (bRunning) Then
            .cmdClose.Caption = "&Stop"
        Else
            .cmdClose.Caption = "&Close"
        End If
    End With
End Sub

Private Function p_Hex2dec(ByRef strHex As String) As Long
    p_Hex2dec = CLng("&H" + strHex)
End Function

Private Function p_Percent2Ascii(ByRef strPercentHex As String) As String
    p_Percent2Ascii = ""
    On Error GoTo Common_Exit
    p_Percent2Ascii = ChrW(p_Hex2dec(Mid$(strPercentHex, 2)))
Common_Exit:

End Function

Private Function p_NormalizeUriNotation(ByRef strURI As String) As String
    p_NormalizeUriNotation = ""
    Dim pRv As String: pRv = ""
    Dim lX As Long
    lX = 1
    Do While (lX <= Len(strURI))
        Dim cThis As String
        cThis = Mid$(strURI, lX, 1)
        If (Len(strURI) - lX > 2) Then
            If (cThis = "%") Then
                Dim cChar As String
                cChar = p_Percent2Ascii(Mid$(strURI, lX, 3))
                If (Len(cChar) > 0) Then
                    pRv = pRv + cChar
                    lX = lX + 2 ' The reinitialization at the end bumps us one more up.
                Else
                    pRv = pRv + cThis
                End If
            Else
                pRv = pRv + cThis
            End If
        Else
            pRv = pRv + cThis
        End If
        lX = lX + 1
    Loop

    p_NormalizeUriNotation = pRv
Common_Exit:

End Function

Function Cab2Folder(ByVal strCabFile As String)
    Cab2Folder = ""
    ' We grab a Temporary Filename and create a folder out of it
    Dim strFolder As String
    strFolder = Environ("TEMP") + "\" + m_fso.GetTempName
    m_fso.CreateFolder strFolder
        
    ' We uncab CAB contents into the Source CAB Contents dir.
    Dim strcmd As String
    strcmd = "cabarc X " + strCabFile + " " + strFolder + "\"
    m_WsShell.Run strcmd, True, True
    
    Cab2Folder = strFolder
End Function

Sub Folder2Cab( _
        ByVal strFolder As String, _
        ByVal strCabFile As String _
    )
    
    ' We recab using the Destination directory contents
    ' cabarc -r -p -s 6144 N ..\algo.cab *.*
    If (m_fso.FileExists(strCabFile)) Then
        m_fso.DeleteFile strCabFile, Force:=True
    End If
    
    Dim strcmd As String
    strcmd = "cabarc -s 6144 N " + strCabFile + " " + strFolder + "\*.*"
    m_WsShell.Run strcmd, True, True

End Sub

' ============ END UTILITY STUFF ========================

' ============ BoilerPlate Form Code
Private Sub cmdBrowseQueries_Click()

    dlg.Filter = "All Files (*.*)|*.*|XLS Files (*.xls)|*.xls"
    dlg.FilterIndex = 2
    dlg.FileName = ""
    dlg.ShowOpen
    
    If (Len(dlg.FileName) > 0) Then
        Me.txtXlsFile = dlg.FileName
    End If

End Sub

Private Sub cmdBrowse_Click()

    dlg.Filter = "All Files (*.*)|*.*|Cab Files (*.cab)|*.cab"
    dlg.FilterIndex = 2
    dlg.FileName = ""
    dlg.ShowOpen
    
    If (Len(dlg.FileName) > 0) Then
        Me.txtCabFile = dlg.FileName
    End If

End Sub

Private Sub cmdSave_Click()
    dlg.Filter = "All Files (*.*)|*.*|Cab Files (*.cab)|*.cab"
    dlg.FilterIndex = 2
    dlg.FileName = p_getTemplateName(dlg.FileName, strTrailer:="_out")
    dlg.ShowSave
    
    If (Len(dlg.FileName) > 0) Then
        Me.txtSaveCab = dlg.FileName
    End If

End Sub

Private Sub cmdClose_Click()
    Unload Me
End Sub

Private Sub cmdGo_Click()

    Me.txtCabFile.Text = Trim$(Me.txtCabFile.Text)
    Me.txtSaveCab.Text = Trim$(Me.txtSaveCab.Text)

    Me.txtCabFile.Enabled = False
    Me.txtSaveCab.Enabled = False
    Me.cmdBrowse.Enabled = False
    Me.cmdSave.Enabled = False
    Me.cmdGo.Enabled = False
    
    If (Len(Me.txtCabFile.Text) > 0) Then
        FixCab Me.txtCabFile.Text, Me.txtSaveCab.Text
    End If
    
    Me.txtCabFile.Enabled = True
    Me.txtSaveCab.Enabled = True
    Me.cmdBrowse.Enabled = True
    Me.cmdSave.Enabled = True
    Me.cmdGo.Enabled = True
    

End Sub

Sub FixCab(ByVal strCabFile As String, ByVal strSaveCab As String)

    Dim strErrMsg As String: strErrMsg = ""

    If (Not m_fso.FileExists(strCabFile)) Then
        MsgBox "Cannot find " & strCabFile
        GoTo Common_Exit
    End If

    Dim strCabFolder As String

    prgBar.Visible = True
    stbProgress.SimpleText = "Uncabbing " & strCabFile: DoEvents
    strCabFolder = Cab2Folder(strCabFile)

    stbProgress.SimpleText = "Applying Fixes ": DoEvents
    Dim bGoodFix As Boolean
    bGoodFix = FixPerSe(strCabFolder)
    
    If (Not bGoodFix) Then
        MsgBox "Error: Fix Failed", Title:=App.EXEName
    Else
        stbProgress.SimpleText = "Recabbing " & strCabFile
        Folder2Cab strCabFolder, strSaveCab
    End If

    ' Now we delete the Temporary Folders
    prgBar.Visible = False
    stbProgress.SimpleText = "Deleting Temporary Files": DoEvents
    m_fso.DeleteFolder strCabFolder, Force:=True

Common_Exit:
    stbProgress.SimpleText = "Done" + IIf(Len(strErrMsg) > 0, " - " + strErrMsg, "")

End Sub
    
' ============= End BoilerPlate Form Code ================
Function FixPerSe(ByVal strCabFolder As String) As Boolean
    
    FixPerSe = False
    
    Dim oElem As IXMLDOMElement     ' Used for all element Creation
    
    ' We parse Package_Description.xml to find the HHT Files
    Dim oDomPkg As DOMDocument: Set oDomPkg = New DOMDocument
    Dim strPkgFile As String: strPkgFile = strCabFolder + "\package_description.xml"
    oDomPkg.async = False
    oDomPkg.Load strPkgFile
    If (oDomPkg.parseError <> 0) Then GoTo Common_Exit
    
    ' Let's check whether this fix was applied
    Dim oFixNode As IXMLDOMNode
    Set oFixNode = oDomPkg.selectSingleNode("HELPCENTERPACKAGE/package_fixes/fix[@id='5']")
    If (Not oFixNode Is Nothing) Then GoTo Common_Exit
    
    ' now, if it is the first time we run we have to create the Package_fixes
    ' NODE.
    If (oDomPkg.selectSingleNode("HELPCENTERPACKAGE/package_fixes") Is Nothing) Then
        Set oElem = oDomPkg.createElement("package_fixes")
        oDomPkg.selectSingleNode("HELPCENTERPACKAGE").appendChild oElem
    End If
    
    ' We record the fact that this fix was already applied
    Set oElem = oDomPkg.createElement("fix")
    oDomPkg.selectSingleNode("HELPCENTERPACKAGE/package_fixes").appendChild oElem
    oElem.setAttribute "id", "5"
    oElem.setAttribute "description", _
            "Removal of Topics with NO URI"
    
    Dim oMetaDataNode As IXMLDOMNode
    Set oMetaDataNode = oDomPkg.selectSingleNode("HELPCENTERPACKAGE/METADATA")

    Dim oMetadataCopy As IXMLDOMNode
    Set oMetadataCopy = oMetaDataNode.cloneNode(deep:=True)
    
    ' now we greba a recordset that has all the questions and URIs
    Dim rsQs As ADODB.Recordset: Set rsQs = p_Xls2Recordset(Me.txtXlsFile)
    
    Dim oDomHhtNode As IXMLDOMNode
    ' now we go through each HHT and check for fix relevancy.
    For Each oDomHhtNode In oMetadataCopy.selectNodes("HHT")
        
        Dim strHhtFile As String
        strHhtFile = oDomHhtNode.Attributes.getNamedItem("FILE").Text
        ' Let's load the HHT
        Dim oDomHht As DOMDocument: Set oDomHht = New DOMDocument
        oDomHht.async = False
        oDomHht.Load strCabFolder + "\" + strHhtFile
        If (oDomHht.parseError <> 0) Then GoTo Common_Exit
        
        Dim dictStopWords As Scripting.Dictionary
        Dim dictStopSigns As Scripting.Dictionary
        
        Set dictStopWords = p_LoadStopWords(oDomHht)
        Set dictStopSigns = p_LoadStopSigns(oDomHht)

        ' Now let's find out those Topic Lines with URI = ""
        Dim oListTopics As IXMLDOMNodeList
        ' Set oListTopics = oDomHht.selectNodes("/METADATA/TAXONOMY_ENTRIES/TAXONOMY_ENTRY[ not( @ENTRY ) and ( not(@URI) or @URI = """" ) ]")
        Set oListTopics = oDomHht.selectNodes("/METADATA/TAXONOMY_ENTRIES/TAXONOMY_ENTRY[ not( @ENTRY ) and ( not(@URI) or @URI = """" ) ]")
        
        If (Not oListTopics Is Nothing) Then
            ' We go through this HHT ONLY if it has
            ' Taxonomy Entries for Topics
            Me.prgBar.Visible = True
            Me.prgBar.Max = rsQs.RecordCount
            Me.prgBar.Value = 0
            
            oDomHht.setProperty "SelectionLanguage", "XPath"
            
            Dim intNewKeywords As Long
            Dim intOldKeywords As Long
            Dim intTotalNewKeywords As Long
            Dim intTotalOldKeywords As Long

            rsQs.MoveFirst
            Do While (Not rsQs.EOF)
                DoEvents
                p_CreateKeywordsFromQuery oDomHht, rsQs("Expected Uri"), rsQs("User Query"), dictStopWords, dictStopSigns, intNewKeywords, intOldKeywords
                rsQs.MoveNext
                Me.prgBar.Value = Me.prgBar.Value + 1
                intTotalNewKeywords = intTotalNewKeywords + intNewKeywords
                intTotalOldKeywords = intTotalOldKeywords + intOldKeywords
            Loop
            
            MsgBox _
                "Total number of rows: " & rsQs.RecordCount & vbCrLf & _
                "New keywords added: " & intTotalNewKeywords & vbCrLf & _
                "Old keywords modified: " & intTotalOldKeywords

            oDomHht.Save strCabFolder + "\" + strHhtFile
        End If
    Next
    
    ' Now we save the resulting package_description.xml
    oDomPkg.Save strPkgFile
    FixPerSe = True

Common_Exit:
    Exit Function
    
End Function

Private Sub p_CreateKeywordsFromQuery( _
    ByRef i_DOMDoc As MSXML2.DOMDocument, _
    ByVal i_strURI As String, _
    ByVal i_strQuestion As String, _
    ByRef i_dictStopWords As Scripting.Dictionary, _
    ByRef i_dictStopSigns As Scripting.Dictionary, _
    ByRef o_intNewKeywords As Long, _
    ByRef o_intOldKeywords As Long _
)
    Dim str As String
    Dim arrStr() As String
    Dim intIndex As Long
    Dim strQuery As String
    Dim strURI As String
    Dim DOMNodeListEntries As MSXML2.IXMLDOMNodeList
    Dim DOMNodeListKw As MSXML2.IXMLDOMNodeList
    Dim DOMNodeEntry As MSXML2.IXMLDOMNode
    Dim Element As MSXML2.IXMLDOMElement
    Dim intPriority As Long
    Dim intLBound As Long
    Dim intUBound As Long
    Dim intNewKeywords As Long
    Dim intOldKeywords As Long
    Dim strPriority As String
    
    WriteStatus "Creating keywords from " & i_strQuestion
    
    strURI = LCase$(Trim$(i_strURI))
    
    str = RemoveOperatorShortcuts(LCase$(i_strQuestion))
    str = p_RemoveStopSigns(str, i_dictStopSigns)
    str = RemoveExtraSpaces(str)
    
    arrStr = Split(str)
    
    intLBound = LBound(arrStr)
    intUBound = UBound(arrStr)
    
    If (intUBound >= 0) Then
        intPriority = 10000 / (intUBound - intLBound + 1)
    End If
                        
    strQuery = "/METADATA/TAXONOMY_ENTRIES/TAXONOMY_ENTRY[not( @ENTRY ) and " & _
    "translate(@URI, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', 'abcdefghijklmnopqrstuvwxyz') = '" & strURI & "'" & _
    "]"
                    
    Set DOMNodeListEntries = i_DOMDoc.selectNodes(strQuery)
    
    For Each DOMNodeEntry In DOMNodeListEntries
        For intIndex = intLBound To intUBound
            str = arrStr(intIndex)
            If (str <> "") Then
                If (Not IsVerbalOperator(str)) Then
                    If (Not i_dictStopWords.Exists(str)) Then
                        
                        strQuery = "KEYWORD[" & _
                            "translate(., 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', 'abcdefghijklmnopqrstuvwxyz') = '" & str & "'" & _
                            "]"
                            
                        Set DOMNodeListKw = DOMNodeEntry.selectNodes(strQuery)
                        
                        If (DOMNodeListKw.length = 0) Then
                            Set Element = i_DOMDoc.createElement(HHT_KEYWORD_C)
                            Element.Text = str
                            XMLSetAttribute Element, HHT_PRIORITY_C, intPriority
                            DOMNodeEntry.appendChild Element
                            intNewKeywords = intNewKeywords + 1
                        Else
                            Set Element = DOMNodeListKw(0)
                            strPriority = XMLGetAttribute(Element, HHT_PRIORITY_C)
                            If (strPriority = "") Then
                                XMLSetAttribute Element, HHT_PRIORITY_C, intPriority
                                intOldKeywords = intOldKeywords + 1
                            ElseIf (CLng(strPriority) < intPriority) Then
                                XMLSetAttribute Element, HHT_PRIORITY_C, intPriority
                            End If
                        End If
                    End If
                End If
            End If
        Next
    Next
    
    o_intNewKeywords = intNewKeywords
    o_intOldKeywords = intOldKeywords

End Sub

Private Function p_RemoveStopSigns( _
    ByVal i_strText As String, _
    ByRef i_dictStopSigns As Scripting.Dictionary _
) As String

    Dim intIndex As Long
    Dim intLength As Long
    Dim str As String
    Dim char As String

    str = i_strText
    intLength = Len(str)

    For intIndex = intLength To 1 Step -1
        char = Mid$(str, intIndex, 1)
        If (i_dictStopSigns.Exists(char)) Then
            If (i_dictStopSigns(char) = CONTEXT_ANYWHERE_E) Then
                ' Replace the character with a space
                str = Mid$(str, 1, intIndex - 1) & " " & Mid$(str, intIndex + 1)
            ElseIf (intIndex > 1) Then
                ' Context is CONTEXT_AT_END_OF_WORD_E, and this isn't the first char
                If (Mid$(str, intIndex - 1, 1) <> " ") Then
                    ' Previous character is not a space
                    If ((intIndex = intLength) Or (Mid$(str, intIndex + 1, 1) = " ")) Then
                        ' This is the last character or the next character is a space
                        ' Replace the character with a space
                        str = Mid$(str, 1, intIndex - 1) & " " & Mid$(str, intIndex + 1)
                    End If
                End If
            End If
        End If
    Next

    p_RemoveStopSigns = str

End Function

Function p_LoadStopSigns(ByRef oDomtaxo As DOMDocument) As Scripting.Dictionary
    
    Dim oDomNode As IXMLDOMNode, oNodeList As IXMLDOMNodeList
    Dim dict As Scripting.Dictionary
    Dim l As Long
    
    WriteStatus "Loading Stop Signs"

    Set dict = New Scripting.Dictionary

    Set oNodeList = oDomtaxo.selectNodes("/METADATA/STOPSIGN_ENTRIES/*")

    For Each oDomNode In oNodeList
        If (oDomNode.Attributes.getNamedItem("CONTEXT").Text = "ENDOFWORD") Then
            l = CONTEXT_AT_END_OF_WORD_E
        Else
            l = CONTEXT_ANYWHERE_E
        End If
        dict.Add oDomNode.Attributes.getNamedItem("STOPSIGN").Text, l
    Next
    
    Set p_LoadStopSigns = dict

End Function

Function p_LoadStopWords(ByRef oDomtaxo As DOMDocument) As Scripting.Dictionary
    
    Dim oDomNode As IXMLDOMNode, oNodeList As IXMLDOMNodeList
    Dim dict As Scripting.Dictionary
    
    WriteStatus "Loading Stop Words"
    
    Set dict = New Scripting.Dictionary

    dict.CompareMode = BinaryCompare

    Set oNodeList = oDomtaxo.selectNodes("/METADATA/STOPWORD_ENTRIES/*")

    For Each oDomNode In oNodeList
        dict.Add LCase$(oDomNode.Attributes.getNamedItem("STOPWORD").Text), True
    Next
    
    Set p_LoadStopWords = dict

End Function

Function p_Xls2Recordset( _
        ByVal strXlsFile As String _
    ) As ADODB.Recordset
        
    Dim cnn As ADODB.Connection
    Set cnn = New ADODB.Connection

    Set p_Xls2Recordset = Nothing

    Dim strErrMsg As String: strErrMsg = ""

    If (Not m_fso.FileExists(strXlsFile)) Then
        MsgBox "Cannot find " & strXlsFile
        GoTo Common_Exit
    End If

    prgBar.Visible = True
    
    WriteLog "Parsing " & strXlsFile
    
    ' Now, lets create a Recordset where we will dump all this information.
    
    Dim rs As ADODB.Recordset: Set rs = New ADODB.Recordset
    Dim rs1 As ADODB.Recordset: Set rs1 = New ADODB.Recordset
    rs.Fields.Append "User Query", adVarWChar, 512
    rs.Fields.Append "Expected Uri", adVarWChar, 512
    rs.Open
    cnn.Open "DRIVER=Microsoft Excel Driver (*.xls);ReadOnly=0;DBQ=" & _
                strXlsFile & ";HDR=0;"
    
    rs1.Open "SELECT * FROM `PrioQueries$`", cnn, adOpenStatic, adLockReadOnly
    
    Do While Not rs1.EOF
        rs.AddNew
        If (IsNull(rs1("User Query"))) Then
            Exit Do
        End If
        rs("User Query") = rs1("User Query") & ""
        rs("Expected Uri") = rs1("Expected Uri") & ""
        rs.Update
        rs1.MoveNext
    Loop
    
    ' We need to sort the Recordset based on User Query and URI
    rs.Sort = "[User Query],[Expected Uri]"
    ' Some recordset Validations:
    '
    ' We do them here, so when Excel via ADO is integrated we
    ' validate in a single place
    '
    ' we discard:
    '   - all repeats of User Query/URI Pairs and flag as warnings these
    '   - all records that have either an Empty Expected URI or Empty User Query
    rs.MoveFirst
    Dim strPrevUserQuery As String, strPrevExpectedUri As String, _
        strUserQuery As String, strExpectedUri As String
    
    strPrevUserQuery = ""
    strPrevExpectedUri = ""
    Do While (Not rs.EOF)
        strUserQuery = rs("User Query")
        strExpectedUri = rs("Expected Uri")
        If (Len(strUserQuery) = 0 Or Len(strExpectedUri) = 0) Then
            WriteLog "Warning Row has empty data and will not be included in set", False
            WriteLog vbTab + "User Query = '" + strUserQuery + "'", False
            WriteLog vbTab + "Expected Uri = '" + strExpectedUri + "'", False
            rs.Delete
            rs.Update
        ElseIf (strPrevUserQuery = strUserQuery) Then
            If (strPrevExpectedUri = strExpectedUri) Then
                WriteLog "Warning Row is a duplicate and will not be included in set", False
                WriteLog vbTab + "User Query = '" + strUserQuery + "'", False
                WriteLog vbTab + "Expected Uri = '" + strExpectedUri + "'", False
                rs.Delete
                rs.Update
            Else
                strPrevExpectedUri = strExpectedUri
            End If
        Else
            ' strPrevUserQuery <> strUserQuery
            strPrevUserQuery = strUserQuery
            strPrevExpectedUri = strExpectedUri
        End If
        rs.MoveNext
    Loop
    
    ' BUGBUG: This step should be unneeded, but due to the fact that I already coded
    '           the validation using the above sort, I simply re-sort. So
    '           the validation above should be reauthored for this order.
    ' Now we need Re-sort the Recordset based on URI and User Query.
    rs.Sort = "[Expected Uri],[User Query]"
    rs.MoveFirst
    
    Set p_Xls2Recordset = rs

Common_Exit:

End Function
'============= Utilities =============

Private Sub p_DisplayParseError( _
    ByRef i_ParseError As IXMLDOMParseError _
)

    Dim strError As String
    
    strError = "Error: " & i_ParseError.reason & _
        "Line: " & i_ParseError.Line & vbCrLf & _
        "Linepos: " & i_ParseError.linepos & vbCrLf & _
        "srcText: " & i_ParseError.srcText
        
    MsgBox strError, vbOKOnly, "Error while parsing"

End Sub