Eine Klasse um SQL-Scripts in seine einzelnen Befehle zu zerteilen und diese auszuführen. Diverse DML, DDL, und DCL werden unterstützt.

Diese Klasse parst ein SQL-Scripte mit verschiedenen SQL-Befehlen. Einerseits ist sie ein Kontainer mit verschiedenen Befehlen drin, anderseits kann sie ein einzelner Befehl sein. Die einzelnen Befehle können auf die Datenbank angewendet werden.

• [VBA][Access] printRs() Eine Funktion um Datensätze als Plaintext auszugeben
• [VBA] sprintf(), vsprintf() sprintf() für VBA.

• [VBA][Access] Klasse SQLScript - SQL Befehle Diverse Beispiele zu den SQL-Befehlen
• [VBA][Access] SQL Console Eine SQL-Konsole für MS Access basierend auf der SQLScript Klasse

Die Klasse SQLScript ist einerseits ein Container mit verschiedenen Befehlen, anderseits auch ein Befehl selber. Je nach der Eigenschaft des Property action.
Am besten sieht man das im Beispiel Öffnen einer Script-Datei und die SQL-Statements einzeln ausführen

Der SQL-Type.

DQL (Data Query Language) wird als DCL gehandhabt

• stNA N/A
• stDML Data Manipulation Language (DML, deutsch „Datenverarbeitungssprache“): Sprache oder Sprachteile für das Abfragen, Einfügen, Ändern oder Löschen von Nutzdaten
• stDDL Data Definition Language (DDL, deutsch „Datenbeschreibungssprache“): Sprache oder Sprachteile für das Anlegen, Ändern und Löschen von Datenstrukturen
• stDCL Data Control Language (DCL, deutsch „Datenaufsichtssprache“): Sprache oder Sprachteile für die Zugriffskontrolle

Dieser Enumerator beschreibt, um was ür ein SQL-Script es sich handelt

• saAutomatic Die Action ist nicht definiert und soll ermittelt werden
• saContainer Das Objekt ist ein Container. Also die Liste mit den versch. SQLs
• DDL Data Definition Language (DDL, deutsch „Datenbeschreibungssprache“)
  • saCreateView Abfrageerstellungsscript
  • saCreate Objekterstellungsscript
  • saAlter Ändern eines Objektes (Tabelle, Index etc)
  • saDrop Löschen eines Objektes (Tabelle, Index View, etc)
• DML Data Manipulation Language (DML, deutsch „Datenverarbeitungssprache“)
  • saUpdate
  • saInsertOnDuplicateUpdate Spezialfall INSERT INTO … ON DUPLICATE KEY UPDATE ….
  • saInsert
  • saDelete
• DCL Data Control Language (DCL, deutsch „Datenaufsichtssprache“)
  • saSelect Ein einfaches Select als RS zurückgeben
  • saSelectWithParams Ein einfaches Select mit Parametern als RS zurückgeben
  • saShow Ausgeben von Auflistungen von Objekten
  • saShowIn Spezialform von saShow
  • saShowObjects Spezialform von saShow für Objekte
  • saShowVariables Spezialform von saShow für Variablen
  • saSet Setzt Variablen
  • saClearCache löscht alle oder einzelne Variabeln
  • saPrompt Zurückgeben eines Textes
• saDirect Alle nicht definierten werden direkt ausgeführt

Objekttypen die von Aktionen betroffen sein können werden mit dem Public Property affectedType ausgegeben

• soTable Tabelle
• soQueryDef Abfrage
• soIndex Index einer Tabelle
• soParams SQL-Variable

Action. Wie soll sich das Script verhalten. Dieser Enum ist kombinierbar spDirect+spOverwrite

• spNone
• spDirect Ohne nachfragen ausführen
• spOverwrite Bestehendes Objekt ohne Nachfragen überschreiben
• spIgnore Fehler ignorieren und weiterfahren
• spLogText Gibt anstelle des returnValue gleich den genierten logText zurück

Container und Statement

result = container.execute([paramters] [,action]

Ist das Objekt ein Container, werden alle Scripte in dem Container ausgeführt.
Der Rückgabewert ist je nach action unterschiedlich.

'/**
' * Führt anhand der Action das Script aus
' * @param  sqlParams
' * @param  ddlAction   (OUT) Angabe, um was für eine Action es sich wirklich handelt
' * @return Variant     Je nach Script unterschiedlich. Recordset, Value, QueryDef, Boolean.
' *                     Wenn als Paramter spOutText ist es ein lesbaerer Rückgabestring
' */
Public Function execute(Optional ByVal iParams As sqlParams = spNone, Optional ByRef oAction As sqlActions) As Variant

Liste der Rückgabetypen nach Action

Container

Set container = SQLScript.instanceByFileDialog([filePath])

Erstellt ein Container aus einer Datei, die mittels dem FileDialog ausgewählt wird

'/**
' * Erstellt ein DDLScriptcontainer aus einem File, das über den Filedialog ausgewählt wurde
' * @example    Öffnen des FileDialoges mit direktem ausführen des Codes
' *             Call SQLScript.instanceByFileDialog().execute
' * @param  String      Der Pfad/Dateiname, wo der Dialog öffnet
' * @retrun SQLScript   oder bei Abrruch Nothing
' */
Public Static Function instanceByFileDialog(Optional ByVal iFilePath As String = Empty) As SQLScript

Container

Set container = SQLScript.instanceByFilePath(filePath)

Erstellt ein Container aus einer Datei. Der Datepafad muss bekannt sein.

'/**
' * Erstellt ein DDLScriptcontainer aus einem File, das über einen direkten Pfad geöffnet wird
' * @example    Öffnen und ausführen des ersten SQLs aus einer Date ohne Nachfrage
' *             SQLScript.instanceByFilePath("C:\temp\vba_sql_test.sql")(0).execute(spDirect)
' * @param  String      Der Pfad/Datreiname
' * @retrun SQLScript
' */
Public Static Function instanceByFilePath(ByVal iFilePath As String) As SQLScript

Container

container.readFile filePath

Liest eine Scriptdatei in ein bestehenden Container

'/**
' * Eine Datei einlesen und auswerten
' * @param  String  Dateipfad
' */
Public Sub readFile(ByVal iFilePath As String)

Container

container.readText sql-Script-String

Parst ein SQL-Script-String. Zerlegt ihn in einzelne Scripte und erstellt im Conatianer jeweils ein Script-Objekt

'/**
' * Ein Script verarbeiten
' * @param  String      ScriptText (mehrere Scripts)
' */
Public Sub readText(ByVal iScriptText As String)

Container

container.addNewScript(command [,action])

Erstellt in einem Container ein neues Script aus einem SQL-Statement.
Siehe auch das Beispiel Manuell erstellter Container

'/**
' * Creiert ein neues Script und hängt es an
' * Diese Funktion kann nur in einem ScriptContainer ausgeführt werden
' * @param  String      SQL-Statement
' * @param  sqlActions
' * @return Boolean     Gibt an, ob das iScript mit der Action iAction geparst werden konnte
' */
Public Function addNewScript(ByVal iCmd As String, Optional ByVal iAction As sqlActions = saAutomatic) As Boolean

Statement

script = SQLScript.instanceSubScript(command [,action])

Erstellt eine Instance für ein einzelnes Script aus einem SQL-Statement heraus.
Siehe Beispiel Ein einsames Script erstellen und ausführen

'/**
' * Erstellt eine Instanze eines neuen Subscriptes
' * @param  String          SQL-String
' * @param  sqlActions      Art des Scriptes. Bei -1 wird die Action ermittelt
' * @retrun SQLScript
' */
Public Static Function instanceSubScript(ByVal iCmd As String, Optional ByVal iAction As sqlActions = saAutomatic) As SQLScript

Gibt die Art des Scriptes zurück. Also, was für eine Aktion ausgeführt wird. Der Rückgabewert ist vom Type sqlActions

Public Property GET action() AS sqlActions

Vom Script betroffenes Objekt. Tabellen-, Abfrage-, Indexnamen etc.

Public Property Get affectedItem() As String

Der Objekttyp, der vom Script betroffen ist. Der Rückgabewert ist vom Type objectType

Public Property Get affectedType() As objectType

Die Information um was für eine Art Script es sich handelt. Der Rückgabewert ist vom Type sqlType

Public Property Get sqlType() As sqlType

Wenn die Instanz ein Container ist, gibt count die Anzahl Scripte zurück. Ansonsten -1

Public Property Get count() As Long

Der Rückgabewert von Execute kann über dieses Property nachträglich nochmals ausgelesen werden

Public Property Get returnValue() As Variant

Gibt einen Text zurück, der die ausgeführten Aktionen dokumentiert

Public Property Get logText() As String

Der pFad des Scriptfiles. Macht ntürlich auch nur bei einem Containerobjekt Sinn

Public Property Get filePath() As String

Die folgenden Funktionen müssen seperat geladen werden, damit die Klasse SQLScript funktioniert. Sie sind zu gross um Sinnvoll in die Klasse zu kopieren.

• [VBA] sprintf(), vsprintf(): Funktion sprintf() ist nützlich um Texte zu parsen

Für die Ausgabe der QueryDefs und der Recordsets verwende ich die Funktion [VBA][Access] printRs()

Eine Script-Datei öffnen und alle Script ausführen

Dim scriptContainer As SQLScript
Set scriptContainer = SQLScript.instanceByFilePath("C:\temp\sql\vba_sql_test2.sql")
scriptContainer.execute

Jeder Befehl einzeln ausführen und die action und sqlType ausgeben

Dim scriptContainer As SQLScript
Dim script  As SQLScript
 
Set scriptContainer = SQLScript.instanceByFilePath("C:\temp\sql\vba_sql_test2.sql")
 
For Each script In scriptContainer
        script.execute
        Debug.Print script.sqlType, script.action
Next script

Dank der Instance-Funktionen kann man einfache Scripte ohne grossen Codeaufwand ausführen. Beide folgenden Script haben dasselbe Resultat

printRs SQLScript.instanceSubScript("SHOW TABLES").execute()
print SQLScript.instanceSubScript("SHOW TABLES").execute(spLogText)

| table_name                  | row_count | last_update         | indexes                                    |
|-----------------------------|-----------|---------------------|--------------------------------------------|
| ADDON_SQL_CONSOLE_SESSION   | 19        | 13.04.2015 12:57:28 | ID, PrimaryKey (PK)                        |
| t_sql_test                  | 1         | 17.04.2015 10:08:24 | idx_sql_val, Index_F44530CA_8088_4FED (PK) |
| tbl_t1                      | 2         | 13.04.2015 12:09:01 | idx_val, Index_B4C4285A_B98F_4415 (PK)     |
| TODO: ADDON_SQL_CONSOLE_LOG | 0         | 13.04.2015 12:26:40 | PrimaryKey (PK), SESSION_ID, STEP_ID

Und hier noch ein Beispiel mit FileDialog und MsgBox um eine Scriptdatei auszuführen. Dazu verwende ich einfach die Instanzierung über instanceByFileDialog] und die Ausgabe von execute mit dem sqlParams spLogText.

MsgBox SQLScript.instanceByFileDialog().execute(spLogText)

Ein Container kann auch Manuell gefüllt werden. Hier ein Beispiel in dem zuerst ein SET ausgeführt wird und anschliessend ein SELECT.

Dim scriptContainer As New SQLScript
'Neu initialisierte Objekte werden automatisch als Container definiert
'Dies könnte über den action-Parameter übersteuert werden
 
 
With scriptContainer
    .addNewScript "SET a = 123"
    .addNewScript "SELECT a"
    .addNewScript "SHOW VARIABLES"
 
    Debug.Print .item(0).execute
    printRs .item(1).execute
    printRs .item(2).execute
End With

 123 
| a   |
|-----|
| 123 |
| variable_name | type | value |
|---------------|------|-------|
| A             | BYTE | 123   |

Siehe [VBA][Access] Klasse SQLScript - SQL Befehle

sqlscript.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "SQLScript"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'-------------------------------------------------------------------------------
'File         : SQLScript.cls
'               Copyright mpl by ERB software
'               All rights reserved
'               http://wiki.yaslaw.info/dokuwiki/doku.php/vba/
'Environment  : VBA 2007+
'Version      : 1.0.0
'Name         : SQLScript
'Author       : Stefan Erb (ERS)
'History      : 16.04.2015 - ERS - Creation
'Description  : Diese Klasse parst ein SQL-Scripte. Einerseits ist sie ein Kontainer mit verschiedenen Scripten drin, anderseits
'               kann sie ein einzelnes Script sein. Die Scripte sind ausführbar
'Libraries    : lib_printf.bas      http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/printf/index
'-------------------------------------------------------------------------------
 
'-------------------------------------------------------------------------------
' ! WICHTIG !
'-------------------------------------------------------------------------------
'Installation : Das Modul hat versteckte Attribute. Damit diese aktiv übernommen werden reicht es nicht aus, den Code in ein
'               neues Modul zu kopieren. Man muss das Modul aus der Datei nach VBA importieren.
'-------------------------------------------------------------------------------
Option Explicit
 
'-------------------------------------------------------------------------------
' -- Public Members
'-------------------------------------------------------------------------------
 
 
'/**
' * Auswahl der verschiedenen Script-Aktionen
' */
Public Enum sqlActions
    saAutomatic = -1          'Die Action ist nicht definiert und soll ermittelt werden.
    saContainer = 0           'Es handelt sich im Ein Container. Also die Liste mit den versch. SQLs
    [_FIRST] = 1
    [_DDL_FIRST] = [_FIRST]
    saCreateView = [_FIRST]   'Spezialfall CREATE VIEW ... AS ...
    saCreate
    saAlter
    saDrop
    [_DDL_LAST] = saDrop
    [_DML_FIRST]
    saUpdate = [_DML_FIRST]
    saInsertOnDuplicateUpdate 'Spezialfall INSERT INTO ... ON DUPLICATE KEY UPDATE ....
    saInsert
    saDelete
    [_DML_LAST] = saDelete
    [_DCL_FIRST]
    saSelect = [_DCL_FIRST]  'Ein einfaches Select als RS zurückgeben
    saSelectWithParams
    saShow                    'SHOW (COLUMNS|INDEX) FROM
    saShowIn                  'SHOW (COLUMNS) IN (SELECT ....)
    saShowObjects             'SHOW (TABLES|VIEWS)
    saShowVariables
    saSet
    saClearCache                'Der Variablencache wird gelöscht
    saPrompt
    [_DCL_LAST] = saPrompt
    saDirect                  'Alle nicht definierten werden direkt ausgeführt
    [_LAST] = saDirect
End Enum
 
'/**
' * SQL Type
' * DQL (Data Query Language) wird als DCL gehandhabt
' */
Public Enum sqlType
    stNA        'N/A
    stDML       'Data Manipulation Language (DML, deutsch „Datenverarbeitungssprache“): Sprache oder Sprachteile für das Abfragen, Einfügen, Ändern oder Löschen von Nutzdaten
    stDDL       'Data Definition Language (DDL, deutsch „Datenbeschreibungssprache“): Sprache oder Sprachteile für das Anlegen, Ändern und Löschen von Datenstrukturen
    stDCL       'Data Control Language (DCL, deutsch „Datenaufsichtssprache“): Sprache oder Sprachteile für die Zugriffskontrolle
End Enum
 
'/**
' * Objekttypen die von Aktionen betroffen sein können
' * Werden mit dem Public Property affectedType ausgegeben
' */
Public Enum objectType
    soTable = acTable
    soQueryDef = acQuery
    soIndex = 101
    soParams
End Enum
 
'/**
' * Action. Wie soll sich das Script verhalten
' */
Public Enum sqlParams
    spNone = 0
    spDirect = 2 ^ 0        'Ohne nachfragen ausführen
    spOverwrite = 2 ^ 1     'Bestehendes Objekt überschreiben
    spIgnore = 2 ^ 2        'Fejhler ignorierenu nd weiterfahren
End Enum
'-------------------------------------------------------------------------------
' -- Private Members
'-------------------------------------------------------------------------------
Const ERR_SQLScript_ONLY_FOR_CONTAINER = vbObjectError + 101
Const ERR_SQLScript_NOT_FOR_CONTAINER = vbObjectError + 102
 
'ADODB Constant
Private Const adVarChar = 200
Private Const adInteger = 3
Private Const adDate = 7
Private Const adBoolean = 11
 
'Properties für saContainer
Private pScriptsO As Collection              'Gefunden Scripts als SQLScript in der Collection für den NewEnum
 
'Properties für die Einzelscript
Private pAction As sqlActions
Private pError As Object
Private pFilePath As String
Private pCmd As String
Private pindex As Long
Private pAffectedItem As String
Private pAffectedValue As Variant
Private pAffectedType As objectType
Private pParent As SQLScript
Private pWithUndo As Boolean
Private pUndoSql As String
Private pSqlVariables As Object
Private pSqlVariablesString As Object
Private pSqlType As sqlType
 
 
'-------------------------------------------------------------------------------
' -- Public methodes
'-------------------------------------------------------------------------------
 
'/**
' * Standartfunktion zum durchiterieren
' */
Public Function NewEnum() As IUnknown
Attribute NewEnum.VB_UserMemId = -4
'Attribute NewEnum.VB_UserMemId = -4
    Set NewEnum = pScriptsO.[_NewEnum]
End Function
 
'/**
' * gibt ein Script anhand des Indexes zurück
' * @param  Long    Index
' * @return SQLScript
' */
Public Property Get item(ByVal iIndex As Long) As SQLScript
Attribute item.VB_UserMemId = 0
'Attribute item.VB_UserMemId = 0
    If pScriptsO.count = 0 Then Exit Property
    Set item = pScriptsO(iIndex + 1)
End Property
 
'-------------------------------------------------------------------------------
' -- Creators
'-------------------------------------------------------------------------------
 
'/**
' * Erstellt ein DDLScriptcontainer aus einem File, das über den Filedialog ausgewählt wurde
' * @example    Öffnen des FileDialoges mit direktem ausführen des Codes
' *             Call SQLScript.instanceByFileDialog().execute
' * @param  String      Der Pfad/Dateiname, wo der Dialog öffnet
' * @retrun SQLScript   oder bei Abrruch Nothing
' */
Public Static Function instanceByFileDialog(Optional ByVal iFilePath As String = Empty) As SQLScript
    Dim fld As Object: Set fld = Application.FileDialog(3)  'msoFileDialogFilePicker = 3
    fld.Filters.Clear
    fld.Filters.add "SQL-File", "*.sql"
    fld.Filters.add "All Files", "*.*"
    fld.InitialFileName = iFilePath
    If fld.Show <> 0 Then
        Set instanceByFileDialog = New SQLScript
        instanceByFileDialog.readFile (fld.SelectedItems(1))
    End If
    Set fld = Nothing
End Function
 
'/**
' * Erstellt ein DDLScriptcontainer aus einem File, das über einen direkten Pfad geöffnet wird
' * @example    Öffnen und ausführen des ersten SQLs aus einer Date ohne Nachfrage
' *             SQLScript.instanceByFilePath("C:\temp\vba_sql_test.sql")(0).execute(spDirect)
' * @param  String      Der Pfad/Datreiname
' * @retrun SQLScript
' */
Public Static Function instanceByFilePath(ByVal iFilePath As String) As SQLScript
    Set instanceByFilePath = New SQLScript
    instanceByFilePath.readFile (iFilePath)
End Function
 
'/**
' * Erstellt eine Instanze eines neuen Subscriptes
' * @param  String          SQL-String
' * @param  sqlActions      Art des Scriptes. Bei -1 wird die Action ermittelt
' * @retrun SQLScript
' */
Public Static Function instanceSubScript(ByVal iCmd As String, Optional ByVal iAction As sqlActions = saAutomatic) As SQLScript
    Set instanceSubScript = New SQLScript
    instanceSubScript.initScript iCmd, iAction
End Function
 
 
'/**
' * Eine Datei einlesen und auswerten
' * @param  String  Dateipfad
' */
Public Sub readFile(ByVal iFilePath As String)
    pFilePath = iFilePath
    readText CreateObject("Scripting.FileSystemObject").OpenTextFile(pFilePath, 1).ReadAll 'ForReading = 1
End Sub
 
'/**
' * Ein Script verarbeiten
' * @param  String      ScriptText (mehrere Scripts)
' */
Public Sub readText(ByVal iScriptText As String)
    Set pScriptsO = New Collection
'    action = saContainer
 
    'Alles einlesen und Kommentare entfernen
    Dim txt As String: txt = rxSqlComment.Replace(iScriptText, "")
    'Alle maskierten Zeichen nach unicode parsen
    txt = masked2uniode(txt)
 
    Dim commands() As String: commands = Split(txt, ";")
 
    'Jeder Abschnitt mit allen Pattern vergleichen
    Dim scriptO As SQLScript
    Dim cmd As Variant: For Each cmd In commands
        Dim pAction As Integer: For pAction = sqlActions.[_FIRST] To sqlActions.[_LAST]
            If rxAction(pAction).test(trims(cmd)) Then
                add SQLScript.instanceSubScript(cmd, pAction)
                Exit For
            End If
        Next pAction
    Next cmd
End Sub
 
'/**
' * Diese Funktion kann nur in einem ScriptContainer ausgeführt werden
' * @param  SQLScript
' */
Public Sub add(ByRef iScriptO As SQLScript)
    If Not pAction = saContainer Then Err.Raise ERR_SQLScript_ONLY_FOR_CONTAINER, "SQLScript.add", "Object-Action is not a Container"
    iScriptO.index = pScriptsO.count    'Index zuweisen
    Set iScriptO.parent = Me
    iScriptO.withUndo = Me.withUndo
    pScriptsO.add iScriptO
End Sub
 
 
'/**
' * initialisiert eine ScriptObjekt
' * @param  ddlaAction
' * @param  String          Der Script-String
' */
Public Sub initScript(ByVal iCmd As String, Optional ByVal iAction As sqlActions = saAutomatic)
    Static pRx As Object: If pRx Is Nothing Then Set pRx = cRx("/;\s*$/")
    pAction = iAction
    pCmd = pRx.Replace(iCmd, Empty)
    If iAction = saAutomatic Then
        For pAction = sqlActions.[_FIRST] To sqlActions.[_LAST]
            If rxAction(pAction).test(trims(iCmd)) Then Exit For
        Next pAction
    End If
End Sub
 
 
'/**
' * Führt anhand der Action das Script aus
' * @param  sqlParams
' * @param  ddlAction   Angabe, um was für eine Action es sich wirklich handelt
' * @return Boolean     true: Scripte weiterführen, False: abbruch
' */
Public Function execute(Optional ByVal iParams As sqlParams = spNone, Optional ByRef oAction As sqlActions) As Variant
On Error GoTo Err_Handler
    oAction = action
    Select Case action
        'Die Instanz ist ein Scriptcontainer. Alle Scripts des Containers ausführen. Rückgabewerte werden ignoriert
        Case saContainer:                                                           '@return: Anzahl Scripts
            Dim script As SQLScript: For Each script In pScriptsO
                script.execute iParams
            Next script
            execute = script.count
        'Die Einzelscripts:
        Case saSelect:                    Set execute = queryDefWithParams          '@return: QueryDef
        Case saSelectWithParams:          Set execute = queryDefWithParams          '@return: QueryDef
        Case saShow:                      Set execute = executeShow                 '@return: ADODB.Recordset
        Case saShowIn:                    Set execute = executeShow                 '@return: ADODB.Recordset
        Case saShowObjects:               Set execute = executeShow                 '@return: ADODB.Recordset
        Case saShowVariables:             Set execute = executeShow                 '@return: ADODB.Recordset
        Case saPrompt:                    execute = executePrompt                   '@return: String                Auszugebender Text
        Case saSet:                       execute = executeSet                      '@return: Variant               Wert des Set-Befehls
        Case saClearCache:                execute = executeClearCache               '@return: Boolean
        Case saCreateView:                execute = executeCreateOrReplaceView(iParams, oAction)        '@return: Boolean
        Case saCreate:                    execute = executeCreate(iParams)          '@return: Boolean
        Case saDrop:                      execute = executeDrop(iParams)            '@return: Boolean
        Case saAlter:                     execute = executeAlter(iParams)           '@return: Boolean
        Case saInsertOnDuplicateUpdate:   execute = executeInsertOnDuplicateUpdate(iParams, oAction)    '@return: Long     Anzahl betroffener Zeilen
        Case saInsert:                    execute = executeDirect(iParams, oAction) '@return: Long     Anzahl betroffener Zeilen
        Case saUpdate:                    execute = executeDirect(iParams, oAction) '@return: Long     Anzahl betroffener Zeilen
        Case saDelete:                    execute = executeDelete(iParams)          '@return: Long     Anzahl betroffener Zeilen
        Case Else:                        execute = executeDirect(iParams, oAction) '@return: Long     Boolean
    End Select
 
Exit_Handler:
On Error Resume Next
    Set script = Nothing
    Exit Function
Err_Handler:
    setErr Err
    Resume Exit_Handler
    Resume
End Function
 
'/**
' * Die SQL Variablen/Parameter zurücksetzen
' */
Public Sub resetCache()
    Set pSqlVariables = Nothing
    Set pSqlVariablesString = Nothing
End Sub
 
 
'/**
' * gibt für einen VBA.VbVarType den entsprechenen DAO.DataTypeEnum zurück
' * @param  VBA.VbVarType       Type zu dem man einen entsprechenden DataTypeEnum gesucht wird
' * @param  DAO.DataTypeEnum    Defualt, falls kein passender eitnrag gefunden wird. Standartmässig nicht gesetzt
' * @retrun DAO.DataTypeEnum
' */
Public Function vbType2dbType(ByVal iType As VBA.VbVarType, Optional ByVal iDefaultType As DAO.DataTypeEnum = -1) As DAO.DataTypeEnum
    Static pArr(0 To 36) As Variant
    'Array initialisieren, falls er noch nicht exisiteirt
    If pArr(vbBoolean) = Empty Then
        pArr(vbEmpty) = dbText
        pArr(vbNull) = dbText
        pArr(vbInteger) = dbInteger
        pArr(vbLong) = dbLong
        pArr(vbSingle) = dbSingle
        pArr(vbDouble) = dbDouble
        pArr(vbCurrency) = dbFloat
        pArr(vbDate) = dbDate
        pArr(vbString) = dbText
        pArr(vbBoolean) = dbBoolean
        pArr(vbVariant) = dbText
        pArr(vbDecimal) = dbDecimal
        pArr(vbByte) = dbByte
    End If
    'Kein Datentyp gefunden -> Error 13
    If iType < 0 And iType > UBound(pArr) Then Err.Raise 13         'Type Missmatch
    If pArr(iType) = Empty And iDefaultType = -1 Then Err.Raise 13  'Type Missmatch
 
    vbType2dbType = IIf(pArr(iType) = Empty, iDefaultType, pArr(iType))
End Function
 
'/**
' * Achtung: Erweitert um NOW()
' * Dies ist die Minimalversion von cValue (V1.1.0): http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cvalue
' * Der 2te Paramtersteuert das Null-Verhalten('nebd'):
' *     n: Der Text Null ohne Delemiter wird als Wert Null intepretiert:    "NULL" -> Null
' *     e: Ein leerer String wird als Null intepretiert,                    "" -> Null
' *     b: Boolean-Text wird als Boolean intepretiert                       "True" -> True (Boolean)
' *     d: Bei Delemited Strings den Delemiter nicht entfernen. ' oder " gelten als Delemiter: "'Hans'" -> Hans
' */
Public Function cV(ByVal iValue As Variant, Optional ByVal iFlags As String) As Variant
    On Error Resume Next: If IsNull(iValue) Then cV = Null: Exit Function
    Static rxDa As Object, rxDs As Object: Dim sm As Object, str As String, flg As String:  str = CStr(iValue): flg = UCase(iFlags)
    Static rxCmd As Object: If rxCmd Is Nothing Then Set rxCmd = cRx("/^\s*(NOW|DATE|TIME)(?:\(\))?\s*$/i")
    If UCase(str) = "NULL" And InStr(flg, "N") Then cV = Null: Exit Function
    If iValue = Empty And CBool(InStr(flg, "E")) Then cV = Null: Exit Function
    If InStr(flg, "N") And rxCmd.test(str) Then
        Dim cmd As String: cmd = rxCmd.execute(UCase(str))(0).subMatches(0)
        cV = Switch(cmd = "NOW", Now, cmd = "DATE", Date, cmd = "TIME", Time)
        Exit Function
    End If
    cV = CByte(str):    If cV = str Then Exit Function
    cV = CInt(str):     If cV = str Then Exit Function
    cV = CLng(str):     If cV = str Then Exit Function
    cV = CDbl(str):     If cV = str Then Exit Function
    cV = CDec(str):     If cV = str Then Exit Function
    If IsDate(str) Then cV = CDate(str): Exit Function
    Err.Clear: If InStr(flg, "B") Then cV = CBool(str):   If Err.Number = 0 Then Exit Function
    If rxDa Is Nothing Then Set rxDa = CreateObject("VBScript.RegExp"): rxDa.pattern = "^#(.*)#$"
    If rxDa.test(str) Then cV = CDate(rxDa.execute(str)(0).subMatches(0)):  Exit Function
    If InStr(flg, "D") > 0 Then cV = iValue: Exit Function
    If rxDs Is Nothing Then Set rxDs = CreateObject("VBScript.RegExp"): rxDs.pattern = "^[#""'\[](.*)([""'#\]])$"
    If rxDs.test(str) Then Set sm = rxDs.execute(str)(0).subMatches: cV = Replace(sm(0), "\" & sm(1), sm(1)):  Exit Function
    cV = iValue
End Function
 
'/**
' * Setzt eine SQL-Variable. Datentyp: Variant, je nach Variable
' */
Public Property Let sqlVariable(ByVal iName As String, ByVal iValue As Variant)
    Dim varName As String:  varName = UCase(iName)
    If Not sqlVariables.exists(varName) Then
        sqlVariables.add varName, cV(iValue, "nb")
    Else
        sqlVariables(varName) = cV(iValue, "nb")
    End If
    sqlVariableString(iName) = sqlVariables(varName)
End Property
Public Property Get sqlVariable(ByVal iName As String) As Variant
    Dim varName As String:  varName = UCase(iName)
    If sqlVariables.exists(varName) Then
        sqlVariable = sqlVariables(varName)
    Else
        sqlVariable = Null
    End If
End Property
 
'/**
' * Setzt eine SQL-Variable. Datentyp: String: SQL-String-Format.
' */
Public Property Let sqlVariableString(ByVal iName As String, ByVal iValue As Variant)
    Dim values As String:   values = castSqlString(iValue)
    Dim varName As String:  varName = UCase(iName)
    If Not sqlVariablesString.exists(varName) Then
        sqlVariablesString.add varName, values
    Else
        sqlVariablesString(varName) = values
    End If
End Property
 
Public Property Get sqlVariableString(ByVal iName As String) As Variant
    Dim varName As String:  varName = UCase(iName)
    If sqlVariablesString.exists(varName) Then
        sqlVariableString = sqlVariablesString(varName)
    Else
        sqlVariableString = Null
    End If
End Property
 
'-------------------------------------------------------------------------------
' -- Private Methodes
'-------------------------------------------------------------------------------
 
'/**
' * Gibt einen SQL-String anhand des Datentyp zurück
' * @param  Variant         Daten
' * @param  VBA.VbVarType   Datentype aus VarType() überschreiben
' * @return String          SQL-String
' */
Private Function castSqlString(ByVal iValue As Variant, Optional ByVal iVarType As VbVarType = -1) As String
    Select Case IIf(iVarType = -1, VarType(iValue), iVarType)
        Case vbDate:        castSqlString = "#" & format(iValue, "MM-DD-YYYY HH:NN:SS") & "#"
        Case vbNull:        castSqlString = "NULL"
        Case vbEmpty:       castSqlString = "''"
        Case vbBoolean:     castSqlString = CStr(CInt(iValue))
        Case vbLong, vbInteger, vbByte, vbDouble, vbDecimal, vbSingle, vbCurrency
                            castSqlString = CStr(iValue)
        Case Else:          castSqlString = "'" & CStr(iValue) & "'"
    End Select
End Function
 
'/**
' * Creiert ein neues Script und hängt es an
' * Diese Funktion kann nur in einem ScriptContainer ausgeführt werden
' * @param  String      SQL-Statement
' * @param  sqlActions
' * @return Boolean     Gibt an, ob das iScript mit der Action iAction geparst werden konnte
' */
Public Function addNewScript(ByVal iCmd As String, Optional ByVal iAction As sqlActions = saAutomatic) As Boolean
    If Not pAction = saContainer Then Err.Raise ERR_SQLScript_ONLY_FOR_CONTAINER, "SQLScript.add", "Object-Action is not Container"
    add SQLScript.instanceSubScript(iCmd, iAction)
    addNewScript = True
'    If rxAction(iAction).test(iScriptS) Then
'        'Dim script As New SQLScript: Set script = SQLScript.initScript(iAction, iScriptS)
'        add SQLScript.instanceSubScript(iScriptS, iAction)
'        addNew = True
'    End If
End Function
 
'/**
' * Steuert das Ausführen anhand der params
' * @param  String      text für Nachfrage
' * @param  sqlParams
' * @return Boolean
' */
Private Function doIt(ByVal iText As String, ByVal iParams As sqlParams) As Boolean
        doIt = iParams And spDirect
        If Not doIt Then doIt = (MsgBox(iText, vbYesNo + vbQuestion) = vbYes)
End Function
 
'/**
' * Erstellt INSERT-Statements für Daten einer Tabelle
' * @param  String  Tabellenname
' * @param  String  Where-Bedining
' * @return String
' */
Private Function createInsertSql(ByVal iTable As String, Optional ByVal iWhere As String) As String
    Dim where As String: where = IIf(Trim(NZ(iWhere)) = Empty, "1=1", iWhere)
    Dim rs As DAO.Recordset:        Set rs = CurrentDb.OpenRecordset("SELECT * FROM [" & iTable & "] WHERE " & where)
    If rs.RecordCount = 0 Then Exit Function
    rs.MoveLast
    Dim scripts() As String:    ReDim scripts(rs.RecordCount - 1)
    Dim flds As DAO.fields:     Set flds = rs.fields
    Dim names() As String:      ReDim names(flds.count - 1)
    Dim values() As String:     ReDim values(flds.count - 1)
 
    Dim colIdx As Long: For colIdx = 0 To flds.count - 1
        names(colIdx) = "[" & flds(colIdx).Name & "]"
    Next colIdx
 
    rs.MoveFirst
    Do While Not rs.EOF
        For colIdx = 0 To flds.count - 1
        Select Case flds(colIdx).Type
            Case dbDate, dbTime, dbTimeStamp:       values(colIdx) = "#" & format(rs.fields(colIdx), "MM-DD-YYYY") & "#"
            Case dbDouble, dbNumeric, dbFloat, dbCurrency, dbInteger, dbLong
                                                    values(colIdx) = rs.fields(colIdx)
            Case Else:                              values(colIdx) = "'" & rs.fields(colIdx) & "'"
        End Select
 
        Next colIdx
        scripts(rs.absolutePosition) = "INSERT INTO [" & iTable & "] (" & Join(names, ", ") & ") VALUES (" & Join(values, ", ") & ");"
        rs.MoveNext
    Loop
    createInsertSql = Join(scripts, vbCrLf)
End Function
 
'/**
' * gibt den Primaryey Index einer Tabelle zurück
' * @param  String      Name der Tabelle
' * @retrun Index
' */
Private Function getPrimaryKey(ByVal iTable As String) As index
    Dim tbl As TableDef:        Set tbl = CurrentDb.TableDefs(iTable)
 
    If Not tbl.indexes.count = 0 Then Exit Function
    Dim pk As index: For Each pk In tbl.indexes
        If pk.Primary Then Exit For
    Next pk
    If pk.Primary Then Set getPrimaryKey = pk
End Function
 
'/**
' * gibt den Nackten Namen zurück. Entfernt ggf die []
' * @param  String
' * @return String
' */
Private Function getNakedName(ByVal iName As String) As String
    Static rx As Object: If rx Is Nothing Then Set rx = cRx("/^\[?(.*?)\]?$/i")
    If Not rx.test(iName) Then
        getNakedName = iName
    Else
        getNakedName = rx.execute(iName)(0).subMatches(0)
    End If
End Function
 
'/**
' * Erstellt Delete-Statements für Daten einer Tabelle
' * @param  String  Tabellenname
' * @param  String  Where-Bedining
' * @return String
' */
Private Function createDeleteSql(ByVal iTable As String, Optional ByVal iWhere As String) As String
    Dim where As String: where = IIf(Trim(NZ(iWhere)) = Empty, "1=1", iWhere)
    Dim rs As DAO.Recordset:        Set rs = CurrentDb.OpenRecordset("SELECT * FROM [" & iTable & "] WHERE " & where)
    If rs.RecordCount = 0 Then Exit Function
 
    Dim tbl As TableDef:        Set tbl = CurrentDb.TableDefs(iTable)
 
    Dim pk As index: Set pk = getPrimaryKey(iTable)
    If pk Is Nothing Then Err.Raise vbObjectError, , "No PrimaryKey found"
 
    Dim scripts() As String:    ReDim scripts(rs.RecordCount - 1)
    rs.MoveFirst
    Do While Not rs.EOF
        Dim wheres() As String: ReDim wheres(pk.fields.count - 1)
        Dim i As Long: For i = 0 To pk.fields.count(i)
            Dim fld As DAO.Field: Set fld = rs.fields(fld(i).Name)
            Select Case fld.Type
                Case dbDouble, dbNumeric, dbFloat, dbCurrency, dbInteger, dbLong
                                                        wheres(i) = "[" & fld.Name & "] = " & fld.value
                Case dbDate, dbTime, dbTimeStamp:       wheres(i) = "[" & fld.Name & "] = #" & format(fld.value, "MM-DD-YYYY") & "#"
                Case Else:                              wheres(i) = "[" & fld.Name & "] = '" & fld.value & "'"
            End Select
        Next i
        scripts(rs.absolutePosition) = "DELETE * FROM [" & iTable & "] WHERE " & Join(wheres, " AND ") & ";"
        rs.MoveNext
    Loop
    createDeleteSql = Join(scripts, vbCrLf)
End Function
 
'/**
' * Führt einen SET-Befehl aus
' */
Private Function executeSet() As Variant
    Dim varName As String, varValue As String
 
    list rxAction(saSet).execute(pCmd)(0), varName, varValue
    varName = UCase(getNakedName(varName))
    parent.sqlVariable(varName) = cV(varValue, "nb")
    parent.sqlVariableString(varName) = parent.sqlVariable(varName)
    executeSet = parent.sqlVariable(varName)
    pAffectedItem = varName
    pAffectedType = soParams
End Function
 
 
Private Function executeClearCache() As Boolean
    If Not parent Is Nothing Then
        parent.resetCache
        executeClearCache = True
    End If
End Function
 
' * ^SHOW\s+(COLUMNS|INDEXES)\s+FROM\s+(\[[^\]]+\]|\S+)
Private Function executeShow() As Object
    Dim srcType As String, srcName As String, srcWhere As String
    list rxAction(action).execute(trims(pCmd))(0), srcType, srcName, srcWhere
    pAffectedItem = Trim(UCase(srcType) & " " & srcName)
 
    Select Case Trim(UCase(srcType))
        Case "TABLES", "TABLE":                 Set executeShow = executeShowTables(srcName, srcWhere)
        Case "VIEW", "VIEWS", "QUERY", "QUERIES", "QUERYDEF", "QUERYDEFS":
                                                Set executeShow = executeShowViews(srcName, srcWhere)
        Case "COLUMNS", "COLUMN":               Set executeShow = executeShowColumns(srcName)
        Case "INDEXES", "INDEX":                Set executeShow = executeShowIndizes(srcName)
        Case "VARIABLES", "VARIABLE":           Set executeShow = executeShowVariables
    End Select
End Function
 
Private Function filteredRs(ByVal iSql As String, Optional ByVal iFilter As String = Empty) As DAO.Recordset
    With CurrentDb.OpenRecordset(iSql)
        If Not Trim(iFilter) = Empty Then .Filter = iFilter
        Set filteredRs = .OpenRecordset
    End With
End Function
 
Private Function executeShowTables(ByVal iSrcName As String, ByVal iSrcWhere As String) As Object
    Dim aRs As Object:          Set aRs = CreateObject("ADODB.Recordset") 'New ADODB.Recordset
    Dim db As DAO.Database:     Set db = CurrentDb
 
    'Temp ADODB.Recordset erstellen
    aRs.fields.Append "table_name", adVarChar, 255
    aRs.fields.Append "row_count", adInteger
    aRs.fields.Append "last_update", adDate
    aRs.fields.Append "indexes", adVarChar, 255
    aRs.Open
 
    With filteredRs("SELECT t.name AS table_name, t.* FROM [MSysObjects] AS t WHERE t.type = 1 AND NOT t.name like 'MSys*' ORDER BY t.name", iSrcWhere)
        .MoveFirst
        Do While Not .EOF
            If objectExists(acTable, !table_name) Then
                Dim tbl As TableDef:        Set tbl = db.TableDefs(!table_name)
                Dim indexList As String:    indexList = Empty
                If tbl.indexes.count > 0 Then
                    Dim indexes() As String: ReDim indexes(tbl.indexes.count - 1)
                    Dim k As Long: For k = 0 To tbl.indexes.count - 1
                        indexes(k) = tbl.indexes(k).Name & IIf(tbl.indexes(k).Primary, " (PK)", "")
                    Next k
                    indexList = Left(Join(indexes, ", "), 255)
                End If
                aRs.addNew Array("table_name", "row_count", "last_update", "indexes"), Array(tbl.Name, tbl.RecordCount, tbl.LastUpdated, indexList)
            End If
            .MoveNext
        Loop
    End With
    Set executeShowTables = aRs
End Function
 
Private Function executeShowViews(ByVal iSrcName As String, ByVal iSrcWhere As String) As Object
    Dim aRs As Object:          Set aRs = CreateObject("ADODB.Recordset") 'New ADODB.Recordset
    Dim db As DAO.Database:     Set db = CurrentDb
 
    'Temp ADODB.Recordset erstellen
    aRs.fields.Append "view_name", adVarChar, 255
    aRs.fields.Append "type_name", adVarChar, 50
    aRs.Open
 
    With filteredRs("SELECT q.name AS view_name, q.* FROM [MSysObjects] AS q WHERE q.type = 5 AND NOT q.name LIKE '~*' order by q.name", iSrcWhere)
        If Not .EOF Then .MoveFirst
        Do While Not .EOF
            If objectExists(acQuery, !view_name) Then
                Dim qry As QueryDef:    Set qry = db.QueryDefs(!view_name)
                aRs.addNew Array("view_name", "type_name"), Array(qry.Name, qryDefTypeName(qry.Type))
            End If
            .MoveNext
        Loop
    End With
    aRs.Sort = "view_name"
    Set executeShowViews = aRs
End Function
 
Private Function executeShowColumns(ByVal iSrcName As String) As Object
    Dim aRs As Object:          Set aRs = CreateObject("ADODB.Recordset") 'New ADODB.Recordset
    Dim sql As String:          sql = IIf(iSrcName Like "SELECT*", iSrcName, "SELECT * FROM " & iSrcName)
    Dim qdf As QueryDef:        Set qdf = queryDefWithParams(sql) 'CurrentDb.OpenRecordset(iSrcName)
 
    'Temp ADODB.Recordset erstellen
    aRs.fields.Append "nr", adInteger
    aRs.fields.Append "field_name", adVarChar, 255
    aRs.fields.Append "field_type", adVarChar, 255
    aRs.fields.Append "allow_zero_length", adBoolean
    aRs.fields.Append "required", adBoolean
    aRs.fields.Append "source_table", adVarChar, 255
    aRs.fields.Append "source_field", adVarChar, 255
    aRs.fields.Append "autoincrement", adBoolean
    aRs.fields.Append "default_value", adVarChar, 255
    aRs.Open
 
    Dim i As Long: For i = 0 To qdf.fields.count - 1
        With qdf.fields(i)
            aRs.addNew _
                Array("nr", "field_name", "field_type", "allow_zero_length", "required", "source_table", "source_field", "autoincrement", "default_value"), _
                Array(.OrdinalPosition + 1, .Name, getSQLType(.Type, .size), .AllowZeroLength, .Required, .SourceTable, .SourceField, CBool((.Attributes And dbAutoIncrField) = dbAutoIncrField), .DefaultValue)
        End With
    Next i
    aRs.Sort = "nr"
    Set executeShowColumns = aRs
End Function
 
Private Function executeShowIndizes(ByVal iSrcName As String) As Object
    Dim aRs As Object:          Set aRs = CreateObject("ADODB.Recordset") 'New ADODB.Recordset
    Dim db As DAO.Database:     Set db = CurrentDb
    Dim tbl As TableDef:        Set tbl = db.TableDefs(iSrcName)
 
    'Temp ADODB.Recordset erstellen
    aRs.fields.Append "index_name", adVarChar, 255
    aRs.fields.Append "primary_key", adBoolean
    aRs.fields.Append "unique", adBoolean
    aRs.Open
 
    Dim i As Long: For i = 0 To tbl.indexes.count - 1
        With tbl.indexes(i)
            aRs.addNew Array("index_name", "primary_key", "unique"), Array(.Name, .Primary, .Unique)
        End With
    Next i
    aRs.Sort = "index_name"
    Set executeShowIndizes = aRs
End Function
 
Private Function executeShowVariables() As Object
    Dim aRs As Object:          Set aRs = CreateObject("ADODB.Recordset") 'New ADODB.Recordset
 
    'Temp ADODB.Recordset erstellen
    aRs.fields.Append "variable_name", adVarChar, 255
    aRs.fields.Append "type", adVarChar, 50
    aRs.fields.Append "value", adVarChar, 255
    aRs.Open
 
    If parent.sqlVariables.count > 0 Then
        Dim keys() As Variant: keys = parent.sqlVariablesString.keys
        Dim i As Long: For i = 0 To least(parent.sqlVariables.count, parent.sqlVariablesString.count) - 1
            Dim varName As String: varName = keys(i)
            aRs.addNew Array("variable_name", "type", "value"), Array(varName, getSQLType(vbType2dbType(VarType(parent.sqlVariable(varName)))), parent.sqlVariableString(varName))
        Next i
    End If
    aRs.Sort = "[variable_name]"
    Set executeShowVariables = aRs
End Function
 
'/**
' * Erstellt eine View
' * ^\s*CREATE\s+OR\s+REPLACE\s+VIEW\s+(\S+)\s+AS\s+([\S\s]*)
' * 0 = View Name
' * 1 = SELECT Statement
' * @return Boolean     true: Scripte weiterführen, False: abbruch
' */
Private Function executeCreateOrReplaceView(ByVal iParams As sqlParams, Optional ByRef oAction As sqlActions = saCreateView) As Boolean
    Dim sql As String, queryName As String
On Error GoTo Err_Handler
 
    list rxAction(saCreateView).execute(pCmd)(0), queryName, sql
 
    If Not objectExists(acQuery, queryName) Then
        If doIt("Query " & queryName & " erstellen?", iParams) Then CurrentDb.CreateQueryDef queryName, sql
    Else
        If doIt("Ersetze Query " & queryName & "?", iParams) Then CurrentDb.QueryDefs(queryName).sql = sql
    End If
 
Exit_Handler:
    executeCreateOrReplaceView = True
    pAffectedItem = queryName
    pAffectedType = soQueryDef
    Exit Function
Err_Handler:
    setErr Err  'Fehler speichern
    Select Case MsgBox("Run-time Error: '" & Err.Number & "'" & vbCrLf & vbCrLf & _
                        Err.Description & vbCrLf & vbCrLf & _
                        sql & vbCrLf & vbCrLf & _
                        "Ignore the error and continue" _
                        , _
                        vbOKCancel + vbExclamation + vbDefaultButton2)
        Case vbCancel:  executeCreateOrReplaceView = False   'Abbrechen
        Case vbOK:      executeCreateOrReplaceView = True    'Ignorieren
    End Select
    GoTo Exit_Handler
    Resume
End Function
 
' * /\s*(CREATE\s+(TABLE|INDEX)\s+(\S+)([\s\S]+))/i
' * 0 = Ganzes Script
' * 1 = Type
' * 2 = ItemName
Private Function executeCreate(ByVal iParams As sqlParams) As Boolean
    Dim sql As String, createType As String, itemName As String, rest As String
    list rxAction(saCreate).execute(pCmd)(0), sql, createType, itemName, rest
 
    Select Case UCase(createType)
        Case "TABLE":
            pAffectedType = soTable
            pAffectedItem = itemName
            pUndoSql = "DROP TABLE [" & itemName & "];"
        Case "INDEX":
            pAffectedType = soIndex
            pAffectedItem = itemName
            Dim tableName As String:   tableName = rxOnTable.execute(rest)(0).subMatches(0)
            pUndoSql = "DROP INDEX [" & tableName & "] ON [" & itemName & "];"
    End Select
    CurrentDb.execute sql
 
    executeCreate = True
End Function
 
' * (DROP\s+(INDEX)\s+(\S+)(.*))
Private Function executeDrop(ByVal iParams As sqlParams) As Boolean
    Dim sql As String, objectType As String, itemName As String, rest As String
    list rxAction(saDrop).execute(pCmd)(0), sql, objectType, itemName, rest
 
    pAffectedItem = itemName
    Select Case UCase(objectType)
        Case "TABLE"
            pAffectedType = soTable
            CurrentDb.execute sql
        Case "VIEW"
            pAffectedType = soQueryDef
            CurrentDb.QueryDefs.delete itemName
        Case "INDEX"
             pAffectedType = soIndex
             Dim tableName As String:   tableName = rxOnTable.execute(rest)(0).subMatches(0)
             pAffectedItem = tableName & "." & itemName
             CurrentDb.execute sql
    End Select
 
    executeDrop = True
End Function
 
' * /^\s*(DELETE\s+[\s\S]+FROM\s+(\S+)(?:\s+WHERE\s+([\s\S]+)|$))/i
Private Function executeDelete(ByVal iParams As sqlParams) As Long
    Dim sql As String, where As String
    list rxAction(saDelete).execute(pCmd)(0), sql, pAffectedItem, where
    If withUndo Then pUndoSql = createInsertSql(pAffectedItem, where)
 
    Dim qdf As QueryDef: Set qdf = queryDefWithParams(sql)
    qdf.execute
    executeDelete = qdf.RecordsAffected
End Function
 
' * /^\s*(INSERT INTO\s+([\S]+)\s+([\s\S]+)|$))/i
Private Function executeInsert(ByVal iParams As sqlParams) As Long
'    Dim sql As String
'    list rxDdlDelete.execute(pCmd)(0), sql, pAffectedItem
'    Dim pk As index: Set pk = getPrimaryKey(pAffectedItem)
'
'    Dim qdf As QueryDef: Set qdf = queryDefWithParams(sql)
'    qdf.execute
'    executeInsert = qdf.RecordsAffected
'
'    Dim rs As DAO.Recordset: Set rs = CurrentDb.OpenRecordset()
'    Dim pkValues() As Variant: ReDim pValues(pk.fields.count - 1)
'
'
'    If withUndo Then pUndoSql = createDeleteSql(pAffectedItem, where)
 
End Function
 
'/**
' * sn = SqlName
' * Schreibt Namen zu SQL Namen um.
' * @example sn("table1.[A-Wert]") => [table1].[A-Wert]
' * @param  String      Nemane mit oder On Tabellennamen
' * @return String
' */
Private Function sn(ByVal iString As String) As String
    Static rx As Object: If rx Is Nothing Then Set rx = cRx("/\[?([^\.\[\]]+)\]?/g")
    sn = rx.Replace(iString, "[$1]")
End Function
 
' * /^\s*(UPDATE\s+(\S+)\s+SET\s+([\s\S]+?)(?:\s+WHERE\s+([\s\S]+)|\s*$))/i
Private Function executeUpdate(ByVal iParams As sqlParams) As Long
    Dim sql As String, objectType As String, setS As String, where As String
    list rxAction(saUpdate).execute(pCmd)(0), sql, pAffectedItem, setS, where
 
    If Trim(where) = Empty Then where = "1=1"
    Dim rs As DAO.Recordset: Set rs = CurrentDb.OpenRecordset("SELECT * FROM " & sn(pAffectedItem) & " WHERE " & where)
 
    With CurrentDb.CreateQueryDef(, sql)
 
        .execute
        '.ReturnsRecords
        executeUpdate = .RecordsAffected
    End With
End Function
 
 
' * /\s*(ALTER\s+(TABLE|INDEX)\s+(\S+)([\s\S]*))/i
Private Function executeAlter(ByVal iParams As sqlParams) As Boolean
    Dim sql As String, objectType As String, rest As String
    list rxAction(saAlter).execute(pCmd)(0), sql, objectType, pAffectedItem, rest
 
    Select Case UCase(objectType)
        Case "TABLE"
            If withUndo Then pUndoSql = createInsertSql(pAffectedItem)
            pAffectedType = soTable
            CurrentDb.execute sql
        Case "INDEX"
             pAffectedType = soIndex
             Dim tableName As String:   tableName = rxOnTable.execute(rest)(0).subMatches(0)
             pAffectedItem = tableName & "." & pAffectedItem
             CurrentDb.execute sql
    End Select
 
    executeAlter = True
End Function
 
 
'/**
' * Führt ein persist aus
' * ^\s*(INSERT\s+INTO\s+(\S+)\s+\(([^\)]+)\)\s+VALUES\s+\(([^\)]+)\))\s+ON\s+DUPLICATE\s+KEY\s+UPDATE\s+([\S\s]+)
' * 0 = insert-Script
' * 1 = name
' * 2 = fieldlist
' * 3 = values
' * 4 =  set Commands
' * @return Long: Anzahl betroffener Zeile
' */
Private Function executeInsertOnDuplicateUpdate(ByVal iParams As sqlParams, ByRef oAction As sqlActions) As Long
On Error GoTo Err_Handler
 
    Dim insert As String, tableName As String, fieldList As String, valueList As String, update As String
    list rxAction(saInsertOnDuplicateUpdate).execute(pCmd)(0), insert, tableName, fieldList, valueList, update
 
    Dim db  As DAO.Database:    Set db = CurrentDb
    Dim qdf As QueryDef:        Set qdf = queryDefWithParams(insert)
On Error Resume Next
    qdf.execute
    If Err.Number = 0 And qdf.RecordsAffected = 1 Then
        oAction = saInsert
        GoTo Exit_Handler
    End If
    Err.Clear
On Error GoTo Err_Handler
    Dim fields()    As Variant:  fields = cArray(UCase(fieldList), , "td")
    Dim values()    As Variant:  values = cArray(valueList, , "td")
    Dim pkInfo  As Object:  Set pkInfo = getPkInfo(CurrentDb.TableDefs(tableName))
    Dim data    As Object:  Set data = cDict(fields, values)
    'Kein PrimaryKey vorhanden
    If pkInfo!indexName = Empty Then Err.Raise vbObjectError, "executeInsertOnDuplicateUpdate", "Table have no Primary Key"
    Dim pkCount As Long: pkCount = pkInfo!fields.count
 
    'Filter definieren
    Dim wheres() As String: ReDim wheres(pkCount - 1)
    Dim keys()  As Variant: keys = pkInfo!fields.keys
    Dim i As Integer: For i = 0 To pkCount - 1
        If Not data.exists(UCase(keys(i))) Then Err.Raise vbObject, "executeInsertOnDuplicateUpdate", "Missing Field [" & keys(i) & "] from PrimaryKey"
        wheres(i) = keys(i) & " = " & data(UCase(keys(i)))
    Next i
    Dim where As String: where = Join(wheres, " AND ")
    Dim sql As String: sql = "UPDATE [" & tableName & "] SET " & update & " WHERE " & where
    If pWithUndo Then pUndoSql = createInsertSql(tableName, where)
    Set qdf = queryDefWithParams(sql)
    oAction = saUpdate
    qdf.execute
 
 
Exit_Handler:
    executeInsertOnDuplicateUpdate = qdf.RecordsAffected
    Exit Function
Err_Handler:
    setErr Err  'Fehler speichern
    Select Case MsgBox("Run-time Error: '" & Err.Number & "'" & vbCrLf & vbCrLf & _
                        Err.Description & vbCrLf & vbCrLf & _
                        pCmd & vbCrLf & vbCrLf & _
                        "Ignore the error and continue" _
                        , _
                        vbOKCancel + vbExclamation + vbDefaultButton2)
        Case vbCancel:  executeInsertOnDuplicateUpdate = False   'Abbrechen
        Case vbOK:      executeInsertOnDuplicateUpdate = True    'Ignorieren
    End Select
    Resume Exit_Handler
    Resume
End Function
 
Private Function executePrompt() As String
        executePrompt = rxAction(saPrompt).execute(pCmd)(0).subMatches(0)
End Function
 
'/**
' * Führt einfache Scripte aus
' * @return Boolean     true: Scripte weiterführen, False: abbruch
' */
Private Function executeDirect(ByVal iParams As sqlParams, ByRef ioAction As sqlActions) As Variant
On Error GoTo Err_Handler
    executeDirect = False
execute:
    Dim qdf As QueryDef
    Set qdf = queryDefWithParams
    qdf.execute dbFailOnError
 
Exit_Handler:
    Select Case ioAction
        Case saInsert, saUpdate:        executeDirect = qdf.RecordsAffected
        Case Else:                          executeDirect = True
    End Select
    Exit Function
Err_Handler:
    setErr Err  'Fehler speichern
    If iParams And spOverwrite And (Err.Number = 3010 Or Err.Number = 3375) Then
        'Bei CREATE TABLE oder CREATE INDEX die Tabelle/Index überschreiben
        Select Case Err.Number
            Case 3010   'Table 'tbl_xxxx' already exists
                Dim tblName As String: tblName = cRx("/^Table '([^']+)'/").execute(Err.Description)(0).subMatches(0)
                CurrentDb.TableDefs.delete (tblName)
                Resume execute
            Case 3375 'Table 'tbl_t1' already has an index named 'idx_val'.
                Dim sm As Object: Set sm = cRx("/^Table '([^']+)'.*'([^']+)'\.$/").execute(Err.Description)(0).subMatches
                Call CurrentDb.TableDefs(sm(0)).indexes.delete(sm(1))
                Set sm = Nothing
                Resume execute
        End Select
    ElseIf Err.Number = 3219 Then
 
    ElseIf iParams And spIgnore Then
        'Fehler ignorieren.
    Else
Err_Msg:
        Dim errMsg As String
        Const C_ERR = "Run-time Error: '%s'\n\n%s\n\n%s"
        Select Case Err.Number
            Case 3010, 3375    'Tabellen und Indexe
                'Description
                Select Case MsgBox(sPrintF(C_ERR, Err.Number, Err.Description, pCmd) & vbCrLf & vbCrLf & _
                                    "Overwrite the Object (no = ignore and continue)" _
                                    , _
                                    vbYesNoCancel + vbExclamation + vbDefaultButton2)
                    Case vbCancel:  executeDirect = False       'Abbrechen
                    Case vbYes:     iParams = spOverwrite:    'Überschreiben
                                    Resume execute
                    Case vbNo:      executeDirect = True        'Ignorieren
                End Select
            Case Else           'Restliche Scripts
                Select Case MsgBox(sPrintF(C_ERR, Err.Number, Err.Description, pCmd) & vbCrLf & vbCrLf & _
                                    "Ignore the error and continue" _
                                    , _
                                    vbOKCancel + vbExclamation + vbDefaultButton2)
                    Case vbCancel:  executeDirect = False   'Abbrechen
                    Case vbOK:      executeDirect = True    'Ignorieren
                End Select
        End Select
    End If
End Function
 
'/**
' * Archiviert den Fehler
' * @param  ErrObject
'^*/
Private Function setErr(ByRef iErr As ErrObject) As Object
    Set pError = CreateObject("scripting.Dictionary")
    pError.add "Number", iErr.Number
    pError.add "Description", iErr.Description
    Set setErr = pError
End Function
 
'/**
' * trim \s:    Entfernt im Gegensatz zu trim() auch Zeilenumbrüche, Tabulatoren etc. Alles was object \s ist
' * @param  String
' * @return String
' */
Private Function trims(ByVal iString As String) As String
    trims = StrReverse(rxTrim.Replace(StrReverse(rxTrim.Replace(iString, "$1")), "$1"))
End Function
'/**
' * Gekürzte Version von V1.1.0 http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/list
' * Dito zu List. Aber die Argumente ist ein vordimensionierter Array
' * @param  Liste           Array, Dictionary, Collection, object.object, object.object oder DAO.Recordset
' * @param  Array<Varaint>  Auflistung der Variablen, die abgefüllt werden
' * @return Boolean         Angabe, ob die ganze Sache gültig war
' */
Private Function list( _
        ByRef iList As Variant, _
        ParamArray oParams() As Variant _
) As Boolean
    Dim lBnd    As Long:    lBnd = 0
    Dim uBnd    As Long:    uBnd = UBound(oParams)
    Dim i       As Long
On Error GoTo Err_Handler
 
    If uBnd = -1 Then Err.Raise vbObjectError, "list", "No Parameters"
 
    'object
    If TypeName(iList) = "IMatch2" Then
        list = iList.subMatches.count > 0:     If Not list Then Exit Function
        If uBnd > iList.subMatches.count - 1 Then uBnd = iList.subMatches.count - 1
        For i = 0 To uBnd
            If Not IsMissing(oParams(i)) Then oParams(i) = iList.subMatches(i)
        Next i
    End If
 
Exit_Handler:
    Exit Function
Err_Handler:
    list = False
    GoSub Exit_Handler
    Resume
End Function
 
'/**
' * Bei einer Variablenübergabe muss immer unterscheiden werden, ob es ein Objekt ist oder nicht.
' * Diese Sub nimmt einem die Arbeit ab
' * ref(oNode, iNode)
' * @param  Variant     Variable, die den Wert bekommen soll
' * @param  Variant     Ret Wert selber
' */
Public Sub ref(ByRef oNode As Variant, ByRef iNode As Variant)
    If IsObject(iNode) Then: Set oNode = iNode: Else: oNode = iNode
End Sub
'/**
' * Prüft ob ein bestimmtest Access-Objekt existiert
' * @param  <AcObjectType>      Type vom Objekt
' * @param  <String>            Name des geushcten Objektes
' * @retrun <Boolean>
' * @example    If ObjectExists(acQuery, "vw_temp") then CurrentDb.QueryDefs.Delete("vw_temp")
' */
Private Function objectExists(ByVal iObjectType As AcObjectType, ByVal iObjectName As String) As Boolean
    Dim dummy As Variant
On Error Resume Next
 
    'Je nach Type unterschiedlich prüfen
    Select Case iObjectType
        Case acTable:   Set dummy = CurrentDb.TableDefs(iObjectName)
        Case acQuery:   Set dummy = CurrentDb.QueryDefs(iObjectName)
        Case acForm:    Set dummy = Application.Forms(iObjectName)
        Case acReport:  Set dummy = Application.Reports(iObjectName)
        Case acModule:  Set dummy = Application.Modules(iObjectName)
        Case acMacro:   'Das Macro ist nicht ganz so einfach wie die anderen Objekte.
            Set dummy = CurrentDb.OpenRecordset("SELECT * FROM MSysObjects WHERE [name] = '" & iObjectName & "' AND [type] = -32766")
            dummy.MoveFirst
    End Select
 
    'Wenn kein Fehler aufgetretten ist, exisitert das Objekt
    objectExists = (Err.Number = 0)
 
On Error Resume Next
    'Suaber aufräumen. Bei Fehler ignorieren
    Err.Clear
    Call dummy.Close
    Set dummy = Nothing
End Function
 
'/**
' * Liest den PrimaryKey einer Tabelle aus
' * @param  TableDef
' * @return Dictionary(autoIncrFld => String, fields => Dictionary(NAME => Empty), indexName => String)
' */
Private Function getPkInfo(ByRef iTbl As Object) As Object
    Static cachedPkDicts    As Object
    If cachedPkDicts Is Nothing Then Set cachedPkDicts = CreateObject("scripting.Dictionary")
 
    Dim tblName             As String:      tblName = UCase(iTbl.Name)
    If Not cachedPkDicts.exists(tblName) Then
        'CacheNode initialisieren
        Dim info As Object: Set info = cDict(Array("autoIncrFld", "fields", "types", "indexName"), Array(Empty, cDict(), cDict(), Empty))
        'Tabelle analysieren
        Dim pk As Object: For Each pk In iTbl.indexes
            If pk.Primary Then      'Primary Key durchgehen
                Dim fld As Variant: For Each fld In pk.fields
                    Dim key As String: key = UCase(fld.Name)
                    If (iTbl.fields(fld.Name).Attributes And dbAutoIncrField) Then info!autoIncrFld = fld.Name     'Prüfen auf autoIncrement
                    info!fields.add key, Empty
                    info("types").add key, iTbl.fields(fld.Name).Type
                Next fld: Set fld = Nothing
                info!indexName = pk.Name
                Exit For
            End If
        Next pk
        cachedPkDicts.add tblName, info
    End If
    Dim keys() As Variant: keys = cachedPkDicts(tblName)!fields.keys
    Dim i As Long: For i = 0 To UBound(keys)
        cachedPkDicts(tblName)!fields(keys(i)) = Empty
    Next i
    Set getPkInfo = cachedPkDicts(tblName)
End Function
 
'-------------------------------------------------------------------------------
' -- Public properties
'-------------------------------------------------------------------------------
 
'/**
' * Beid en Subscripts entspricht der parent dem Container, in dem sie sich befinden
' * @return SQLScript
' */
Public Property Get parent() As SQLScript
    Set parent = pParent
End Property
Public Property Set parent(ByRef iParent As SQLScript)
    Set pParent = iParent
End Property
 
' * Der Action-Type
Public Property Get action() As sqlActions:                 action = pAction:       End Property
Public Property Let action(ByVal iAction As sqlActions):    pAction = iAction:      End Property
 
' * Objekt, das von dem Script betroffen war
Public Property Get affectedItem() As String:               affectedItem = pAffectedItem:   End Property
' *
'Public Property Get affectedValue() As Variant:             affectedValue = pAffectedValue: End Property
' * objectType, der von dem Script betroffen war   Table/Query etc.
Public Property Get affectedType() As objectType:              affectedType = pAffectedType:   End Property
 
'/**
' * Die SQL-Parameters/Variablen, die mit SET gesetzt wurden
' * @retrun Dictionary  Dict<Key> => Varaint
' */
Public Property Get sqlVariables() As Object
    If pSqlVariables Is Nothing Then Set pSqlVariables = CreateObject("scripting.Dictionary")
    Set sqlVariables = pSqlVariables
End Property
 
'/**
' * Die SQL-Parameters/Variablen, die mit SET gesetzt wurden. Aber als SQL-String
' * @retrun Dictionary  Dict<Key> => String
' */
Public Property Get sqlVariablesString() As Object
    If pSqlVariablesString Is Nothing Then Set pSqlVariablesString = CreateObject("scripting.Dictionary")
    Set sqlVariablesString = pSqlVariablesString
End Property
 
' * Index des Elemnts im Container
Public Property Get index() As Long:                        index = pindex:         End Property
Public Property Let index(ByVal iIndex As Long):            pindex = iIndex:        End Property
 
' * Errors
Public Property Get haveError() As Boolean:     haveError = Not isNothing(pError):      End Property
Public Property Get error() As Object:                      Set error = pError:     End Property
 
' * SQL-String
Public Property Get sql(Optional ByVal iIndex As Long = -1) As String
    Select Case action
        Case saContainer:                 sql = IIf(iIndex > -1, pScriptsO(iIndex).sql(), Empty)
        Case Else:                        sql = pCmd
    End Select
End Property
 
'/**
' * Typenzuordnung DDL/DML/DCL
' */
Public Property Get sqlType() As sqlType
    If action <= [_DDL_LAST] Then
        sqlType = stDDL
    ElseIf action <= [_DML_LAST] Then
        sqlType = stDML
    ElseIf action <= [_DCL_LAST] Then
        sqlType = stDCL
    Else
        sqlType = stNA
    End If
End Property
 
' * Anzahl Elemente im Container
Public Property Get count() As Long
    count = IIf(action = saContainer, pScriptsO.count, -1)
End Property
 
' * Pfad der Quelldatei
Public Property Get filePath() As String
    filePath = pFilePath
End Property
 
'' * Erste Zeile wird als header ausgegeben
'Public Property Get header(Optional ByVal iIndex As Long = -1) As String
'    Select Case action
'        Case saContainer:
'            If iIndex = -1 Then
'                header = filePath
'            Else
'                header = pScriptsO(iIndex).header
'            End If
'        Case saCreateView:
'            header = "Create or Replace View " & rxAction(saCreateView).execute(pCmd)(0).subMatches(0)
'        Case saInsertOnDuplicateUpdate
'            header = "Persist Data into " & rxAction(saInsertOnDuplicateUpdate).execute(pCmd)(0).subMatches(1)
'        Case Else
'            header = trims(Split(Split(trims(pCmd), vbLf)(0), vbCr)(0))
'    End Select
'End Property
 
'TODO: Undo-Script Handling
Public Property Get withUndo() As Boolean
    withUndo = pWithUndo
End Property
Public Property Let withUndo(ByVal iFlag As Boolean)
    pWithUndo = iFlag
End Property
Public Property Get undoSql() As String
    undoSql = pUndoSql
End Property
 
'-------------------------------------------------------------------------------
' -- private properties
'-------------------------------------------------------------------------------
'/**
' * Temporäres QueryDef mit den Paramtern
' * @return QueryDef
' */
Private Function queryDefWithParams(Optional ByVal iSource As Variant = Null) As QueryDef
    Dim db As DAO.Database: Set db = CurrentDb
    Dim qdf As QueryDef
    Select Case TypeName(iSource)
        Case "QueryDef":    Set qdf = iSource
        Case "String":      Set qdf = db.CreateQueryDef("", iSource)
        Case "Recordset2":  Set qdf = iSource.OpenQueryDef
        Case "Null":          Set qdf = db.CreateQueryDef("", trims(unicodeDecode(sql)))
    End Select
    'qdf.sql = unicodeDecode(sql)
    Dim i As Long: For i = 0 To qdf.Parameters.count - 1
        Dim vName As String: vName = getNakedName(UCase(qdf.Parameters(i).Name))
        If Not parent Is Nothing Then
            If parent.sqlVariables.exists(vName) Then
                qdf.Parameters(i).value = parent.sqlVariable(vName)
            Else
                Dim value As Variant: value = InputBox("Value for Param " & qdf.Parameters(i).Name)
                parent.sqlVariable(vName) = cV(value, "nb")
                qdf.Parameters(i).value = parent.sqlVariable(vName)
            End If
        Else
            value = InputBox("Value for Param " & qdf.Parameters(i).Name)
            qdf.Parameters(i).value = cV(value, "nb")
        End If
    Next i
    Set queryDefWithParams = qdf
End Function
 
' * object für Comments
Private Property Get rxSqlComment() As Object
    Static rx As Object: If rx Is Nothing Then Set rx = cRx("/^(\s*(--|#).*)$/gm")
    Set rxSqlComment = rx
End Property
 
' * object um leere Zeilen zu fineden
Private Property Get rxEmptyRow() As Object
    Static rx As Object: If rx Is Nothing Then Set rx = cRx("/(^\s*$)/")
    Set rxEmptyRow = rx
End Property
 
' * object um einen Trim durchzuführen (inkl. Zeilenumbrüchen, Tabulatoren etc)
Private Property Get rxTrim() As Object
    Static rx As Object: If rx Is Nothing Then Set rx = cRx("/^\s*([\S\s]*)$/")
    Set rxTrim = rx
End Property
 
' * object um ein ON zu analysieren
Private Property Get rxOnTable() As Object
    Static rx As Object: If rx Is Nothing Then Set rx = cRx("/\s*ON\s+(\S+)/i")
    Set rxOnTable = rx
End Property
 
'-------------------------------------------------------------------------------
' -- private libraries
'-------------------------------------------------------------------------------
 
'/**
' * Wandelt jedes mit \ maskierte Feld in Unicode um, ausser es handelt sich bereits um einen Unicode
' * @param  String
' * @return String
' */
Private Function masked2uniode(ByVal iString As String) As String
    Static rx As Object:    If rx Is Nothing Then Set rx = cRx("/\\(?!u[0-9A-F]{4})(.)/")
    masked2uniode = iString
    Do While rx.test(masked2uniode)
        masked2uniode = rx.Replace(masked2uniode, char2unicode(rx.execute(masked2uniode)(0).subMatches(0)))
    Loop
End Function
 
'/**
' * 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
 
'/**
' * 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
 
'/**
' * Wandelt alle Unicodes in einem String in das eigentliche Zeichen zurück
' * @param  String
' * @return String
' */
Private Function unicodeDecode(ByVal iString) As String
    unicodeDecode = iString
    Static rx As Object
    If rx Is Nothing Then Set rx = cRx("/\\u[0-9A-F]{4}/i")
    Do While rx.test(unicodeDecode)
        unicodeDecode = rx.Replace(unicodeDecode, unicode2Char(rx.execute(unicodeDecode)(0)))
    Loop
End Function
 
Private Property Get qryDefTypeName(ByVal iDbQType As Long) As String
    Static pTypeNames(240) As String
    If pTypeNames(dbQSelect) = Empty Then
        pTypeNames(dbQAction) = "Action"
        pTypeNames(dbQAppend) = "Append"
        pTypeNames(dbQCompound) = "Compound"
        pTypeNames(dbQCrosstab) = "Crosstab"
        pTypeNames(dbQDDL) = "DDL"
        pTypeNames(dbQDelete) = "Delete"
        pTypeNames(dbQMakeTable) = "MakeTable"
        pTypeNames(dbQProcedure) = "Procedure"
        pTypeNames(dbQSelect) = "Select"
    End If
    qryDefTypeName = pTypeNames(iDbQType)
End Property
 
' /**
' * Ähnlich wie split. Zusätzlich
' *     - Einzelne Elemente können in Anführungszeichen gesetzt sein. Delemiter innerhalb des Strings werden nicht als
' *       Delemiter erkannt. Anführungszeichen innerhalb eine sStrings können mit \ maskiert werden
' * @param  String
' * @param  String   Delemiter   Default: ,
' * @param  String   Paramters:
' *     t: Trim() auf die Items anwenden
' *     v: cValue() auf die Items anwenden
' *     n: Der Text Null ohne Delemiter wird als Wert Null intepretiert:    "NULL" -> Null
' *     e: Ein leerer String wird als Null intepretiert,                    "" -> Null
' *     b: Boolean-Text wird als Boolean intepretiert                       "True" -> True (Boolean)
' *     d: Bei Delemited Strings den Delemiter nicht entfernen. ' oder " gelten als Delemiter: "'Hans'" -> Hans
' * @return Array<Variant>
' */
Private Function cArray(ByVal iString As String, Optional ByVal iDelemiter As String = ",", Optional ByVal iFlags As String = "tvneb") As Variant()
    Static rxCharsInStringToUnicode As Object:  If rxCharsInStringToUnicode Is Nothing Then Set rxCharsInStringToUnicode = cRx("/([\[\]\{\}'""=;,])/")
    Static rxStrings As Object:                 If rxStrings Is Nothing Then Set rxStrings = cRx("/(['""])([^\1]+?)\1/g")
 
    Dim str As String: str = iString
 
    If rxStrings.test(str) Then
        Dim mc As Object: Set mc = rxStrings.execute(str)
        Dim i As Long: For i = mc.count - 1 To 0 Step -1
            Dim substr As String: substr = mc(i).subMatches(1)
            Do While rxCharsInStringToUnicode.test(substr)
                substr = rxCharsInStringToUnicode.Replace(substr, CStr(char2unicode(rxCharsInStringToUnicode.execute(substr)(0))))
            Loop
            Dim dm As String: dm = mc(i).subMatches(0)
            str = replaceIndex(str, dm & substr & dm, mc(i).firstIndex, mc(i).length)
        Next i
    End If
    Dim strArr() As String: strArr = Split(str, iDelemiter)
    Dim retArr() As Variant: ReDim retArr(UBound(strArr))
    For i = 0 To UBound(strArr)
        Dim item As Variant: item = unicodeDecode(strArr(i))
        If InStr(iFlags, "t") Then item = Trim(item)
        If InStr(iFlags, "v") Then item = cV(item, "nb")
        retArr(i) = item
    Next i
    cArray = retArr
End Function
 
'/**
' * Wandelt verschiedene Formate in ein Dictionary um
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cdic
' * @param  ParamArray
' * @return Dictionary
' */
Private Function cDict(ParamArray iItems() As Variant) As Object
    Dim items() As Variant:     items = CVar(iItems)
    Set cDict = cDictA(items)
End Function
 
'/**
' * Dito zu cDict(). Die Übergabe ist aber nicht ein ParamArray sondern ein Arry.
' * Dieser Aufruf wird vor allem im Einsatz in anderen Funktionen verwendet
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cdic
' * @param  Array
' * @return Dictionary
' */
Private Function cDictA(ByRef iItems() As Variant) As Object
    'Cache object um einSet-String zu zerlegen
    Static rxSetString As Object:               If rxSetString Is Nothing Then Set rxSetString = cRx("/(|lluN|eslaf|eurt|(['""#](?![\\,])).+?\1(?!\\)|[\d\.]*)\s*(?:>=|[,:=])\s*((['""](?!\\)).+?\4(?!\\)|(\](?!\\)).+?\[(?!\\)|[\w\s-]+)/i")
    Static rxCharsInStringToUnicode As Object:  If rxCharsInStringToUnicode Is Nothing Then Set rxCharsInStringToUnicode = cRx("/([\[\]\{\}'""=;,])/")
    Static rxStrings As Object:                 If rxStrings Is Nothing Then Set rxStrings = cRx("/(['""])([^\1]+?)\1/g")
    Set cDictA = CreateObject("scripting.Dictionary")
    Dim mc As Object
    Dim items() As Variant:                     items = CVar(iItems)
    Dim key As Variant, value As Variant
    Dim isList As Boolean
 
    If UBound(items) = -1 Then Exit Function
 
    'Prüfen ob 2 Parametetrs übergeben wurden
    If UBound(items) = 1 Then
        'Beide Parametrer sind Arrays -> Combine: Erster Array Keys, 2ter Values
        If IsArray(items(0)) And IsArray(items(1)) Then
            Dim keys() As Variant:      keys = items(0)
            Dim values() As Variant:    values = items(1)
            Dim delta As Long:          delta = LBound(keys) - LBound(values)
            ReDim Preserve values(LBound(values) To UBound(keys) + delta)
            Dim i As Integer: For i = LBound(keys) To UBound(keys)
                If Not cDictA.exists(keys(i)) Then cDictA.add keys(i), values(i + delta)
            Next i
            Exit Function
        End If
    End If
 
    'Alle Items durchackern
    Dim cnt As Integer:     cnt = 0
    Dim item As Variant:    For Each item In items
        'Dictionary
        If Not isList And TypeName(item) = "Dictionary" Then
            For Each key In item.keys
                If Not cDictA.exists(key) Then cDictA.add key, item.item(key)
            Next key
        'einsamer Array
        ElseIf Not isList And IsArray(item) Then
            For key = LBound(item) To UBound(item)
                If Not cDictA.exists(key) Then cDictA.add key, item(key)
            Next key
        'SetString
        ElseIf Not isList And Not IsArray(item) And Not IsObject(item) Then
            'Alle []{}'"=;, innerhalb eines Strings in Unicode parsen
            If rxStrings.test(item) Then
                Set mc = rxStrings.execute(item)
                For i = mc.count - 1 To 0 Step -1
                    Dim substr As String: substr = mc(i).subMatches(1)
                    Do While rxCharsInStringToUnicode.test(substr)
                        substr = rxCharsInStringToUnicode.Replace(substr, CStr(char2unicode(rxCharsInStringToUnicode.execute(substr)(0))))
                    Loop
                    Dim dm As String: dm = mc(i).subMatches(0)
                    item = replaceIndex(item, dm & substr & dm, mc(i).firstIndex, mc(i).length)
                Next i
            End If
            If rxSetString.test(StrReverse(item)) Then
                Set mc = rxSetString.execute(StrReverse(item))
                Dim k As Variant: For k = mc.count - 1 To 0 Step -1
                    key = cV(unicodeDecode(StrReverse(mc(k).subMatches(2))))
                    value = cV(unicodeDecode(StrReverse(mc(k).subMatches(0))), "nb")
                    If Not cDictA.exists(key) Then cDictA.add key, value
                Next k
 
            Else
                GoTo DEFAULT        'Zuerst wollte ich diesen GoTo nicht haben. Aber StrReverse() wirft ein Fehler wenn ein Objekt übergeben wird. Darum konnte der Test nicht im ElseIf durchgeführt werden.
            End If
        'Alles andere geht in ein WertePaar.
        ElseIf cnt = 0 Or isList Then
DEFAULT:
            If cnt Mod 2 = 0 Then
                key = item
            ElseIf Not cDictA.exists(key) Then cDictA.add key, item
            End If
            isList = True
        End If
        cnt = cnt + 1
    Next
    'Falls es sich um eine nicht abgeschlossene Liste handelt
    If isList And cnt Mod 2 <> 0 Then If Not cDictA.exists(key) Then cDictA.add key, Empty
End Function
 
'-------------------------------------------------------------------------------
'--- LIBRARIES for cDict
'-------------------------------------------------------------------------------
 
 
 
'/**
' * Dies ist die Minimalversion von cRegExp (V2.1.0): http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cregexp
' */
Private Function cRx(ByVal iPattern As String) As Object
    Static rxP As Object
    If rxP Is Nothing Then:     Set rxP = CreateObject("VBScript.RegExp"): rxP.pattern = "^([@&!/~#=\|])?(.*)\1(?:([Ii])|([Gg])|([Mm]))*$"
    Dim sm As Object:           Set cRx = CreateObject("VBScript.RegExp"): Set sm = rxP.execute(iPattern)(0).subMatches
    cRx.pattern = sm(1):        cRx.IgnoreCase = Not isEmpty(sm(2)):       cRx.Global = Not isEmpty(sm(3)):     cRx.Multiline = Not isEmpty(sm(4))
End Function
 
'/**
' * Copyright mpl by ERB software | http://wiki.yaslaw.info
' *
' * Ersetzt ein pestimmte Position in einem String
' * @param  String      Heystack
' * @param  String      Ersetzungsstring
' * @param  Integer     Position im String
' * @param  Integer     Länge des zu ersetzenden Strings
' */
Private Function replaceIndex(ByVal iExpression As Variant, ByVal iReplace As Variant, ByVal iIndex As Variant, Optional ByVal iLength As Integer = 1) As String
    replaceIndex = Left(iExpression, iIndex) & iReplace & Mid(iExpression, iIndex + iLength + 1)
End Function
 
'/**
' * Gibt den Kleinsten aus einer unbestimmten Menge von Werten zurück
' * @param  Keine Objekte
' * @return Grösster Wert
' * @example least("Hallo Welt", 42, "Mister-X") -> 42
'*/
Private Function least(ParamArray iItems() As Variant) As Variant
    least = iItems(LBound(iItems))
    Dim item As Variant: For Each item In iItems
        If NZ(item) < NZ(least) Then least = item
    Next item
End Function
 
 
'-------------------------------------------------------------------------------
'               http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/strtodate
'Version      : 1.0.1
'History      : 30.04.2014 - ERS - Creation
'-------------------------------------------------------------------------------
'/**
' * Prüft, ob eine Variable Null, Empty, Nothing, Leerstring, leerer Array etc ist
' *
' *     boolean = isNothing(object)
' *     boolean = isNothing(vaule)
' *
' * @param  Variant     Variable die geprüft werden soll
' * @return Boolean
' */
Private Function isNothing(ByRef iValue As Variant) As Boolean
    isNothing = True
    Select Case TypeName(iValue)
        Case "Nothing", "Empty", "Null":    Exit Function
        Case "Collection", "Dictionary":    If iValue.count = 0 Then Exit Function
        Case "String":                      If Len(Trim(iValue)) = 0 Then Exit Function
        Case "Iterator":                    If Not iValue.isInitialized Then Exit Function
        '//TODO: weitere Spezialfälle
        Case Else:
            If IsArray(iValue) Then
                On Error Resume Next
                Dim dummy As Variant: dummy = iValue(LBound(iValue))
                If Err.Number <> 0 Then Exit Function
            End If
    End Select
    isNothing = False
End Function
 
'/**
' * Gibt den SQL-Type für ein DAO.DataTypeEnum zurück.
' * Diesen kann man für automatisierte CRATE TABLE oder ALTER TABLE verwenden
' * @param  DAO.DataTypeEnum
' * @param  Integer
' * @return String
' */
Private Function getSQLType(ByVal iVarType As DAO.DataTypeEnum, Optional ByVal iSize As Integer = 50) As String
    Select Case iVarType
        Case dbText:        getSQLType = "TEXT(" & iSize & ")"
        Case dbLong:        getSQLType = "LONG"
        Case dbInteger:     getSQLType = "INTEGER"
        Case dbBoolean:     getSQLType = "YESNO"
        Case dbMemo:        getSQLType = "MEMO"
        Case dbByte:        getSQLType = "BYTE"
        Case dbSingle:      getSQLType = "SINGLE"
        Case dbCurrency:    getSQLType = "CURRENCY"
        Case dbTimeStamp:   getSQLType = "DATETIME"
        Case dbDate:        getSQLType = "DATE"
        Case dbTime:        getSQLType = "TIME"
        Case dbBinary:      getSQLType = "BINARY(" & iSize & ")"
        Case dbLongBinary:  getSQLType = "LONGBINARY"
        Case Else:          getSQLType = "TEXT(" & iSize & ")"
    End Select
End Function
 
 
'-------------------------------------------------------------------------------
' -- Private Events
'-------------------------------------------------------------------------------
 
'/**
' * Initialisierung
' */
Private Sub Class_Initialize()
    Set pScriptsO = New Collection
    pAction = saContainer       'Solange die Action nicht überschrieben wird, gilt das Objekt als Container
End Sub
 
 
'-------------------------------------------------------------------------------
' -- Action Settings
'-------------------------------------------------------------------------------
 
'/**
' * object den Actions zuordnen
' */
Private Property Get rxAction(ByVal iAction As sqlActions) As Object
    Static rxList(sqlActions.[_FIRST] To sqlActions.[_LAST]) As Object
    Static patterns(sqlActions.[_FIRST] To sqlActions.[_LAST]) As String
    If patterns(sqlActions.[_FIRST]) = Empty Then
        patterns(saSelect) = "/^\s*(SELECT[\s\S]+)/i"
        patterns(saSelectWithParams) = "/^\s*(PARAMETERS\s+.+\s*(SELECT[\s\S]+))/i"
        patterns(saPrompt) = "/^\s*PROMPT\s+(.*)$/i"
        patterns(saShow) = "/^\s*SHOW\s+(COLUMN[S]?|INDEX(?:ES)?)\s+FROM\s+(\[[^\]]+\]|\S+)/i"
        patterns(saShowObjects) = "/^\s*SHOW\s+(TABLE[S]?|VIEW[S]?|QUER(?:Y|IES)|QUERYDEF[S]?)()(?:\s+WHERE\s+([\s\S]*))?/i"
        patterns(saShowIn) = "/^\s*SHOW\s+(COLUMNS)\s+IN\s+\(([\S\s]+)\)\s*/i"
        patterns(saShowVariables) = "/^SHOW\s+(VARIABLE[S]?)()$/i"
        patterns(saCreateView) = "/^\s*CREATE\s+OR\s+REPLACE\s+VIEW\s+(\S+)\s+AS\s+([\S\s]*)/i"
        patterns(saCreate) = "/\s*(CREATE\s+(TABLE|INDEX)\s+(\S+)([\s\S]+))/i"
        patterns(saAlter) = "/\s*(ALTER\s+(TABLE|INDEX)\s+(\S+)([\s\S]*))/i"
        patterns(saDrop) = "/(DROP\s+(TABLE|VIEW|INDEX)\s+(\S+)([\s\S]*))/i"
        patterns(saInsertOnDuplicateUpdate) = "/^\s*(INSERT\s+INTO\s+(\S+)\s?\(([^\)]+)\)\s+VALUES\s*\(([^\)]+)\))\s+ON\s+DUPLICATE\s+KEY\s+UPDATE\s+([\S\s]+)/i"
        patterns(saInsert) = "/^\s*INSERT\s+INTO\s+(\S+)/i"
        patterns(saUpdate) = "/^\s*(UPDATE\s+(\S+)\s+SET\s+([\s\S]+?)(?:\s+WHERE\s+([\s\S]+)|\s*$))/i"
        patterns(saDelete) = "/^\s*(DELETE\s+(?:[\s\S]\s+)?FROM\s+(\S+)(?:\s+WHERE\s+([\s\S]+)|$))/i"
        patterns(saSet) = "/^\s*SET\s+(\S+|\[[^\]]+\])\s*=\s*(.+)\s*$/i"
        patterns(saClearCache) = "/^\s*CLEAR CACHE\s*$/i"
        patterns(saDirect) = "/^\s*([\s\S]+)/i"
    End If
    If rxList(iAction) Is Nothing Then
        If Not patterns(iAction) = Empty Then Set rxList(iAction) = cRx(patterns(iAction))
    End If
    Set rxAction = rxList(iAction)
End Property