Visual Basic in the workplace

[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 Select Expand


'**************************************************
'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



[Yoni]

Eww... :-/

[iago]

Wow, look at all those comments! :-)

[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