'/**
' * Copyright mpl by ERB software | http://wiki.yaslaw.info
' *
' * Wandelt ein Charakter in ein Unicode
' * @example: char2unicode("€") -> '\u20AC'
' * @param  String(1)   Charakter, der gewandelt werden soll
' * @return String      Unicode
' */
Private Function char2Unicode(ByVal iChar As String) As String
    char2Unicode = Hex(AscW(iChar)) 'Hex-Wert ermitteln
    char2Unicode = "\u" & String(4 - Len(char2Unicode), "0") & char2Unicode
End Function

'/**
' * Copyright mpl by ERB software | http://wiki.yaslaw.info
' *
' * Wandelt ein Unicode in ein Charakter
' * @example: unicode2char("\u20AC") -> '\€'
' * @param  String      Unicode
' * @return String      Char
' */
Private Function unicode2Char(ByVal iUnicode As String) As String
    unicode2Char = ChrW(replace(iUnicode, "\u", "&h"))
End Function

'/**
' * Copyright mpl by ERB software | http://wiki.yaslaw.info
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/index#replacea
' *
' * @example:   str = replaceA("abcd", array("a", "c"), "_")            '_b_d
' * @example:   str = replaceA("abcd", array("a", "c"), array("A", "C") 'AbCd
' *
' * @example:   str = replaceA("abcd", array("a", "c"), "_")            '_b_d
' * @example:   str = replaceA("abcd", array("a", "c"), array("A", "C") 'AbCd
' * @param  Variant                     expression containing substring to replace.
' * @param  Array<String>               find Required. Substring being searched for.
' * @param  Array<String> or String     replace Required. Replacement substring.
' * @param  Long                        Siehe VB-Doku zu replace()
' * @param  Long                        Siehe VB-Doku zu replace()
' * @param  VbCompareMethod             Siehe VB-Doku zu replace()
' * 2return String
' */
Private Function replaceA( _
        ByVal iExpression As Variant, _
        ByVal iFind As Variant, _
        ByVal iReplace As Variant, _
        Optional ByVal iStart As Long = 1, _
        Optional ByVal iCount As Long = -1, _
        Optional ByVal iCompare As VbCompareMethod = vbBinaryCompare _
) As String
    'Sicherstellen, dass wir einen String haben
    Dim str     As String:  str = CStr(Nz(iExpression))
    'Sicherstellen, dass filnd ein Array as iFind ist
    Dim find    As Variant: find = IIf(IsArray(iFind), iFind, Array(iFind))
    'Sicherstellen, dass repl ein Array aus iReplace ist
    Dim repl    As Variant: repl = IIf(IsArray(iReplace), iReplace, Array(iReplace))
    Dim i       As Integer

    'Die Arrays miteinander abstimmen. Wenn find mehr einträge als repl hat, so
    'wird der Rest bei repl mit seinem letzten Eintrag aufgefüllt.
    For i = UBound(repl) + 1 To UBound(find)
        ReDim Preserve repl(i)
        repl(i) = repl(0)
    Next i

    'Pro find ein Replace ausführen
    For i = 0 To UBound(find)
        str = replace(str, CStr(find(i)), CStr(repl(i)), iStart, iCount, iCompare)
    Next i

    'return
    replaceA = str
End Function

'/**
' * Copyright mpl by ERB software | http://wiki.yaslaw.info
' * Schneidet die Zeit ab
' * @param  Date        Datum + Zeit
' * @retrun Date        Datum ohne Zeit
' */
Public Function truncDate(Optional ByVal iDateTime As Variant = Null) As Date
    iDateTime = CDate(Nz(iDateTime, Now))
    truncDate = DateSerial(Year(iDateTime), Month(iDateTime), Day(iDateTime))
End Function

'/**
' * Prüft on ein Value ein Integer-Wert ist
' * @param  Variant     Zu prüfender Wert
' * @return Boolean
' */
Public Function isInteger(ByVal iExpression As Variant) As Boolean
    If Not IsNumeric(iExpression) Then Exit Function
    isInteger = (CInt(iExpression) = iExpression)
End Function

'/**
' * Prüft on ein Value ein Double-Wert ist
' * @param  Variant     Zu prüfender Wert
' * @param  Boolean     Flag ob ein Integer als Double akzeptiert werden soll
' * @return Boolean
' */
Public Function isDouble(ByVal iExpression As Variant, Optional ByVal iNoInteger As Boolean = True) As Boolean
    If Not IsNumeric(iExpression) Then Exit Function
    If iNoInteger And (CInt(iExpression) = iExpression) Then Exit Function
    isDouble = (CDbl(iExpression) = iExpression)
End Function


'/**
' * Bit Comparison
' * geeignet für MS Access SQL-Statements
' * @example:   Alle User mit Schreibrecheten gem. CHMOD hat
' *             SELECT * FROM [user] WHERE BITCOMP([rigths], 2)
' * @param  Integer
' * @param  Integer
' * @return Boolean
' */
Public Function bitComp(ByVal iBytes As Integer, ByVal iBit As Integer) As Boolean
    bitComp = (iBytes And iBit)
End Function

'/**
' * Die Idee hatte ich aus PHP. Ein Befehl für ein Regulärer Ausdruck-Replace ohne Mehrzeiler
' * @example            new_string = preg_replace("([\W])", "_", "Hallo: Welt2!")
' * @param  String      Pattern analog RegExp
' * @param  String      Ersetzungsstring anaog zu RegExp.replace
' * @param  String      Der String der bearbeitet werden soll
' * @param  Boolean     Multiline-Eigenschaft von RegExp
' * @param  Boolean     IgnoreCase-Eigenschaft von RegExp
' * @param  Boolean     Global-Eigenschaft von RegExp
' * @return String
' */
Public Function preg_replace( _
        ByVal iPattern As String, _
        ByVal iReplacement As String, _
        ByVal iSubject As String, _
        Optional ByVal iMultiLine As Boolean = True, _
        Optional ByVal iIgnoreCase As Boolean = True, _
        Optional ByVal iGlobal As Boolean = True _
) As String
    Dim rx  As New regexp

    rx.Multiline = iMultiLine
    rx.Global = iGlobal
    rx.IgnoreCase = iIgnoreCase

    rx.pattern = iPattern

    preg_replace = IIf(rx.test(iSubject), rx.replace(iSubject, iReplacement), iSubject)

    Set rx = Nothing
End Function



'/**
' * Führt eine Callback-Funktion über alle Trefferelemente aus und ersetzt diese im Text
' * @example            Ein Beispiel. ich habe eine Funktion getMin(v1,v2) welche den kleineren der Beiden Werte zurückgibt.
' *                     Nun will ich in einem Text alle 'zwieschen v1 und v2' damit berechnen lassen und ersetzen
' *                     Print preg_replace_callback("zwieschen (\d) und (\d)", "getMin", "wir haben zwieschen 1 und 4 Biere und zwieschen 5 und 3 Weine")
' *                     Eingabe: 'wir haben zwieschen 1 und 4 Biere und zwieschen 5 und 3 Weine'
' *                     Ausgabe: 'wir haben 1 Biere und 3 Weine'
' * @param  String      Pattern analog RegExp
' * @param  String      Name der Callback-Funktion
' * @param  String      Der String der bearbeitet werden soll
' * @param  Boolean     Multiline-Eigenschaft von RegExp
' * @param  Boolean     IgnoreCase-Eigenschaft von RegExp
' * @param  Boolean     Global-Eigenschaft von RegExp
' * @return String
' */
Public Function preg_replace_callback( _
        ByVal iPattern As String, _
        ByRef iCallback As Variant, _
        ByVal iSubject As String, _
        Optional ByVal iMixedUserData As String = vbNullString, _
        Optional ByVal iMultiLine As Boolean = True, _
        Optional ByVal iIgnoreCase As Boolean = True, _
        Optional ByVal iGlobal As Boolean = True _
) As String
    Dim rx      As New regexp
    Dim mc      As MatchCollection
    Dim m       As match
    Dim smc()   As String
    Dim ret     As String
    Dim i, k

    rx.Multiline = iMultiLine
    rx.Global = iGlobal
    rx.IgnoreCase = iIgnoreCase

    rx.pattern = iPattern
    Set mc = rx.execute(iSubject)

    preg_replace_callback = iSubject
    For i = mc.count - 1 To 0 Step -1
        Set m = mc.item(i)
        'Alle Submatches zu Argumenten zusammenführen
        ReDim smc(m.SubMatches.count - 1)
        For k = 0 To UBound(smc): smc(k) = """" & m.SubMatches(k) & """": Next k
        ret = CStr(Eval(iCallback & "(" & join(smc, ",") & ")"))
        'Unterstring ersetzen
        preg_replace_callback = Left(preg_replace_callback, m.FirstIndex) & ret & Mid(preg_replace_callback, m.FirstIndex + m.Length + 1)
    Next i

    Set m = Nothing
    Set mc = Nothing
    Set rx = Nothing

End Function



'/**
' * Erstellt aus einem String einen technischen Namen
' * @used   replaceUmlaute  http://wiki.yaslaw.info/wikka/VbVbaFunctions#replaceUmlaute
' * @param  String      Name der gewandelt werden soll
' * @param  Integer     Maximale Länge
' * @param  VbStrConv   Art der Konvertierung. Lower/Uper/Proper-Case
' * @return String
' */
Public Function translateToTechName( _
        ByVal iName As String, _
        Optional ByVal iMaxLen As Integer = 255, _
        Optional ByVal iStrConv As VbStrConv = vbUpperCase _
) As String

    translateToTechName = StrConv(iName, iStrConv)
    regexp.IgnoreCase = True
    regexp.Global = True
    translateToTechName = replaceUmlaute(translateToTechName, True)

    regexp.pattern = "([\W])"
    translateToTechName = regexp.replace(translateToTechName, "_")

    translateToTechName = Left(translateToTechName, iMaxLen)

End Function




'/**
' * Ersetzt alle Umlaute durch Xe
' * Idee by http://www.office-loesung.de/ftopic142553_0_0_asc.php
' * @param  String      Text in dem die Umlaute ersetzt werden soll
' * @param  Boolean     Flag ob bei Grossbuchstaben der Ersatzwert vollständig in Grossbuchstaben geandelt werden soll. Default: false
' *                     False: Ä -> Ae    True: Ä -> AE
' * @return String
' */
Public Function replaceUmlaute(ByVal iSubject As String, Optional ByVal iCaseSave As Boolean = False) As String
    replaceUmlaute = iSubject
    replaceUmlaute = replace(replaceUmlaute, "Ä", IIf(iCaseSave, "AE", "Ae"), 1, -1, vbBinaryCompare)
    replaceUmlaute = replace(replaceUmlaute, "Ü", IIf(iCaseSave, "UE", "Ue"), 1, -1, vbBinaryCompare)
    replaceUmlaute = replace(replaceUmlaute, "Ö", IIf(iCaseSave, "OE", "Oe"), 1, -1, vbBinaryCompare)
    replaceUmlaute = replace(replaceUmlaute, "ä", "ae", 1, -1, vbBinaryCompare)
    replaceUmlaute = replace(replaceUmlaute, "ü", "ue", 1, -1, vbBinaryCompare)
    replaceUmlaute = replace(replaceUmlaute, "ö", "oe", 1, -1, vbBinaryCompare)
    replaceUmlaute = replace(replaceUmlaute, "ß", "ss", 1, -1, vbBinaryCompare)
End Function



'/**
' * Analog zu MySQL FIND_IN_SET()
' * Kann in Access vor allem bei nichtnormalisierten Tabellen verwendet werden
' * @param  String  Element das gesucht wird
' * @param  String  Das Set von Elementen, mit Komma getrennt
' * @return Integer oder False
' * @example    If find_in_set("d", "a,b,c,d") Then ...
' * @example    SELECT ... WEHRE find_in_set('d', field1)
' */
Public Function find_in_set(ByVal iSearch As String, ByVal iSet As String) As Variant
    Dim parts() As String
    Dim index   As Integer
On Error GoTo Err_Handler
    find_in_set = False
    parts = split(iSet, ",")
    For index = 0 To UBound(parts)
        If Trim(parts(index)) = iSearch Then
            find_in_set = index + 1
            Exit For
        End If
    Next index
    Exit Function
Err_Handler:
    find_in_set = False
End Function



'/**
' * Wandelt alle Spaltennamen in technische Namen. Praktisch nach einem Erstimport aus Excel
' * @used               http://wiki.yaslaw.info/wikka/VbAccessFunctions#translateToTechName
' * @param  String      Tabellenname
' */
Public Sub translateTableFields(ByVal iTableName As String)
    Dim tbl     As DAO.TableDef
    Dim dbs     As DAO.Database
    Dim fld     As DAO.field

    Set dbs = CurrentDb
    Set tbl = dbs.TableDefs(iTableName)

    For Each fld In tbl.fields
        fld.name = translateToTechName(fld.name)
    Next

    Set fld = Nothing
    Set tbl = Nothing
    Set dbs = Nothing
End Sub