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.
'**************************************************
'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
Eww... :-/
Wow, look at all those comments! :-)
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