Attribute VB_Name = "lib_sqlFilter"
'-------------------------------------------------------------------------------
'File         : lib_sqlFilter.bas
'               Copyright mpl by ERB software
'               All rights reserved
'               http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/concat_ws
'Environment  : VBA 2010 +
'Version      : 1.0.2
'Name         : fil*
'Author       : Stefan Erb (ERS)
'History      : 16.05.2014 - ERS - Creation
'-------------------------------------------------------------------------------
Option Explicit

'-------------------------------------------------------------------------------
' -- Public Member
'-------------------------------------------------------------------------------

'/**
' * Die möglichen Parameters. Sie lassens ich kombineren mit +
' * Pro Gruppe wird aber nur der erste gesetzte  verwendet:
' * fiCompEq+fiTypeBoolean+fiTypeDate wird als fiCompEq+fiTypeBoolean ausgewertet
' */
Public Enum fiParams
    fiNone = 0
    fiAutomatic = 2 ^ 0         'Standart anwenden
    finot = 2 ^ 1               'Logik umkehren
    fiCombineAnd = 2 ^ 2        'Alle Fleder mit AND verknüpfen
    fiCombineOr = 2 ^ 3         'Alle Fleder mit or verknüpfen
    [_START_COMPAIRE] = 5
        fiCompBetween = 2 ^ 5   'Between Value_1 and Value_2
        fiCompBetweenVB = 2 ^ 6 'Value_1 <= [feld] AND [feld] <= Value_2
        fiCompin = 2 ^ 7        'IN()
        fiCompNull = 2 ^ 8      'IS NULL
        fiCompEq = 2 ^ 9        '==
        fiCompNe = 2 ^ 10       '!=
        fiCompLt = 2 ^ 11       '<
        fiCompGt = 2 ^ 12       '>
        fiCompLe = 2 ^ 13       '<=
        fiCompGe = 2 ^ 14       '>=
        fiCompEmpty = 2 ^ 15    'ISEMPTY()
        fiCompNothing = 2 ^ 16  'NULL or TRIM()="" or EMPTY: TRIM(NZ([feld])) = ""
        fiCompLike = 2 ^ 17     'Ein LIKE Filter
        fiCompEqLike = 2 ^ 18   'Like oder EQ, je nachdem was der Wert hergibt
    [_END_COMPAIRE] = 18
    [_START_TYPE] = 20
        fiTypeDefault = 2 ^ 20  'Type ermitteln lassen
        fiTypeBoolean = 2 ^ 21  'Boolean
        fiTypeDate = 2 ^ 22     'Date
        fiTypeDateTime = 2 ^ 23 'DateTime
        fiTypeTime = 2 ^ 24     'Time
        fiTypeString = 2 ^ 25   'String
        fiTypeNumber = 2 ^ 26   'Number: Long, Integer, Double etc.
        fiTypeNull = 2 ^ 27     'Prüfung gegen NULL
        fiTypeEmpty = 2 ^ 28    'Prüfung gegen EMPTY
        fiTypeField = 2 ^ 29
    [_END_TYPE] = 29
End Enum

'Abgespeckte Version von fiParams für die Compiars
Public Enum fComp
    fcAutomatic = fiAutomatic
    fcNot = finot
    fcBetween = fiCompBetween
    fcBetweenVB = fiCompBetweenVB
    fcIn = fiCompin
    fcNull = fiCompNull
    fcEq = fiCompEq
    fcNe = fiCompNe
    fcLt = fiCompLt
    fcGt = fiCompGt
    fcLe = fiCompLe
    fcGe = fiCompGe
    fcEmpty = fiCompEmpty
    fcNothing = fiCompNothing
    fcLike = fiCompLike
    fcEqLike = fiCompEqLike
End Enum

'Abgespeckte Version von fiParams für die Types
Public Enum fType
    ftAutomatic = fiAutomatic
    ftNot = finot
    ftDefault = fiTypeDefault
    ftBoolean = fiTypeBoolean
    ftDate = fiTypeDate
    ftDateTime = fiTypeDateTime
    ftTime = fiTypeTime
    ftString = fiTypeString
    ftNumber = fiTypeNumber
    ftNull = fiTypeNull
    ftEmpty = fiTypeEmpty
    ftField = fiTypeField
End Enum
'-------------------------------------------------------------------------------
' -- Private Members
'-------------------------------------------------------------------------------

'/**
' * Parametetkatwgorien
' */
Private Enum fiParamType
    fiRest = 0
    fiCompaire = 1
    fiType = 2
End Enum
'/**
' * Parameterkategoriyinformationen
' */
Private Type fiParamTypeInfo
    start   As fiParams
    End     As fiParams
    Default As fiParams
End Type
'/**
' * gechate Parameterinformationen
' */
Private paramType(0 To 2)   As fiParamTypeInfo
Private isInitialized       As Boolean
Private rxNameWithSource    As Object   'Parst Feldnamen mit Tabellenangabe:    table.feld, [table].[feld], table![feld] etc -> [table].[feld]
Private rxNameOnly          As Object   'Parst Feldnamen ohne Tab. Angabe:      feld, [feld] -> [feld]


'-------------------------------------------------------------------------------
' -- Public Aliase
'-------------------------------------------------------------------------------

'/**
' * Erstellt einen einfachen Equal String
' * @param  String      Feldname
' * @param  ParamArray  Werte mit denen verglichen werden soll
' * @return String      Filterstring
' */
Public Function filEq( _
        ByVal iFieldName As String, _
        ParamArray iValues() As Variant _
) As String
    'ParamArray als Array übernehmen
    Dim values As Variant:  values = IIf(UBound(iValues) = -1, False, iValues)
    
    filEq = filByArray(iFieldName, fiAutomatic, values)
End Function

'/**
' * Erstellt einen einfachen Not Equal String
' * @param  String      Feldname
' * @param  ParamArray  Werte mit denen verglichen werden soll
' * @return String      Filterstring
' */
Public Function filNe( _
        ByVal iFieldName As String, _
        ParamArray iValues() As Variant _
) As String
    'ParamArray als Array übernehmen
    Dim values As Variant:  values = IIf(UBound(iValues) = -1, False, iValues)
    
    filNe = filByArray(iFieldName, finot + fiAutomatic, values)
End Function

'/**
' * Erstellt einen Feldervergleichsstring
' * @param  String      Feldname 1
' * @param  String      Feldname 2
' * @param  fiParams    Paramters zum erstellen des Filterstring. Diese sind kombinierbar: zB. fiNot+fiTypeString
' * @return String      Filterstring
' */
Public Function filFld( _
        ByVal iFieldName1 As String, _
        ByVal iFieldName2 As String, _
        Optional ByVal iParams As fComp = fcEq _
)
    initParamTypes
    filFld = filByArray( _
            iFieldName1, _
            cleanParamType(iParams, fiType, fiTypeField), _
            Array(iFieldName2) _
    )
End Function

'/**
' * Erstellt einen einfachen Between String
' * @param  String      Feldname
' * @param  Variant     Wert 1
' * @param  Variant     Wert 2
' * @param  fiParams    Paramters zum erstellen des Filterstring. Diese sind kombinierbar: zB. fiNot+fiTypeString
' * @return String      Filterstring
' */
Public Function filBetween( _
        ByVal iFieldName As String, _
        Optional ByVal iFrom As Variant = Null, _
        Optional ByVal iTo As Variant = Null, _
        Optional ByVal iParams As fType = ftDefault _
) As String
    Dim p As fiParams
    If Trim(Nz(iFrom)) = Empty And Trim(Nz(iTo)) = Empty Then
        'Kein FROM und kein TO definiert -> Rückgabe "TRUE"
        filBetween = "TRUE"
    ElseIf Trim(Nz(iFrom)) = Empty Then
        'Kein FROM definiert -> [FELD] <= TO
        p = cleanParamType(iParams, fiCompaire, fiCompLe)
        filBetween = filByArray(iFieldName, p, Array(iTo))
    ElseIf Trim(Nz(iTo)) = Empty Then
        'Kein TO definiert -> [FELD] >= FROM
        p = cleanParamType(iParams, fiCompaire, fiCompGe)
        filBetween = filByArray(iFieldName, p, Array(iFrom))
    Else
        p = cleanParamType(iParams, fiCompaire, IIf(iParams And fiCompBetweenVB, fiCompBetweenVB, fiCompBetween))
        filBetween = filByArray(iFieldName, p, Array(iFrom, iTo))
    End If
    
    
End Function

'/**
' * Erstellt einen einfachen And-String
' * @param  ParamArray  Werte mit denen verglichen werden soll
' * @return String      Filterstring
' */
Public Function filAnd( _
        ParamArray iValues() As Variant _
) As String
    Dim values() As Variant
    Dim idx As Integer: idx = -1
    Dim i As Integer: For i = 0 To UBound(iValues)
        If Not Trim(Nz((iValues(i)))) = Empty Then
            idx = idx + 1
            ReDim Preserve values(idx):    values(idx) = iValues(i)
        End If
    Next i
    
    'ParamArray als Array übernehmen
    If idx = -1 Then Exit Function
    If idx = 0 And IsArray(values(0)) Then values = values(0)
    If UBound(values) = 0 Then filAnd = values(0): Exit Function
    filAnd = filByArray("", fiCombineAnd, values)
End Function

'/**
' * Erstellt einen einfachen Or-String
' * @param  ParamArray  Werte mit denen verglichen werden soll
' * @return String      Filterstring
' */
Public Function filOr( _
        ParamArray iValues() As Variant _
) As String
    Dim values() As Variant
    Dim idx As Integer: idx = -1
    Dim i As Integer: For i = 0 To UBound(iValues)
        If Not Trim(Nz((iValues(i)))) = Empty Then
            idx = idx + 1
            ReDim Preserve values(idx):    values(idx) = iValues(i)
        End If
    Next i
    
    'ParamArray als Array übernehmen
    If idx = -1 Then Exit Function
    If idx = 0 And IsArray(values(0)) Then values = values(0)
    If UBound(values) = 0 Then filOr = values(0): Exit Function
    filOr = filByArray("", fiCombineOr, values)
End Function

'/**
' * Erstellt einen Filterstring
' * @param  String      Feldname
' * @param  fiParams    Paramters zum erstellen des Filterstring. Diese sind kombinierbar: zB. fiCompBetween+fiNot+fiTypeString
' * @param  ParamArray  Werte mit denen verglichen werden soll
' * @return String      Filterstring
' */
Public Function fil( _
        ByVal iFieldName As String, _
        ByVal iParams As fiParams, _
        ParamArray iValues() As Variant _
) As String
    'ParamArray als Array übernehmen
    Dim values As Variant:  values = IIf(UBound(iValues) = -1, False, iValues)
    fil = filByArray(iFieldName, iParams, values)
End Function



'-------------------------------------------------------------------------------
' -- Public Methodes
'-------------------------------------------------------------------------------

'/**
' * Erstellt einen Filterstring. Im Gegensatz zu fil() ist es kein ParamArray, sondern ein normaler Array für die Argumente
' * Alle Aliase greifen auf diese Funktion zu.
' * @param  String      Feldname
' * @param  fiParams    Paramters zum erstellen des Filterstring. Diese sind kombinierbar: zB. fiCompBetween+fiNot+fiTypeString
' * @param  Array       Werte mit denen verglichen werden soll
' * @return String      Filterstring
' */
Public Function filByArray( _
        ByVal iFieldName As String, _
        ByVal iParams As fiParams, _
        Optional ByRef iValues As Variant = False _
) As String

    'Combine-Filter Ausführen und Funktion verlassen
    If iParams And fiCombineAnd Then
        filByArray = "(" & IIf(Len(iFieldName) > 0, iFieldName & " AND ", "") & Join(iValues, " AND ") & ")"
        Exit Function
    ElseIf iParams And fiCombineOr Then
        filByArray = "(" & IIf(Len(iFieldName) > 0, iFieldName & " OR ", "") & Join(iValues, " OR ") & ")"
        Exit Function
    End If

    'Parameterkategoriene definieren
    initParamTypes
    
    'feldname ermitteln
    Dim fieldName As String: fieldName = getFieldName(iFieldName)
    
    'Vergleichsart ermitteln
    Dim compaire    As fiParams:    compaire = fiCompNothing
    If IsArray(iValues) Then compaire = getParam(iParams, fiCompaire, IIf(UBound(iValues) > 1, fiCompin, fiCompEqLike))
    
    'ValueType ermitteln und Werte formatieren
    Dim sqlValue1   As String
    Dim sqlValue2   As String
    Dim valueType   As fiParams:    valueType = getParam(iParams, fiType, paramType(fiType).Default)
    If Not compaire = fiCompNull And Not compaire = fiCompNothing Then
        If valueType = fiTypeDefault Then valueType = getType(iValues(0))
        If compaire = fiCompEqLike Then
            compaire = IIf(valueType = fiTypeString, fiCompLike, fiCompEq)
        End If
        'Vergleich auf NULL anpassen, falls der Value NULL ist
        If valueType = fiTypeNull Then
            compaire = fiCompNull
        'Vergleich auf EMPTY anpassen, falls der Value EMPTY ist
        ElseIf valueType = fiTypeEmpty Then
            compaire = fiCompEmpty
        Else
            'Bei Between und IN() auf EQ überschreiben falls zu wenig Values mitgegeben wurden
            If (compaire = fiCompBetween Or compaire = fiCompin) Then
                If UBound(iValues) = 0 Then
                    compaire = fiCompEq
                ElseIf Trim(Nz(iValues(1), "")) = Empty Then
                    compaire = fiCompEq
                End If
            End If
            'Wenn der value(0) ein * besitzt und compaire fiAutomatic, dann in LIKE ändern
            
            'Alle Values zu SQL-Values parsen
            Dim values() As String: ReDim values(UBound(iValues))
            Dim i As Integer: For i = 0 To UBound(iValues)
                values(i) = getSqlString(iValues(i), valueType)
            Next
            
            
            
            Select Case compaire
                Case fiCompBetween, fiCompBetweenVB
                                sqlValue1 = values(0)
                                sqlValue2 = values(1)
                Case fiCompin:  sqlValue1 = Join(values, ", ")
                Case Else:      sqlValue1 = values(0)
            End Select
            
        End If
    End If
    
    'Vergleichsstring defineren
    Dim pattern     As String
    Select Case compaire
        Case fiCompNull:        pattern = "{$name} {$not}IS NULL"
        Case fiCompEmpty:       pattern = "{$not}ISEMPTY({$name})"
        Case fiCompBetween:     pattern = "{$not}({$name} BETWEEN {$value1} AND {$value2})"
        Case fiCompBetweenVB:   pattern = "{$not}({$value1} <= {$name} AND {$name} <= {$value2})"
        Case fiCompin:          pattern = "{$name} {$not}IN ({$value1})"
        Case fiCompNe:          pattern = "NOT {$name} = {$value1}"
        Case fiCompLt:          pattern = "{$not}{$name} < {$value1}"
        Case fiCompGt:          pattern = "{$not}{$name} > {$value1}"
        Case fiCompLe:          pattern = "{$not}{$name} <= {$value1}"
        Case fiCompGe:          pattern = "{$not}{$name} >= {$value1}"
        Case fiCompNothing:     pattern = "{$not}TRIM(NZ({$name})) = """""
        Case fiCompEq:          pattern = "{$not}{$name} = {$value1}"
        Case Else:              pattern = "{$not}{$name} LIKE {$value1}"
    End Select
    
    'erstelle den Filterstring
    filByArray = Replace(pattern, "{$name}", fieldName)
    filByArray = Replace(filByArray, "{$value1}", Nz(sqlValue1))
    filByArray = Replace(filByArray, "{$value2}", Nz(sqlValue2))
    filByArray = Replace(filByArray, "{$not}", IIf(iParams And finot, "NOT ", Empty))
    filByArray = Trim(filByArray)
End Function

'-------------------------------------------------------------------------------
' -- Private Methodes
'-------------------------------------------------------------------------------

'/**
' * Gibt den Tybellen/Feldnamen aus einem String zurück
' * @param  String
' * @return String
' */
Private Function getFieldName(ByVal iFieldName As String) As String
    If rxNameOnly.Test(iFieldName) Then
        getFieldName = rxNameOnly.Replace(iFieldName, "[$1]")
    ElseIf rxNameWithSource.Test(iFieldName) Then
        getFieldName = rxNameWithSource.Replace(iFieldName, "[$1].[$2]")
    Else
        Err.Raise vbObjectError, "filByArray", "invalid Fieldname"
    End If
End Function

'/**
' * Initialisiert die ParamType-Definitionen
' */
Private Sub initParamTypes()
    If isInitialized And Not rxNameWithSource Is Nothing And Not rxNameOnly Is Nothing Then Exit Sub
    
    Set rxNameOnly = CreateObject("VBScript.RegExp")
    rxNameOnly.pattern = "^\[?([^.!\[\]]+)\]?$"
    Set rxNameWithSource = CreateObject("VBScript.RegExp")
    rxNameWithSource.pattern = "^\[?([^.!\[\]]+)\]?[.!]\[?([^.!\[\]]+)\]?$"
    
    'Compaire
    paramType(fiCompaire).start = fiParams.[_START_COMPAIRE]
    paramType(fiCompaire).End = fiParams.[_END_COMPAIRE]
    paramType(fiCompaire).Default = fiCompEq
    'Datatype
    paramType(fiType).start = fiParams.[_START_TYPE]
    paramType(fiType).End = fiParams.[_END_TYPE]
    paramType(fiType).Default = fiTypeDefault
    
    isInitialized = True
End Sub

'/**
' * Entfernt alle Paramter einer Kategorie und setzt den Default
' * @param  fiParams        Alle Parameters
' * @param  fiParamType     Kategorie des gesuchten Parameters
' * @param  fiParams        Standart
' * @return fiParams        Bereinigte Params
' */
Private Function cleanParamType(ByVal iParams As fiParams, ByVal iType As fiParamType, Optional ByVal iDefault As fiParams = fiNone) As fiParams
    cleanParamType = iParams
    Dim i As Integer: For i = paramType(iType).start To paramType(iType).End
        If (iParams And 2 ^ i) Then
            cleanParamType = cleanParamType - 2 ^ i
        End If
    Next i
    cleanParamType = cleanParamType + iDefault
End Function

'/**
' * Sucht den ersten gesetzten Param aus einer Paramkatergorie
' * @param  fiParams        Alle Parameters
' * @param  fiParamType     Kategorie des gesuchten Parameters
' * @param  fiParams        Standart
' * @return fiParams        erster gesetzter Parameter
' */
Private Function getParam(ByVal iParams As fiParams, ByVal iType As fiParamType, ByVal iDefault As fiParams) As fiParams
    getParam = iDefault
    Dim i As Integer: For i = paramType(iType).start To paramType(iType).End
        If (iParams And 2 ^ i) Then
            getParam = 2 ^ i
            Exit For
        End If
    Next i
End Function

'/**
' * Formatiert ein Parameter anhand des Datatypes
' * @param  Variant     Wert der in ein SQL-String umgesetzt werden soll
' * @param  fiParams    DataType
' * @return String      SQL-String des Wertes
' */
Private Function getSqlString(ByVal iValue As Variant, ByVal iType As fiParams) As String
    Select Case iType
        Case fiTypeNumber:      getSqlString = iValue
        Case fiTypeDate:        getSqlString = format(iValue, "\#mm\/dd\/yyyy\#")
        Case fiTypeDateTime:    getSqlString = format(iValue, "\#mm\/dd\/yyyy hh:nn:ss\#")
        Case fiTypeTime:        getSqlString = format(iValue, "\#hh:nn:ss\#")
        Case fiTypeBoolean:     getSqlString = CStr(iValue)
        Case fiTypeField:       getSqlString = getFieldName(iValue)
        Case Else:              getSqlString = """" & iValue & """"
    End Select
End Function

'/**
' * Ermittelt den Datentype eines Values
' * @param  Variant     Wert
' * @param  fiParams    Datatype
Private Function getType(ByRef iValue As Variant) As fiParams
    If IsNull(iValue) Then:                 getType = fiTypeNull: Exit Function
    If isEmpty(iValue) Then:                getType = fiTypeEmpty: Exit Function
    If TypeName(iValue) = "Boolean" Then:   getType = fiTypeBoolean: Exit Function
    If IsDate(iValue) Then:                 getType = fiTypeDateTime: Exit Function
    If IsNumeric(iValue) Then:              getType = fiTypeNumber: Exit Function
    If True Then:                           getType = fiTypeString: Exit Function
End Function