Search.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 = "Search"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Option Compare Text

'--- Codes Constant
Private Const STR_QUOTE = """"
Private Const MAX_COLL = 5 ' Maximum number of document types

Public Enum SearchTypeOptions
    ftsContains = 1
    ftsFreeText = 2
    ftsInflection = 3
    ftsSubstring = 4
    ftsOrIsDefault = 5
End Enum

'--- PUBLIC properties (no restrictions)
Public SearchType As SearchTypeOptions

'--- PRIVATE data members
Private m_aWords() As String

'--- Initialize the class defaults
Private Sub Class_Initialize()
   SearchType = ftsContains
End Sub



Public Property Let SearchString(ByVal RHS As String)
Attribute SearchString.VB_Description = "Parse the string before sending it to index server."
Attribute SearchString.VB_UserMemId = 0
  ' Replace special case "NEAR()" with tilde
  RHS = Replace(LCase(Trim(RHS)), "near() ", "~ ")
  ' Split the string into words (tokens)
  m_aWords = Tokenize(RHS, " ")
End Property

Public Property Get SearchString() As String
    Dim count As Integer
    Dim strncat As String
    Dim bTerm As Boolean
    Dim strAnd As String
    
    If SearchType = ftsOrIsDefault Then
       strAnd = "or "
    Else
       strAnd = "and "
    End If
    
    Select Case SearchType
    ' Combine the word list into a single phrase
    Case ftsFreeText
        strncat = STR_QUOTE
        For count = 1 To UBound(m_aWords)
            ' Remove double quotes from all tokens
            strncat = strncat & Replace(m_aWords(count), STR_QUOTE, "")
        Next count
        strncat = strncat & STR_QUOTE
        
    ' Combine the words as a boolean search
    Case Else
        bTerm = True ' First pass, don't add terms
        For count = 1 To UBound(m_aWords)
            Select Case m_aWords(count)
            ' Append these, but treat them as special terms
            Case "~ ", "or ", "and "
                If Not bTerm Then
                    bTerm = True
                    strncat = strncat & m_aWords(count)
                End If
            
            ' Handle NEAR as a term, but not after another term
            Case "near "
                If Not bTerm Then
                    bTerm = True
                    strncat = strncat & "~ "
                End If
            
            ' Non-term word found
            Case Else
                Dim x
                If Not bTerm Then strncat = strncat & strAnd
                bTerm = False
                x = InStr(m_aWords(count), "*")
                If x > 0 Then
                    ' Wrap "word*" form in double quotes
                    strncat = strncat & """" & Left(m_aWords(count), x) & """ "
                ElseIf SearchType <> ftsSubstring Or _
                       InStr(m_aWords(count), STR_QUOTE) > 0 Then
                    ' Just add this word as-is
                    strncat = strncat & m_aWords(count)
                Else
                    ' Create "word*" form if using sub-string search option
                    strncat = strncat & """" & m_aWords(count) & "*"" "
                End If
            End Select
        Next
    End Select
    
    If SearchType = ftsInflection And _
       UBound(m_aWords) = 1 And _
       InStr(strncat, "*") = 0 Then
       strncat = "FORMSOF (INFLECTIONAL,""" & strncat & """)"
    End If
     
    SearchString = RTrim(strncat)
End Property

'===================================================================
' TOKEN PARSING FUNCTIONS
'===================================================================

' Returns the current position in the string
' NOTE: This function ignores delimiters inside of quotes and adds an extra space to tokens
Private Function GetToken(ByRef strText As String, ByRef strDelim As String, ByRef strToken As String) As String
   Dim x As Integer, c As String, bInQ As Boolean

   bInQ = False
   strToken = ""
   For x = 1 To Len(strText)
      c = Mid(strText, x, 1)
      '--- skip delimiters inside quoted strings
      If c = STR_QUOTE Then bInQ = Not bInQ
      If Not bInQ And c = strDelim Then
         If strToken <> "" Then
           strToken = strToken & " "
           GetToken = x + 1  ' skip delimiter
           Exit Function
         End If
      Else
         strToken = strToken & c
      End If
   Next
   
   ' Append a space, just like all the other tokens
   If strToken <> "" Then strToken = strToken & " "
   
   ' Last token
   GetToken = 0
End Function

' Returns an array of values split at delimiters
Private Function Tokenize(ByRef strText As String, ByVal strDelim As String) As String()
   Dim aTokens() As String, cTokens As Integer
   Dim x As Integer, strToken As String

   cTokens = 0
   
   '--- Parse string into array of tokens
   x = GetToken(strText, strDelim, strToken)
   Do While x > 0
      cTokens = cTokens + 1
      ReDim Preserve aTokens(cTokens)
      aTokens(cTokens) = strToken
      '--- Chop string and iterate
      strText = Mid(strText, x)
      x = GetToken(strText, strDelim, strToken)
   Loop
   
   '--- Last token in string
   cTokens = cTokens + 1
   ReDim Preserve aTokens(cTokens)
   aTokens(cTokens) = strToken
   
   '--- Return array of tokens
   Tokenize = aTokens
End Function