Valhalla Legends Forums Archive | Excess of Grok | Visual Basic in the workplace

AuthorMessageTime
Grok
If you ever become professionally employed implementing business applications with Visual Basic, you might be writing something like this function, part of the nearly 4000 lines of code I wrote over the last 9 days.

[code]

'**************************************************
'Search cabinets.
'Create an accumulator from the first cabinet searched.
'Add each subsequent cabinet results to the accumulator.
'Display the results form, passing the accumulator.
'**************************************************
Private Sub cmdSearch_Click()
   
   On Error GoTo cmdSearch_ClickErr
   
   Dim lKGI As Long
   Dim lPos As Long, lPos2 As Long                 'working vars
   Dim pCabName As String, pCabObjId As String
   Dim pServer As String
   Dim pDocObjID As String                         'document vars
   Dim pKeywords As String, pSubclass As String
   Dim rsCabs As New ADODB.Recordset               'cabinets to search
   Dim rsFind As New ADODB.Recordset               'find criteria
   Dim rsAcc As New ADODB.Recordset                'accumulator
   Dim rsList As New ADODB.Recordset               'listcab results
   Dim sqlFilter As String                         'filter predicate
   Dim bKeepDoc As Boolean                         'true if document survived filters
   Dim pKWYes As String, pKWNo As String           'strings from keywords textboxes
   Dim saKWYes() As String, saKWNo() As String     'arrays of keywords filters
   Dim rsFiltered As New ADODB.Recordset           'filtered recordset
   Dim sField As String, sCompare As String        'search variables
   Dim sFilter As String                           'search variables
   Dim adoField As ADODB.Field                     'temp field variable
   Dim Itm As MSComctlLib.ListItem
   Dim iSavePtr As Integer
   
   iSavePtr = Screen.MousePointer
   Screen.MousePointer = vbHourglass
   gRunning = True: gHalt = False
   
   'initialize search statistics
   Stats.Cabs = 0                                  'num cabs searched
   Stats.entries = 0                               'num entries in cabinets
   Stats.Scanned = 0                               'scanned from primary search filter
   Stats.Opened = 0                                'documents opened for keywords+subclass
   Stats.Found = 0                                 'num docs resulting after all
   
   'set up the recordset for File Cabinets to search
   rsCabs.CursorLocation = adUseClient
   rsCabs.Fields.Append "Name", adVarChar, 30
   rsCabs.Fields.Append "Server", adVarChar, 30
   rsCabs.Fields.Append "ObjectID", adVarChar, 30
   rsCabs.Open
   
   For lPos = 1 To lvwSearchCabs.ListItems.Count
       Set Itm = lvwSearchCabs.ListItems(lPos)
       If Itm.Selected = True Then
           pCabName = Itm.Text
           pCabObjId = Itm.Key
           rsCabs.AddNew
           rsCabs.Fields("Name").Value = pCabName
           rsCabs.Fields("Server").Value = VBA.Split(pCabObjId, ".")(0)
           rsCabs.Fields("ObjectID").Value = pCabObjId
           rsCabs.Update
       End If
   Next lPos
   
   'build search criteria recordset
   rsFind.CursorLocation = adUseClient
   rsFind.Fields.Append "Field", adVarChar, 50
   rsFind.Fields.Append "Filter", adVarChar, 50
   rsFind.Fields.Append "Compare", adChar, 2
   rsFind.Open
   
   'load the search criteria from the dialog's textboxes
   '** what we're doing here is building a recordset with an entry
   'for each criteria the user wants to search.  later we will traverse
   'this recordset and apply each filter against the file cabinet
   'search results, eliminating those which do not pass the tests.
   If Len(txtTitle.Text) > 0 Then
       rsFind.AddNew
       rsFind.Fields("Field").Value = "Title"
       rsFind.Fields("Filter").Value = txtTitle.Text & ""
       rsFind.Fields("Compare").Value = "EQ"               'EQUAL TO
       rsFind.Update
   End If
   
   If Len(txtPerson.Text) > 0 Then
       rsFind.AddNew
       rsFind.Fields("Field").Value = "Person"
       rsFind.Fields("Filter").Value = txtPerson.Text & ""
       rsFind.Fields("Compare").Value = "EQ"               'EQUAL TO
       rsFind.Update
   End If
   
   If Len(txtType.Text) > 0 Then
       rsFind.AddNew
       rsFind.Fields("Field").Value = "UserType"
       rsFind.Fields("Filter").Value = txtType.Text & ""
       rsFind.Fields("Compare").Value = "EQ"               'EQUAL TO
       rsFind.Update
   End If
   
   Select Case True
   Case Len(txtDate.Text) > 0                              'exact date used
       rsFind.AddNew
       rsFind.Fields("Field").Value = "Date"
       rsFind.Fields("Filter").Value = txtDate.Text
       rsFind.Fields("Compare").Value = "EQ"               'EQUAL TO
       rsFind.Update
   Case Len(txtDateFrom.Text) + Len(txtDateTo.Text) > 0    'from or to date
       If Len(txtDateFrom.Text) > 0 Then                   'from date
           rsFind.AddNew
           rsFind.Fields("Field").Value = "Date"
           rsFind.Fields("Filter").Value = txtDateFrom.Text
           rsFind.Fields("Compare").Value = "GE"           '>=
           rsFind.Update
       End If
       If Len(txtDateTo.Text) > 0 Then                     'to date
           rsFind.AddNew
           rsFind.Fields("Field").Value = "Date"
           rsFind.Fields("Filter").Value = txtDateTo.Text
           rsFind.Fields("Compare").Value = "LE"           '<=
           rsFind.Update
       End If
   End Select
   
   'if no title,person,type, or date index chosen, search ALL on Title.
   'otherwise no records will be returned to search through keywords.
   If rsFind.RecordCount = 0 Then
       rsFind.AddNew
       rsFind.Fields("Field").Value = "Title"
       rsFind.Fields("Filter").Value = "*"                 'everything
       rsFind.Fields("Compare").Value = "EQ"               'EQUAL TO
       rsFind.Update
   End If
   
   If Len(txtKeyWords.Text) > 0 Then
       rsFind.AddNew
       rsFind.Fields("Field").Value = "Keywords"
       rsFind.Fields("Filter").Value = txtKeyWords.Text
       rsFind.Fields("Compare").Value = "EQ"               'EQUAL TO
       rsFind.Update
   End If
   
   If Len(txtNotKeyWords.Text) > 0 Then
       rsFind.AddNew
       rsFind.Fields("Field").Value = "Keywords"
       rsFind.Fields("Filter").Value = txtNotKeyWords.Text
       rsFind.Fields("Compare").Value = "NE"               'NOT EQUAL
       rsFind.Update
   End If
   
   'see if they entered any search criteria .. if not, we can exit now.
   If rsFind.RecordCount = 0 Then
       MsgBox "No search criteria!" & vbCrLf & "Search cancelled.", vbExclamation
       GoTo cmdSearch_ClickExit
   End If
   
   'build the filter clause for our recordsets.. if someone searched for
   'hits by putting "Moby Dick" in the title field, and "Herman Melville" in
   'the person field, the filter will look like this:
   '
   '(Title='Moby Dick') AND (Person='Herman Melville')
   '
   'read MSDN help for Filter property of a Recordset for more info.
   '
   sqlFilter = ""
   rsFind.MoveFirst
   Do While rsFind.EOF = False
       sField = rsFind.Fields("Field").Value & ""
       sFilter = rsFind.Fields("Filter").Value & ""
       sCompare = rsFind.Fields("Compare").Value & ""
       'if filter is "something=*" then do not add it to sqlFilters
       If (sCompare = "EQ") And (sFilter = "*") Then
           'user wants all of a field, do not add to sqlFilter string.
       Else
           'build sqlFilter string, add filter request to sqlFilter string.
           If Len(sqlFilter) > 0 Then sqlFilter = sqlFilter & " AND ("
           If Len(sqlFilter) = 0 Then sqlFilter = "("
           sqlFilter = sqlFilter & sField & " "
           lPos = InStr(gKEYFilters, sCompare)
           If lPos > 0 Then                            'must be valid keyfile filter
               Select Case sField
               Case "Title", "Person", "UserType", "Date", "Description"
                   sqlFilter = sqlFilter & Trim(Mid(gSQLFilters, lPos, 2)) & "'"
                   sqlFilter = sqlFilter & sFilter & "'"
               Case "Keywords"
                   Select Case sCompare
                   Case "EQ"
                       pKWYes = sFilter
                       saKWYes = Split(sFilter, vbCrLf)
                   Case "NE"
                       pKWNo = sFilter
                       saKWNo = Split(sFilter, vbCrLf)
                   End Select
               End Select
               sqlFilter = sqlFilter & ")"
           End If
       End If
       rsFind.MoveNext
   Loop
   
   'attach to accumulator database (access db, local)
   rsAcc.Open "Results", dbLocal, adOpenKeyset, adLockOptimistic
   dbLocal.Execute "delete from results"
   
   If rsCabs.RecordCount > 0 Then                          'if there are cabinets to search
       rsCabs.MoveFirst
       Do While rsCabs.EOF = False                         'loop through the cabinets
           If gHalt = True Then GoTo cmdSearch_Halt
           'go get some results
           pCabObjId = rsCabs.Fields("ObjectID").Value & ""        'get cabinet objectID
           pServer = Split(pCabObjId, ".")(0)                      'figure out the server
           
           'loop through open keyfile connections, looking for correct server
           lKGI = -1                                       'initialize to invalid index
           For lPos = 0 To UBound(KGI)
               If StrComp(pServer, KGI(lPos).ServerName) = 0 Then
                   lKGI = lPos                             'found KGI session handle
                   Exit For
               End If
           Next lPos
           If lKGI >= 0 Then
               Set File = New AKO32.CFile
               File.hKGI = KGI(lKGI)
               File.ObjectID = rsCabs.Fields("ObjectID").Value & ""
               Stats.Cabs = Stats.Cabs + 1
               File.OpenList
               Stats.entries = Stats.entries + File.entries
               rsFind.MoveFirst
               File.SetFilter rsFind.Fields("Field").Value, rsFind.Fields("Filter").Value & "", rsFind.Fields("Compare").Value & ""
               If File.EOF = False Then
                   Set rsList = File.List
                   Do While rsList.EOF = False
                       If gHalt = True Then GoTo cmdSearch_Halt
                       Stats.Scanned = Stats.Scanned + rsList.RecordCount
                       rsList.Filter = sqlFilter               'found some, apply the sql filter
                       'everything left can be applied to the results accumulator
                       Do While rsList.EOF = False
                           If gHalt = True Then GoTo cmdSearch_Halt
                           bKeepDoc = True
                           If (Len(pKWYes) > 0) Or (Len(pKWNo) > 0) Then
                               Stats.Opened = Stats.Opened + rsList.RecordCount
                               Set Doc = New AKO32.CDocument
                               Doc.hKGI = KGI(lKGI)
                               pDocObjID = rsList.Fields("ObjectID").Value & ""
                               Doc.OpenDocument pDocObjID
                               Doc.GetUserKeywords
                               pKeywords = UCase(Doc.UserKeywords)
                               pSubclass = Doc.Subclass
cmdSearch_ClickSkipOpenDoc:
                               Set Doc = Nothing
                               '***********************************************
                               'look for required keywords
                               '+++++++++++++++++++++++++++++++++++++++++++++++
                               If Len(pKWYes) > 0 Then
                                   For lPos = LBound(saKWYes) To UBound(saKWYes)
                                       If InStr(pKeywords, UCase(saKWYes(lPos))) = 0 Then
                                           'document didnt have one, reject whole thing
                                           bKeepDoc = False
                                           Exit For
                                       End If
                                   Next lPos
                               End If
                               
                               If bKeepDoc = True And Len(saKWNo) > 0 Then
                                   'look for keywords user wants to reject docs
                                   For lPos = LBound(saKWNo) To UBound(saKWNo)
                                       If InStr(pKeywords, saKWNo(lPos)) > 0 Then
                                           'keyword found, user does not want this doc.
                                           bKeepDoc = False
                                           Exit For
                                       End If
                                   Next lPos
                               End If
                               '-----------------------------------------------
                               'end of keywords checking
                               '***********************************************
                           End If
                           
                           If bKeepDoc = True Then
                               'it survived, add it to results
                               rsAcc.AddNew
                               rsAcc.Fields("ObjectID").Value = rsList.Fields("ObjectID").Value & ""
                               rsAcc.Fields("Title").Value = rsList.Fields("Title").Value & ""
                               rsAcc.Fields("Person").Value = rsList.Fields("Person").Value & ""
                               rsAcc.Fields("UserType").Value = rsList.Fields("UserType").Value & ""
                               rsAcc.Fields("Date").Value = rsList.Fields("Date").Value & ""
                               rsAcc.Fields("Description").Value = rsList.Fields("Description").Value & ""
                               rsAcc.Fields("Icon").Value = rsList.Fields("Icon").Value & ""
                               rsAcc.Fields("Keywords").Value = pKeywords
                               rsAcc.Fields("Subclass").Value = pSubclass
                               rsAcc.Fields("IsTop").Value = rsList.Fields("IsTop").Value
                               rsAcc.Update
                               Stats.Found = Stats.Found + 1
                           End If
                           rsList.MoveNext
                       Loop
                       'get next batch from file cabinet
                       Set rsList = File.List
                       DoEvents
                   Loop
               End If
               File.Shut
               Set File = Nothing
           Else
               'error!  cabinet is from a server that we are not connected with.
           End If
           rsCabs.MoveNext
       Loop
   End If
cmdSearch_Halt:
   rsAcc.Close
   rsFind.Close
   rsCabs.Close
   If gHalt = False Then
       frmResults.Show
       Dim lngLeft As Long
       lngLeft = frmResults.Left
       frmResults.Move -(frmResults.Width + 100)
       Dim T1 As Variant
       T1 = Now
       Do
           DoEvents
       Loop Until DateDiff("s", T1, Now) > 1
       frmResults.DisplayData
       frmResults.Move lngLeft
   End If
   
'    Dim Msg As String
'    Msg = "Search Complete!" & vbCrLf & vbCrLf
'    Msg = Msg & "Cabinets:   " & Stats.Cabs & vbCrLf
'    Msg = Msg & "Entries:    " & Stats.entries & vbCrLf
'    Msg = Msg & "Scanned:    " & Stats.Scanned & vbCrLf
'    Msg = Msg & "Opened:     " & Stats.Opened & vbCrLf
'    Msg = Msg & "Found:      " & Stats.Found
'    MsgBox Msg, vbInformation
   
cmdSearch_ClickExit:
   Screen.MousePointer = iSavePtr
   gRunning = False
   Exit Sub
   
cmdSearch_ClickErr:
   Dim lErr As Long, lDesc As String
   lErr = Err.Number
   lDesc = Error(lErr)
   Debug.Print lErr & "-" & lDesc
   Select Case lErr
   Case 9991                       'cannot open document
       Resume cmdSearch_ClickSkipOpenDoc
   Case 9995
       Sleep 1000
       Resume
   Case Else
       MsgBox "Error in search: " & lErr & "-" & lDesc, vbExclamation, "ERROR, Click OK to continue"
   End Select
   Resume cmdSearch_ClickExit
   Resume
   
End Sub

[/code]
January 31, 2003, 11:14 AM
Yoni
Eww... :-/
January 31, 2003, 11:26 AM
iago
Wow, look at all those comments! :-)
January 31, 2003, 5:45 PM
Atom
Holy! My hand would have died... I hope you get payed by the hour lol. Using With \ End With would make that a little easier
February 1, 2003, 12:05 PM

Search