Author | Message | Time |
---|---|---|
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 |