VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "basUtility"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

'*** Constant declarations
Private Const strMODULE_NAME As String = "basUtility"
Private Const intSTRING_SIZE_LIMIT As Integer = 500
Private Const strNO_RECORDS_MESSAGE As String = "There Are No Records To Display"
Private Const intSCREEN_WIDTH_IN_PIXELS As Integer = 597
Private Const intNO_RECORDS_FONT_SIZE As Integer = 2
'*** This function returns a string containing a formatted HTML table
'*** Input Parameters:
'***    rsToDisplay: ADO recordset to display (required)
'***    arrOfColNames: array containing column headers, If = False then no headers (optional)
'***    arrOfFieldFormats: array containing field format filters (optional)
'***    intPageSize: number of lines per page (between Response.Write calls)
'***    blnIfAlternatingColor: display alternation row colors (optional)
'***    strFieldsToExclude: CSV list of field #'s to exclude from the display - "2,5,6" (optional)
'***    arrDisplayRules: array containing display rule strings in format "FIELD:RULEXXXXRULE"
'***    strSecurityTaskField: field # in the recordset containing a security task id
'***    strSortFields: CSV list of field #'s to have sort controls
'***    strCurrentSortField: field # of the current sort field (when sort fields are defined)
'***       Where FIELD = field to apply rule towards, RULE = rule text and XXXX = position
'***       = in output rule string to insert the field value (optional)
'***       Example array entry: "9:<A HREF='DisplayWellDetails.asp?
'***    strParmString: Contains string of additional data to add to display rull
'*** Note: no error checking is done to insure that arrOfMaxColSizes or arrOfColNames
'***    contain the correct number of entries to match the incoming recordset object
Public Function strFormatTable(ByVal rsData As ADODB.Recordset, _
        ByVal arrOfColNames As Variant, _
        ByVal arrOfFieldFormats As Variant, _
        ByVal intPageSize As Integer, _
        ByVal blnIfAlternatingColor As Boolean, _
        ByVal strFieldsToExclude As String, _
        ByVal arrDisplayRules As Variant, _
        ByVal strSortFields As String, _
        ByVal strCurrentSortField As String, _
        ByVal strWhiteColor As String, _
        ByVal strPrimaryFont As String, _
        ByVal intFontSize As Integer, _
        ByVal strTableHeaderColor As String, _
        ByVal strAlternatingRowColor As String, _
        ByVal strBlackColor As String) As String
    
    '*** Declare all variables
    Dim arrHTML As Variant              'Array of HTML strings to be built (to minimize string concatenation size)
    Dim intArrCounter As Integer        'Counter for moving through HTML string array
    Dim objField As ADODB.Field         'Recordset field
    Dim intNoOfFields As Integer        '# of fields in the recordset (used to decide the table width)
    Dim strRowColor As String           'Current row color
    Dim intAltRowCounter As Integer     'Counter to track alternating rows
    Dim i As Integer                    'Generic counter
    Dim intRemainder As Integer
    Dim intRuleCounter As Integer       'Display rule counter
    Dim strDisplayRule As String        'Display Rule String
    Dim intFieldCounter As Integer      'Field has been excluded for display counter
    Dim arrTempDisplayRule As Variant   'FieldNumber:DisplayRule pair
    Dim strParsedDisplayRuleString As String 'Display string after parsing the display rule
    Dim strFlattenedDisplayRuleString As String 'Flattened display Rule String
    Dim intTableWidth As Integer        'Default table width
    Dim intFieldSetWidth As Integer     'Default column width
    Dim strDisplayValue As String       'Data value to be written (after applying the format filter)
    Dim intRowCounter As Integer        'Rows added to a table section counter
    Dim strBufferValue As String        'Buffered cell value for subsequent use in a display rule
    Dim intWrittenFieldCounter As Integer 'Current written field position
    Dim strCellWrap As String           'Cell wrapping
    
    '*** Enable error handling
    On Error GoTo ErrorHandler
        
    '*** Initialize working variables
    intNoOfFields = CInt(rsData.Fields.Count)
    strRowColor = strWhiteColor
    intRuleCounter = 0
    strDisplayRule = ""
    strFlattenedDisplayRuleString = ""
    intRowCounter = 0
    intAltRowCounter = 0
    intArrCounter = 0
        
    '*** Initialize the size of the output string array
    ReDim arrHTML(1)
    
    '*** Initialize table width and field width
    '***    Assign a default table width using a 20% width factor for each field (assumes
    '****   average of 5 fields per table).  If total number of fields exceeds
    '***    100% then cap it at 100%. Calculate the field width using get the screenwidth
    intTableWidth = 20 * intNoOfFields
    If intTableWidth > 100 Then
        intTableWidth = 100
    End If
    intFieldSetWidth = (intTableWidth / 100) * intSCREEN_WIDTH_IN_PIXELS
    arrHTML(intArrCounter) = "<TABLE STYLE='font-size:" & intFontSize & "; font-family:" & _
        strPrimaryFont & "' WIDTH=" & intTableWidth & "% BORDER=0 CELLSPACING=0 CELLPADDING=5>"
    
    '*** Configure column alignments using data based upon the first row of data (header rows override these settings)
    arrHTML(intArrCounter) = arrHTML(intArrCounter) & "<COLGROUP>"
    intFieldCounter = 1
    For Each objField In rsData.Fields
        If InStr(1, strFieldsToExclude, CStr(intFieldCounter), 0) = 0 Then
            If IsNumeric(objField.Value) = True Then
                arrHTML(intArrCounter) = arrHTML(intArrCounter) & "<COL ALIGN='RIGHT'>"
            Else
                arrHTML(intArrCounter) = arrHTML(intArrCounter) & "<COL ALIGN='LEFT'>"
            End If
        End If
        intFieldCounter = intFieldCounter + 1
    Next
    
    '*** If display rules are defined then format them into a flattened string
    '***    Example: "2:<a href='test.asp?errorid=x'>click here for error.asp</a>^3:<a href=display.asp>Click here for display.asp</a>'"
    If IsArray(arrDisplayRules) Then
        intRuleCounter = 0
        While intRuleCounter <= UBound(arrDisplayRules)
            If intRuleCounter = 0 Then
                strFlattenedDisplayRuleString = strFlattenedDisplayRuleString & _
                    arrDisplayRules(intRuleCounter)
            Else
                'Use ^ as a delimiter
                strFlattenedDisplayRuleString = strFlattenedDisplayRuleString & "^" & _
                    arrDisplayRules(intRuleCounter)
            End If
            intRuleCounter = intRuleCounter + 1
        Wend
        '*** At this stage we have a flattened rule string that looks like:
    End If
    
    '*** Iterate through the recordset to populate the table
    If Not (rsData.EOF And rsData.BOF) Then
        '*** Position at the first record
        rsData.MoveFirst
        
        '*** Iterate through the recordset
        While Not rsData.EOF
                
            '*** If this is the first row in the page then write a column header
            If intAltRowCounter = 0 Then
                arrHTML(intArrCounter) = arrHTML(intArrCounter) & "<TR VALIGN='TOP' " & _
                    "STYLE='font-weight: bold; color:" & strWhiteColor & "' BGCOLOR='" & _
                    strTableHeaderColor & "'>"
                '*** If a column header array was passed then write a header row containing
                '***    the specified column names to the table
                If IsArray(arrOfColNames) Then
                    For i = 0 To UBound(arrOfColNames)
                        arrHTML(intArrCounter) = arrHTML(intArrCounter) & "<TD ALIGN='CENTER'>" & _
                        arrOfColNames(i) & "</TD>"
                    Next i
                '*** Else if False then write no header (do nothing)
                ElseIf arrOfColNames = False Then
                    'Do nothing here
                '*** Else write a default header containing the field names
                Else
                    For i = 0 To rsData.Fields.Count - 1
                        '*** If the field is not marked for exclusion then write the field name
                        If InStr(1, strFieldsToExclude, CStr(i + 1), 0) = 0 Then
                            arrHTML(intArrCounter) = arrHTML(intArrCounter) & "<TD ALIGN='CENTER'>" & _
                            rsData.Fields(i).Name & "</TD>"
                        '*** Else exclude the field (do nothing)
                        Else
                        End If
                    Next i
                End If
                arrHTML(intArrCounter) = arrHTML(intArrCounter) & "</TR>"
            End If
                                        
            '*** If alternating row colors are selected then assign the appropriate color
            '***    for the current row
            If blnIfAlternatingColor Then
                '*** (intRemainder is used to show alternating colors in the rows of the table)
                intRemainder = intAltRowCounter Mod 2
                If intRemainder = 0 Then
                    strRowColor = strAlternatingRowColor
                Else
                    strRowColor = strWhiteColor
                End If
            End If

           '*** Start a new data row in the table
            arrHTML(intArrCounter) = arrHTML(intArrCounter) & "<TR BGCOLOR='" & strRowColor & "'>"

            '*** Initialize the field counter = 1 for each new row
            intFieldCounter = 1
            intWrittenFieldCounter = 0
        
            '*** Iterate through the fields and display them one by one
            For Each objField In rsData.Fields
                '*** If the field is not marked for exclusion then continue
                If InStr(1, strFieldsToExclude, CStr(intFieldCounter), 0) = 0 Then
                    '*** If a field output format array was provided then search for a format string
                    If IsArray(arrOfFieldFormats) Then
                        '*** If a format string was defined then format the field for display
                        If arrOfFieldFormats(intWrittenFieldCounter) <> "" Then
                            If IsNull(objField.Value) = False Then
                                strDisplayValue = Format(objField.Value, _
                                    arrOfFieldFormats(intWrittenFieldCounter))
                            Else
                                strDisplayValue = ""
                            End If
                        '*** Else just display the value "as-is"
                        Else
                            strDisplayValue = CStr(objField.Value & "")
                        End If
                    '*** Else just display the value "as-is"
                    Else
                        strDisplayValue = CStr(objField.Value & "")
                    End If
                    If blnContainsWrapChar(strDisplayValue) = True Then
                        strCellWrap = " NOWRAP"
                    Else
                        strCellWrap = ""
                    End If
                    '*** If a display rule is defined for this field then fetch the rule and apply it
                    '***   (an instr for the flattened display rule string will be sufficient)
                    If InStr(1, strFlattenedDisplayRuleString, CStr(intFieldCounter), 0) Then
                        intRuleCounter = 0
                        strDisplayRule = ""
                        '*** Iterate through the array to get the rule
                        While intRuleCounter <= UBound(arrDisplayRules)
                            strDisplayRule = arrDisplayRules(intRuleCounter)
                            '*** Find the matching display rule string
                            If InStr(1, strDisplayRule, CStr(intFieldCounter), 0) > 0 Then
                                '*** Fetch the display rule
                                arrTempDisplayRule = Split(strDisplayRule, "|")
                                '*** Replace the pattern XXXX with the rule string
                                '***    (The display rule is at the second dimension)
                                strParsedDisplayRuleString = Replace(arrTempDisplayRule(1), "XXXX", _
                                    strDisplayValue)
                                '*** Replace the pattern YYYY with the buffer value
                                strParsedDisplayRuleString = Replace(strParsedDisplayRuleString, _
                                    "YYYY", strBufferValue)
                                '*** Display the field using the display rule
                                arrHTML(intArrCounter) = arrHTML(intArrCounter) & "<TD" & _
                                    strCellWrap & " ALIGN='LEFT'>" & strParsedDisplayRuleString & "</TD>"
                                '*** Reinitialized the display rule string
                                strParsedDisplayRuleString = ""
                            End If
                            intRuleCounter = intRuleCounter + 1
                        Wend
                    Else
                        '*** Else simply display the field value
                        arrHTML(intArrCounter) = arrHTML(intArrCounter) & "<TD" & _
                            strCellWrap & ">" & strDisplayValue & "</TD>"
                    End If
                    '*** Increment the intWrittenFieldCounter
                    intWrittenFieldCounter = intWrittenFieldCounter + 1
                '*** Else buffer the field for use in the display rule
                Else
                    strBufferValue = CStr(objField.Value & "")
                End If
                '*** Increment the intFieldCounter
                intFieldCounter = intFieldCounter + 1
            Next
            '*** Close the row
            arrHTML(intArrCounter) = arrHTML(intArrCounter) & "</TR>"
        
            '*** Increment the alternating row counter
            intAltRowCounter = intAltRowCounter + 1

            '*** If string size limit is reached then increment array bound (to minimize
            '***    string concatenation constraints)
            If Len(arrHTML(intArrCounter)) > intSTRING_SIZE_LIMIT Then
                intArrCounter = intArrCounter + 1
                ReDim Preserve arrHTML(intArrCounter + 1)
            End If
            
            '*** If the page is not complete then increment the alternating row counter
            If intRowCounter < intPageSize Then
                intRowCounter = intRowCounter + 1
            '*** Reset the row counters
            Else
                intRowCounter = 0
                intAltRowCounter = 0
            End If
            
            '*** Read the next record
            rsData.MoveNext
        Wend
    '*** Else the recordset is empty - display a message
    Else
        arrHTML(intArrCounter) = arrHTML(intArrCounter) & "<TR><TD align='RIGHT' VALIGN='MIDDLE' " & _
            "COLSPAN='" & intAltRowCounter + 1 & "'><FONT FACE='" & strPrimaryFont & "' COLOR='" & _
            strBlackColor & "' SIZE='" & intNO_RECORDS_FONT_SIZE & "'>" & _
            strNO_RECORDS_MESSAGE & "</FONT></TD></TR>"
    End If
    
    '*** Close the table
    arrHTML(intArrCounter) = arrHTML(intArrCounter) & "</TABLE>"
    
    '*** Join array and return a single string
    strFormatTable = Join(arrHTML)

CommonExit:
    GoSub ObjectCleanup
    Exit Function

ObjectCleanup:
    If Not (objField Is Nothing) Then Set objField = Nothing
    Return
    
ErrorHandler:
    GoSub ObjectCleanup
    '*** Raise an error to the calling procedure
    Err.Raise Err.Number, Err.Source & "[" & strMODULE_NAME & ".arrFormatTable()]", Err.Description
   
End Function
'*** This function formats a string using the specified format value
Public Function strFormatValue(ByVal strValueIn As String, _
        ByVal strFormat As String) As String
   
    '*** Enable error handling
    On Error GoTo ErrorHandler
    
    strFormatValue = Format(strValueIn, strFormat)
   
CommonExit:
    Exit Function
    
ErrorHandler:
    '*** Raise an error to the calling procedure
    Err.Raise Err.Number, Err.Source & "[" & strMODULE_NAME & ".strFormatValue()]", Err.Description
   
End Function
'*** This function determines if a string value is found in an array of string values
Private Function blnFindValueInArray(ByVal arrValues As Variant, _
        ByVal strSearchValues As String) As Boolean

    Dim i As Integer
   
    '*** Enable error handling
    On Error GoTo ErrorHandler
   
    '*** Iterate through the array seeking the value
    For i = 0 To UBound(arrValues, 1)
        If UCase(arrValues(i)) = UCase(strSearchValues) Then
            blnFindValueInArray = True
            Exit Function
        End If
    Next i
    
    blnFindValueInArray = False

CommonExit:
    Exit Function
    
ErrorHandler:
    '*** Raise an error to the calling procedure
    Err.Raise Err.Number, Err.Source & "[" & strMODULE_NAME & ".blnFindValueInArray()]", Err.Description
   
End Function
'*** This function returns an HTML string contain a select list of dates
Public Function strDateSelectList(ByVal strListName As String, _
    ByVal dtmStartingDate As Date, _
    ByVal strCurrentlySelectedDate As String, _
    ByVal strIntervalType As String, _
    ByVal intNumberOfIntervals As Integer, _
    Optional ByVal strEventProcedure) As String

    Dim strHTML As String
    Dim i As Integer
    Dim strListDateToAdd As String
   
    '*** Enable error handling
    On Error GoTo ErrorHandler
    
    '*** Make the number of intervals negative (for generating dates backwards from start date)
    intNumberOfIntervals = intNumberOfIntervals * -1
   
    '*** Initialize selection list
    strHTML = "<SELECT NAME=" & strListName & " SIZE='1' " & strEventProcedure & ">"
    
        '*** Add the specified range of dates to the list
        For i = 0 To intNumberOfIntervals Step -1
            strListDateToAdd = Format(DateAdd(strIntervalType, i, dtmStartingDate), "MM/DD/YYYY")
            '*** If the date being added <> the current end date then just add it
            If strListDateToAdd <> strCurrentlySelectedDate Then
                strHTML = strHTML & "<OPTION>" & strListDateToAdd
            '*** Else add it and make it the selected item in the list
            Else
                strHTML = strHTML & "<OPTION SELECTED>" & strListDateToAdd
            End If
        Next i
    strHTML = strHTML & "</SELECT>"
    
    '*** Return the HTML selection list
    strDateSelectList = strHTML
    
CommonExit:
    Exit Function
    
ErrorHandler:
    '*** Raise an error to the calling procedure
    Err.Raise Err.Number, Err.Source & "[" & strMODULE_NAME & ".strDateSelectList()]", Err.Description
   
End Function