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.5.2
'Name         : SQLScript
'Author       : Stefan Erb (ERS)
'History      : 21.04.2015 - ERS - Creation
'               ...
'               24.10.2016 - ERS - getSQLType um DOUBLE erweitert/Fehler im DROP behoben
'               04.11.2016 - ERS - instanceByTableText so erweitert, dass leere Spalten (kein Header und kein Inhalt) unterdrückt werden
'               18.01.2017 - ERS - RegExp Patterns angepasst, dass Objektnamen mit [] und Leerzeichen erkennt werden
'
'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
'               udf_printrs.bas     http://wiki.yaslaw.info/dokuwiki/doku.php/vba/access/functions/printrs
'-------------------------------------------------------------------------------
 
'-------------------------------------------------------------------------------
' ! 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
 
'Das Interface IFormattable ist in diesem Projekt vorhanden
#Const IFormattable_exists = False
 
#If IFormattable_exists Then
    Implements IFormattable
#End If
 
'-------------------------------------------------------------------------------
' -- Public events
'-------------------------------------------------------------------------------
Public Event executeFinished(ByRef oRetVal As Variant, ByVal oAction As sqlActions, ByRef iCancel As Boolean)
 
'-------------------------------------------------------------------------------
' -- 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 ....
    saSelectInto
    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
    saAbout
    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        'Fehler ignorieren und weiterfahren
    spLogText = 2 ^ 3       'Gibt anstelle des Return Values gleich den genierten logText zurück
    spNoAutoCache = 2 ^ 4   'Bei Abfragen mit Paramtern die Paramter nicht im Cache speichern
End Enum
 
'/**
' * Parameter um die Text-zu-TableCreate zu steuern
' */
Public Enum text2ddlParams
    tdAutomatic = 0
    tdNoHeader = 2 ^ 0          'Die Erste Zeile ist keine Kopfzeile
    tdSuppressDashLines = 2 ^ 1 'Linien die nur aus -_=| und Leerzeichen bestehen werden unterdrückt. Das werden Trennlinien sein
    tdDropTable = 2 ^ 2         'Erstelle zum  CREATE TABEL auch ein DROP TABLE
End Enum
'-------------------------------------------------------------------------------
' -- Private Members
'-------------------------------------------------------------------------------
'/**
' * Error Konstantens
' */
Private Const C_SD_ERR_INVALID_FORMAT = -2147221504 + 1  'Das Format ist nicht parsbar
Private Const C_SD_ERR_NOT_PARSEBLE = -2147221504 + 2    'Der String passt nicht mit dem Format überein
Private Const ERR_SQLScript_ONLY_FOR_CONTAINER = vbObjectError + 101
Private Const ERR_SQLScript_NOT_FOR_CONTAINER = vbObjectError + 102
 
Private Const C_TEMP_QUERY_NAME = "vw_sqlscript_tmp"
 
Private Const P_NR = "NR"
Private Const P_START_LINE = "START_LINE"
Private Const P_START_POS = "START_POS"
Private Const P_END_LINE = "END_LINE"
Private Const P_LINES = "LINES"
Private Const P_LINE_START_POSITIONS = "LINE_START_POSITIONS"
Private Const P_CMD = "ORIG_CMD"
Private Const P_LEN = "LEN"
 
'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
Private pLogTextes() As String
Private pScriptProperties() As Object
Private pScriptIndex() As Long
 
'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 pSqlVariables As Object
Private pSqlVariablesString As Object
Private pSqlType As sqlType
Private pRetVal As Variant
Private pCancel As Boolean
Private pProperties As Object               'Dictionary
 
'/**
' * 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
 
    Set instanceByFileDialog = New SQLScript
 
    If fld.Show <> 0 Then
        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 ein DDLScriptcontainer aus einem String
' * @param  String      SQL-Script
' * @retrun SQLScript
' */
Public Static Function instanceByText(ByVal iScriptText As String) As SQLScript
    Set instanceByText = New SQLScript
    instanceByText.readText iScriptText
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
 
 
 
'/**
' * Erstellt ein DDLScriptcontainer aus einem Text, der eine Tabelle darstellt
' * @param  String          Tabelle in Textform. zB. CSV
' * @param  String          Tabellenname
' * @param  String          Mögliche Spaltendelemiter als RegExp-Pattern
' * @param  text2ddlParams  Steuerparameter
' * @param  String          Eine seperate Kopfzeile. Wenn die Kopfzeile bereits im iText ist,
' *                         muss sie nicht seperat mitgegeben werden. NoHeader wird ignoriert
' * @retrun SQLScript
' */
Public Function instanceByTableText( _
        ByVal iText As String, _
        ByVal iTableName As String, _
        Optional ByVal iDelemiterRxPattern As String = "[,|;\t]", _
        Optional ByVal iParams As text2ddlParams = tdSuppressDashLines, _
        Optional ByVal iHeader As String = Empty _
) As SQLScript
    Dim tableName       As String:      tableName = createSqlName(iTableName)           'Tabellenname mit [] umklammert
    Dim rowsTxt()       As String:      rowsTxt = Split(iText, vbCrLf)                  'Zeilen des Textes
    Dim rxDelemiter     As Object:      Set rxDelemiter = cRx(iDelemiterRxPattern)      'Mögliche Spaltendelemiter als RegExp-Pattern
    Dim delemiter       As String:      delemiter = ","                                 'Wirklicher Spatlendelemiter
    If rxDelemiter.test(rowsTxt(0)) Then delemiter = cRx(iDelemiterRxPattern).execute(rowsTxt(0))(0).value
 
    Dim rowNr As Long, colNr As Long, scriptNr As Long                                  'Durchnummerierungen
    Dim rowFields()     As Variant                                                      'Felder einer Zeile Array<Felder>
    Dim firstDataRow    As Integer:     firstDataRow = IIf(UBound(rowsTxt) > 0, 1, 0)   'Zeilennummer der ersten Datenzeile
    If Not iHeader = Empty Then firstDataRow = 0                                        'Header seperat wird mitgegeben
    If andB(iParams, tdNoHeader) Then firstDataRow = 0                                  'Header ausgeschaltet
 
    Dim hdrRow          As String:      hdrRow = IIf(iHeader = Empty, rowsTxt(0), iHeader)
    Dim hdrFields()     As Variant:     hdrFields = cArray(hdrRow, delemiter)           'Spaltenüberschriften auslesen
 
    Dim hdrFieldsSql()  As Variant:     ReDim hdrFieldsSql(UBound(hdrFields))           'Spaltennamen im SQL-Format
    'Falls nur eine Zeile vorhanden ist, so ist dies eine Datenzeile und die Spalten werden durchnumeriert
    If firstDataRow = 0 Then ReDim hdrFields(UBound(hdrFields))
 
    Dim types()         As VbVarType:   ReDim types(UBound(hdrFields))                  'Spaltentypen
    Dim colLengths()    As Long:        ReDim colLengths(UBound(hdrFields))             'Spaltenlängens
    Dim colSupress()    As Boolean:     ReDim colSupress(UBound(hdrFields))             'Angabe, ob eine Spalte unterdrückt wird
    Dim tblMatrix()     As Variant                                                      'Array<Zeile=Array<Felder>>
 
    'Script-Container anlegen
    Set instanceByTableText = New SQLScript
 
    'Zeilenweise die Daten auslesen
    For rowNr = firstDataRow To UBound(rowsTxt)
        If Trim(rowsTxt(rowNr)) = "" Then
            'Ignore empty lines
        ElseIf rxDash(delemiter).test(rowsTxt(rowNr)) And andB(iParams, tdSuppressDashLines) Then
            'Ignore Dash-Lines
        Else
            rowFields = cArray(rowsTxt(rowNr), delemiter)
            'Sicherstellen, dass gleich viele Felder wie Headereinträge vorhanden sind
            If UBound(rowFields) <> UBound(hdrFields) Then ReDim Preserve rowFields(UBound(hdrFields))
            'Format/Grösse der Spalte ermitteln
            For colNr = 0 To UBound(hdrFields)
                'Format bestimmen
                If getTypeOrder(varType(rowFields(colNr))) > getTypeOrder(types(colNr)) Then types(colNr) = varType(rowFields(colNr))
                'Spaltengrösse ermitteln
                If Len(rowFields(colNr)) > colLengths(colNr) Then colLengths(colNr) = Len(rowFields(colNr))
            Next colNr
            scriptNr = scriptNr + 1
            ReDim Preserve tblMatrix(scriptNr)
            tblMatrix(scriptNr) = rowFields
        End If
    Next rowNr
 
    'Alle Spalten prüfen, ob 1) ein Titel vorhanden ist und 2) die SPaltenbreite > 0 ist
    For colNr = UBound(colLengths) To 0 Step -1
        If Trim(hdrFields(colNr)) = Empty And colLengths(colNr) = 0 Then
            hdrFields = arrayRemoveItem(hdrFields, colNr)
            hdrFieldsSql = arrayRemoveItem(hdrFieldsSql, colNr)
            types = arrayRemoveItem(types, colNr)
            colLengths = arrayRemoveItem(colLengths, colNr)
            rowFields = arrayRemoveItem(rowFields, colNr)
        End If
    Next colNr
 
    'Spaltendefintionen erstellen
    For colNr = 0 To UBound(hdrFields)
        'Falls der Header kein Text ist, ein generischer Header setzen
        If IsNumeric(hdrFields(colNr)) Or Trim(hdrFields(colNr)) = Empty Then hdrFields(colNr) = "FIELD_" & colNr + 1
        'Die Spaltennamen in [] setzen
        hdrFields(colNr) = createSqlName(hdrFields(colNr))
        'SQL Definition erstellen
        hdrFieldsSql(colNr) = hdrFields(colNr) & " " & getSQLType(vbType2dbType(types(colNr)), colLengths(colNr))
    Next colNr
 
    'DropTabel Script
    If andB(iParams, tdDropTable) Then instanceByTableText.add "DROP TABLE " & tableName
 
    'Create Table Script erstellen und hinzufügen
    instanceByTableText.add "CREATE TABLE " & tableName & " (" & Join(hdrFieldsSql, ",") & ")"
 
    'Zeilenverarbeitung
    For scriptNr = 1 To UBound(tblMatrix)
        'Die Werte ins SQL Format bringen
        For colNr = 0 To UBound(rowFields)
            rowFields(colNr) = castSqlString(tblMatrix(scriptNr)(colNr), IIf(NZ(tblMatrix(scriptNr)(colNr), Empty) = Empty, vbNull, types(colNr)))
        Next colNr
        'Zeilenscript erstellen nd hinzufügen
        instanceByTableText.add "INSERT INTO " & tableName & " (" & Join(hdrFields, ",") & ") VALUES (" & Join(rowFields, ",") & ")"
    Next scriptNr
End Function
 
'-------------------------------------------------------------------------------
' -- Public methodes
'-------------------------------------------------------------------------------
 
'/**
' * 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)
    Static rxLastSemicol As Object: If rxLastSemicol Is Nothing Then Set rxLastSemicol = cRx("/;\s*$/")
    Static rxLastLineOfCmd As Object: If rxLastLineOfCmd Is Nothing Then Set rxLastLineOfCmd = cRx("/^(?!\s*(?:--|PARAMETERS\b)).*;\s*$/i")
 
    If Not pAction = saContainer Then Err.raise ERR_SQLScript_ONLY_FOR_CONTAINER, "SQLScript.readText", "Object-Action is not a Container"
 
    Set pScriptsO = New Collection
 
    Erase pScriptProperties
    If trims(iScriptText) = Empty Then Exit Sub
 
    Dim fLines() As String: fLines = Split(iScriptText, vbCrLf)
 
    Dim lnCnt As Long:              lnCnt = UBound(fLines)
    Dim nextStart As Long:          nextStart = 0
    Dim lineStartPos() As Long:  ReDim lineStartPos(lnCnt)
    ReDim pScriptIndex(lnCnt)
 
    'Script Array initialisieren
    Dim k As Long: k = 0
    ReDim pScriptProperties(k)
    Set pScriptProperties(k) = CreateObject("scripting.Dictionary")
    pScriptProperties(k)(P_START_LINE) = 0
 
    Dim lines() As String: ReDim lines(0)
    'Zeilenweise abarbeiten
    Dim i As Long: For i = 0 To lnCnt
        lineStartPos(i) = nextStart
        Dim line As String:         line = trims(fLines(i))
        Dim lastScriptNr As Long:   lastScriptNr = k
        'Die Linie dem Script übergeben
        ReDim Preserve lines(pScriptProperties(lastScriptNr)(P_START_LINE) To i)
        lines(i) = fLines(i)
        'Script Ende finden. Endet mit ; ohne -- am Anfang und ohne 'PARAMETERS' am Anfang
        'If Not line Like "--*" And line Like "*;" And Not line Like "*\;" And Not UCase(Trim(line)) Like "PARAMETERS*" Then
        If rxLastLineOfCmd.test(line) Then
            pScriptProperties(k)(P_LINES) = lines
            pScriptProperties(k)(P_END_LINE) = i              'offenes Script abschliessen
            If i < lnCnt Then                   'neues Script initialisieren, sofern wir nicht am Ende vom Text sind
                ReDim Preserve pScriptProperties(inc(k))
                Set pScriptProperties(k) = CreateObject("scripting.Dictionary")
                Erase lines
                pScriptProperties(k)(P_NR) = k
                pScriptProperties(k)(P_START_LINE) = i + 1
            End If
        End If
        pScriptIndex(i) = lastScriptNr                'Index nachführen
 
        'Startposition der nächsten Zeile berechnen
        nextStart = nextStart + Len(fLines(i)) + Len(vbCrLf)
    Next i
    'Falls das letzte Script nicht mit einem ; abgeschlossen ist
    If pScriptProperties(lastScriptNr)(P_END_LINE) = 0 Then
        pScriptProperties(lastScriptNr)(P_END_LINE) = lnCnt
        pScriptProperties(k)(P_LINES) = lines
    End If
 
 
    For i = 0 To UBound(pScriptProperties)
        'Scripts vervollständigen
        pScriptProperties(i)(P_START_POS) = lineStartPos(pScriptProperties(i)(P_START_LINE))      'Start Position ermitteln
        pScriptProperties(i)(P_CMD) = Join(pScriptProperties(i)(P_LINES), vbCrLf)
        pScriptProperties(i)(P_LEN) = Len(pScriptProperties(i)(P_CMD))    'Länge ermitteln
 
        'Kommentare entfernen
        Dim cmd As String: cmd = masked2unicode(rxSqlComment.replace(pScriptProperties(i)(P_CMD), ""))
        If rxLastSemicol.test(cmd) Then cmd = rxLastSemicol.replace(cmd, Empty)
        'Passende Action suchen
        Dim act As sqlActions: For act = sqlActions.[_FIRST] To sqlActions.[_LAST]
            If rxAction(act).test(trims(cmd)) Then
                Dim cCmd As SQLScript: Set cCmd = SQLScript.instanceSubScript(cmd, act)
                Set cCmd.properties = pScriptProperties(i)
                add cCmd
                Exit For
            End If
        Next act
    Next i
    Set properties = CreateObject("scripting.Dictionary")
    properties(P_LINES) = fLines
    properties(P_LINE_START_POSITIONS) = lineStartPos
End Sub
 
'/**
' * Diese Funktion kann nur in einem ScriptContainer ausgeführt werden
' * @param  SQLScript/String    Ein Script oder ein SQL-String
' * @param  ddlaAction          Den Typ. Wird nur verwendet, wenn iScript ein String ist
' * @return SQLScript
' */
Public Function add(ByRef iScript As Variant, Optional ByVal iAction As sqlActions = saAutomatic) As SQLScript
    If Not pAction = saContainer Then Err.raise ERR_SQLScript_ONLY_FOR_CONTAINER, "SQLScript.add", "Object-Action is not a Container"
    Dim subScript As SQLScript
    Select Case TypeName(iScript)
        Case "SQLScript":       Set subScript = iScript
        Case "String":          Set subScript = SQLScript.instanceSubScript(iScript, iAction)
        Case Else:              Err.raise 13  'Type mismatch
    End Select
    subScript.index = pScriptsO.count    'Index zuweisen
    Set subScript.parent = Me
    pScriptsO.add subScript
    Set add = subScript
End Function
 
'/**
' * initialisiert eine ScriptObjekt
' * @param  String          Der Script-String
' * @param  ddlaAction
' */
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
    'Kommentarzeilen entfernen
    pCmd = rxSqlComment.replace(icmd, Empty)
    'Abschliessende ; entfernen
    pCmd = pRx.replace(pCmd, 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 Variant     Je nach Script unterschiedlich. Recordset, Value, QueryDef, Boolean.
' *                     Wenn als Paramter spLogText ist es ein lesbaerer Rückgabestring
' */
Public Function execute(Optional ByVal iParams As sqlParams = spNone, Optional ByRef oAction As sqlActions) As Variant
On Error GoTo Err_Handler
    If Not pError Is Nothing Then error.RemoveAll
    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
            If pScriptsO.count > 0 Then
                Dim retVals() As Variant: ReDim retVals(pScriptsO.count - 1)
                ReDim pLogTextes(pScriptsO.count - 1)
                Dim i As Long: For i = 1 To pScriptsO.count
                    ref retVals(i - 1), pScriptsO(i).execute(iParams)
                    pLogTextes(i - 1) = pScriptsO(i).logText
                Next i
                pRetVal = retVals
            End If
        'Die Einzelscripts:
        Case saSelect:                    Set pRetVal = queryDefWithParams(, iParams)                    '@return: QueryDef
        Case saSelectWithParams:          Set pRetVal = queryDefWithParams(, iParams)                    '@return: QueryDef
        Case saShow:                      Set pRetVal = executeShow                                     '@return: ADODB.Recordset
        Case saShowIn:                    Set pRetVal = executeShow                                     '@return: ADODB.Recordset
        Case saShowObjects:               Set pRetVal = executeShow                                     '@return: ADODB.Recordset
        Case saShowVariables:             Set pRetVal = executeShow                                     '@return: ADODB.Recordset
        Case saPrompt:                    pRetVal = executePrompt                                       '@return: String    Auszugebender Text
        Case saSet:                       pRetVal = executeSet                                          '@return: Variant   Wert des Set-Befehls
        Case saClearCache:                pRetVal = executeClearCache                                   '@return: Boolean
        Case saCreateView:                pRetVal = executeCreateOrReplaceView(iParams, oAction)        '@return: Boolean
        Case saCreate:                    pRetVal = executeCreate(iParams)                              '@return: Boolean
        Case saDrop:                      pRetVal = executeDrop(iParams)                                '@return: Boolean
        Case saAlter:                     pRetVal = executeAlter(iParams)                               '@return: Boolean
        Case saInsertOnDuplicateUpdate:   pRetVal = executeInsertOnDuplicateUpdate(iParams, oAction)    '@return: Long     Anzahl betroffener Zeilen
        Case saInsert:                    pRetVal = executeDirect(iParams, oAction)                     '@return: Long     Anzahl betroffener Zeilen
        Case saSelectInto:                pRetVal = executeDirect(iParams, oAction)                     '@return: Long     Anzahl betroffener Zeilen
        Case saUpdate:                    pRetVal = executeDirect(iParams, oAction)                     '@return: Long     Anzahl betroffener Zeilen
        Case saDelete:                    pRetVal = executeDelete(iParams)                              '@return: Long     Anzahl betroffener Zeilen
        Case saAbout:                     pRetVal = version
        Case Else:                        pRetVal = executeDirect(iParams, oAction)                     '@return: Long     Boolean
    End Select
Exit_Handler:
On Error Resume Next
    ref execute, IIf(andB(iParams, spLogText), logText, pRetVal)
    Dim Cancel As Boolean
    RaiseEvent executeFinished(execute, action, Cancel)
    parent.Cancel = Cancel
    Exit Function
Err_Handler:
    setErr Err
    Resume Exit_Handler
    Resume
End Function
 
'/**
' * Gibt ein String-Wert eines Objektes zurück
' * @return String
' */
Public Property Get toString() As String
    Select Case action
        'Die Instanz ist ein Scriptcontainer. Alle Scripts des Containers ausführen. Rückgabewerte werden ignoriert
        Case saContainer:
            If pScriptsO.count > 0 Then
                Dim retVals() As String: ReDim retVals(pScriptsO.count - 1)
                ReDim pLogTextes(pScriptsO.count - 1)
                Dim i As Long: For i = 1 To pScriptsO.count
                    ref retVals(i - 1), pScriptsO(i).toString
                    pLogTextes(i - 1) = pScriptsO(i).logText
                Next i
                pRetVal = retVals
            End If
            toString = Join(retVals, vbCrLf)
        'Die Einzelscripts:
        Case saPrompt:                  toString = CStr(execute)
        Case Else:                      getRunnableSql toString
    End Select
End Property
 
'/**
' * @depreched -> castSqlString
' * Parst ein Value in ein SQL-String
' * @param  Variant
' * @param  DAO.DataTypeEnum
' * @return String
' */
'Public Function getSqlString(ByVal iValue As Variant, ByVal iVarType As VBA.VbVarType) As String
'    getSqlString = castSqlString(iValue, iVarType)
'End Function
 
 
'/**
' * Gibt einen SQL-String anhand des Datentyp zurück
' * @param  Variant         Daten
' * @param  VBA.VbVarType   Datentype aus VarType() überschreiben
' * @return String          SQL-String
' */
Public 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(CBool(iValue)) 'CStr(CInt(iValue))
        Case vbLong, vbInteger, vbByte, vbDouble, vbDecimal, vbSingle, vbCurrency
                            castSqlString = CStr(iValue)
        Case Else:          castSqlString = "'" & escapeQuota(CStr(iValue)) & "'"
    End Select
End Function
 
'/**
' * @depreched
' * 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
    add icmd, iAction
    addNewScript = True
End Function
 
'/**
' * Erstellt eine Temporäre Abfrage mit dem Namen aus C_TEMP_QUERY_NAME und öffent die Edit-Ansicht
' * Kann nur auf ein Einzel- oder SubScript angewendet werden
' * */
Public Function openInQueryBuilder() As Boolean
    If pAction = saContainer Then Err.raise ERR_SQLScript_NOT_FOR_CONTAINER, "SQLScript.add", "Object-Action is not for Container"
 
    Dim sql As String
    Dim qdfName As String
    openInQueryBuilder = getRunnableSql(sql, qdfName)
    If Not openInQueryBuilder Then Exit Function
 
    Dim qdf As QueryDef
    If objectExists(acQuery, C_TEMP_QUERY_NAME) Then
        If IsObjectLoaded(C_TEMP_QUERY_NAME, acQuery) Then
            If Not MsgBox("Das temporäre Query ist noch offen. Soll das geschlossen werden? Die Änderungen werden verworfen.", vbQuestion + vbOKCancel, "SQLScript") = vbOK Then Exit Function
            DoCmd.Close acQuery, C_TEMP_QUERY_NAME, acSaveNo
        End If
        CurrentDb.QueryDefs.delete C_TEMP_QUERY_NAME
    End If
 
    Set qdf = New QueryDef
    qdf.sql = sql
    qdf.Name = C_TEMP_QUERY_NAME
    CurrentDb.QueryDefs.Append qdf
 
    Call Application.SetHiddenAttribute(acQuery, C_TEMP_QUERY_NAME, True)
    DoCmd.OpenQuery C_TEMP_QUERY_NAME, acViewDesign
End Function
 
'/**
' * Parst ein SQL-String (inklusife Delemiter) in seinen Datentyp
' * @param  String      SQL-String Value
' * @param  vbVarType   Zieltyp
' * @param  Variant
' *
Public Function getValueFromSqlString(ByVal iSqlString As String, ByVal iVarType As VBA.VbVarType) As Variant
On Error Resume Next
    getValueFromSqlString = Eval(iSqlString)
    If Err.number <> 0 Then getValueFromSqlString = iSqlString
    getValueFromSqlString = cast(iVarType, getValueFromSqlString)
End Function
 
 
 
'/**
' * Die SQL Variablen/Parameter zurücksetzen
' */
Public Sub resetCache(Optional ByVal iVarName As String = Empty)
    If iVarName = Empty Then
        Set pSqlVariables = Nothing
        Set pSqlVariablesString = Nothing
    Else
        Dim varName As String: varName = UCase(iVarName)
        If Not pSqlVariables Is Nothing Then If pSqlVariables.exists(varName) Then pSqlVariables.remove varName
        If Not pSqlVariablesString Is Nothing Then If pSqlVariablesString.exists(varName) Then pSqlVariablesString.remove varName
    End If
End Sub
 
'/**
' * Ermittelt den Indes des SQL-Befehles anhand einer Zeilennr eines SQL-Scriptes
' * @param  Long    Zeilennummer
' * @retrun Long    Index desSubscriptes
' */
Public Function getCmdIndexFromLineNr(ByVal iLnNr As Long) As Long
    If Not pAction = saContainer Then Err.raise ERR_SQLScript_ONLY_FOR_CONTAINER, "SQLScript.add", "Object-Action is not a Container"
    If isNothing(pScriptIndex) Then
        getCmdIndexFromLineNr = 0
    Else
        getCmdIndexFromLineNr = pScriptIndex(iLnNr)
    End If
End Function
 
'/**
' * Ermittelt den den SQL-Befehles anhand einer Zeilennr eines SQL-Scriptes
' * @param  Long    Zeilennummer
' * @retrun String  SQL-Befehl
' */
Public Function getCmdFromLineNr(ByVal iLnNr As Long) As SQLScript
    If Not pAction = saContainer Then Err.raise ERR_SQLScript_ONLY_FOR_CONTAINER, "SQLScript.add", "Object-Action is not a Container"
    If isNothing(pScriptsO) Then
        Set getCmdFromLineNr = New SQLScript
    Else
        Set getCmdFromLineNr = pScriptsO(pScriptIndex(iLnNr) + 1)
    End If
End Function
 
'/**
' * 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
 
 
 
 
 
'/**
' * 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
 
#If IFormattable_exists Then
    '-------------------------------------------------------------------------------
    ' -- Interface methodes/properties
    '-------------------------------------------------------------------------------
 
    Private Function IFormattable_cast(iObject As Variant) As IFormattable
    End Function
 
    '/**
    ' * Gibt das Originalobjekt  zurück
    ' * @object
    ' */
    Private Property Get IFormattable_toString(Optional ByVal format As Variant, Optional ByRef FormatProvider As Object) As String
        IFormattable_toString = toString
    End Property
#End If
 
'-------------------------------------------------------------------------------
' -- Private Methodes
'-------------------------------------------------------------------------------
Private Function getRunnableSql(Optional ByRef oSql As String, Optional ByRef oName As String) As Boolean
    Select Case action
        'Die Instanz ist ein Scriptcontainer. Alle Scripts des Containers ausführen. Rückgabewerte werden ignoriert
        Case saContainer: '@return: Anzahl Scripts
        'Die Einzelscripts:
        Case saSelect:                  getRunnableSql = getSqlQueryDef(oSql)
        Case saSelectWithParams:        getRunnableSql = getSqlQueryDef(oSql)
        Case saShow:
        Case saShowIn:
        Case saShowObjects:
        Case saShowVariables:
        Case saPrompt:
        Case saSet:
        Case saClearCache:
        Case saCreateView:              getRunnableSql = getSqlCreateOrReplaceView(oSql, oName)
        Case saCreate:                  getRunnableSql = getSqlCreate(oSql, , oName)
        Case saDrop:                    getRunnableSql = getSqlDrop(oSql, , oName)
        Case saAlter:                   getRunnableSql = getSqlDirect(oSql)
        Case saInsertOnDuplicateUpdate:
        Case saInsert:                  getRunnableSql = getSqlDirect(oSql)
        Case saSelectInto:
        Case saUpdate:                  getRunnableSql = getSqlDirect(oSql)
        Case saDelete:                  getRunnableSql = getSqlDirect(oSql)
        Case saAbout:
        Case Else:
    End Select
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 = andB(iParams, 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
            values(colIdx) = castSqlString(rs.fields(colIdx), flds(colIdx).Type)
'        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 die Hackordnung der verschiedenen Typen zurück. Höhere Ordnung überschreibt kleinere Ordnung
' * @param  VbVarType
' * @return Integer
' */s
Private Function getTypeOrder(ByVal iVarType As VbVarType) As Integer
    Select Case iVarType
        Case vbEmpty:       getTypeOrder = 1
        Case vbNull:        getTypeOrder = 2
        Case vbBoolean:     getTypeOrder = 3
        Case vbDate:        getTypeOrder = 4
        Case vbByte:        getTypeOrder = 11
        Case vbInteger:     getTypeOrder = 12
        Case vbSingle:      getTypeOrder = 13
        Case vbLong:        getTypeOrder = 14
        Case vbDouble:      getTypeOrder = 15
        Case vbDecimal:     getTypeOrder = 16
        Case vbString:      getTypeOrder = 91
    End Select
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
 
'/**
' * 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
 
'/**
' * Leert den Variablenspeicher
' */
Private Function executeClearCache() As String
    Dim varName As String: varName = UCase(rxAction(saClearCache).execute(trims(pCmd))(0).subMatches(0))
    If Not parent Is Nothing Then
        parent.resetCache varName
        executeClearCache = True
    End If
    executeClearCache = varName
End Function
 
'/**
' * Führt ein SHOW aus
' * @return ADODB.Recordset
' */
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(srcWhere)
        Case "VIEW", "VIEWS", "QUERY", "QUERIES", "QUERYDEF", "QUERYDEFS":
                                                Set executeShow = executeShowViews(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
 
'/**
' * Erstellt einen gefilterten DAO.Recordset
' * @param  String      SQL-String
' * @param  String      SQL-Filter
' * @return DAO.Recordset
' */
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
 
'/**
' * Führt ein SHOW TABLES aus
' * @param  String  WHERE
' * @return ADODB.Recordset
' */
Private Function executeShowTables(ByVal iSrcWhere As String) As Object
    Dim aRs As Object:          Set aRs = CreateObject("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
 
'/**
' * Führt ein SHOW VIEW aus
' * @param  String  WHERE
' * @return ADODB.Recordset
' */
Private Function executeShowViews(ByVal iSrcWhere As String) As Object
    Dim aRs As Object:          Set aRs = CreateObject("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
 
'/**
' * Führt ein SHOW COLUMNS aus
' * @param  String  Quellname (Tabelle/View)
' * @param  String  WHERE
' * @return ADODB.Recordset
' */
Private Function executeShowColumns(ByVal iSrcName As String) As Object
    Dim aRs As Object:          Set aRs = CreateObject("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(andB(.Attributes, dbAutoIncrField)), .defaultValue)
        End With
    Next i
    aRs.sort = "nr"
    Set executeShowColumns = aRs
End Function
 
'/**
' * Führt ein SHOW INDEX aus
' * @param  String  Tabellenname
' * @param  String  WHERE
' * @return ADODB.Recordset
' */
Private Function executeShowIndizes(ByVal iSrcName As String) As Object
    Dim aRs As Object:          Set aRs = CreateObject("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")
 
    '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 getSqlCreateOrReplaceView(Optional ByRef oSql As String, Optional ByRef oName As String) As Boolean
    getSqlCreateOrReplaceView = rxAction(saCreateView).test(pCmd)
    If getSqlCreateOrReplaceView Then list rxAction(saCreateView).execute(pCmd)(0), oName, oSql
End Function
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 getSqlCreateOrReplaceView(sql, queryName) Then Err.raise C_SD_ERR_NOT_PARSEBLE, "executeCreateOrReplaceView"
 
    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
    Resume Exit_Handler
    Resume
End Function
 
' * /\s*(CREATE\s+(TABLE|INDEX)\s+(\S+)([\s\S]+))/i
' * 0 = Ganzes Script
' * 1 = Type
' * 2 = ItemName
Private Function getSqlCreate(Optional ByRef oSql As String, Optional ByRef oCreateType, Optional ByRef oItemName, Optional ByRef oRest) As Boolean
    getSqlCreate = rxAction(saCreate).test(pCmd)
    If getSqlCreate Then list rxAction(saCreate).execute(pCmd)(0), oSql, oCreateType, oItemName, oRest
End Function
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
    getSqlCreate sql, createType, itemName, rest
 
    Select Case UCase(createType)
        Case "TABLE":
            If objectExists(acTable, itemName) And andB(iParams, spOverwrite) Then
                CurrentDb.execute "DROP TABLE " & itemName
            End If
            pAffectedType = soTable
            pAffectedItem = itemName
        Case "INDEX":
            pAffectedType = soIndex
            pAffectedItem = itemName
            Dim tableName As String:   tableName = rxOnTable.execute(rest)(0).subMatches(0)
    End Select
    CurrentDb.execute sql
 
    executeCreate = True
End Function
 
' * (DROP\s+(INDEX)\s+(\S+)(.*))
Private Function getSqlDrop(Optional ByRef oSql As String, Optional ByRef oObjectType, Optional ByRef oItemName, Optional ByRef oRest) As Boolean
    getSqlDrop = rxAction(saDrop).test(pCmd)
    If getSqlDrop Then list rxAction(saDrop).execute(pCmd)(0), oSql, oObjectType, oItemName, oRest
End Function
Private Function executeDrop(ByVal iParams As sqlParams) As Boolean
On Error GoTo Err_Handler
    Dim sql As String, objectType As String, itemName As String, rest As String
    'list rxAction(saDrop).execute(pCmd)(0), sql, objectType, itemName, rest
    getSqlDrop script, objectType, itemName, rest
 
    pAffectedItem = itemName
    Select Case UCase(objectType)
        Case "TABLE"
            pAffectedType = soTable
            CurrentDb.execute script
        Case "VIEW"
            pAffectedType = soQueryDef
            If objectExists(acQuery, itemName) Then CurrentDb.QueryDefs.delete itemName
        Case "INDEX"
             pAffectedType = soIndex
             Dim tableName As String:   tableName = rxOnTable.execute(rest)(0).subMatches(0)
             pAffectedItem = tableName & "." & itemName
             CurrentDb.execute script
    End Select
 
    executeDrop = True
    Exit Function
Err_Handler:
    executeDrop = False
    Exit Function
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
 
    Dim qdf As QueryDef: Set qdf = queryDefWithParams(sql)
    qdf.execute
    executeDelete = qdf.RecordsAffected
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*(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"
            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
        Resume 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 = CreateObject("scripting.Dictionary")  'Set data = cDict(fields, values)
    Dim i As Long: For i = 0 To UBound(fields)
        data.add fields(i), values(i)
    Next i
 
    '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
    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
    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
 
'/**
' * Ein freier Text im Log ausgeben
' * @return String
' */
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 getSqlDirect(Optional ByRef oSql As String) As Boolean
    oSql = queryDefWithParams.sql
    getSqlDirect = True
End Function
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, saSelectInto:          executeDirect = qdf.RecordsAffected
        Case Else:                                      executeDirect = True
    End Select
    Exit Function
Err_Handler:
    setErr Err  'Fehler speichern
    If andB(iParams, 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 andB(iParams, 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
' */
Private 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
 
'/**
'* Entfernt ein Eintrag aus einem Array und verkürzt diesen
' * @param  Variant Der zu verkürzende Array
' * @param  Long    Index der gelöscht werden soll
' * @param  Variant
' */
Private Function arrayRemoveItem(ByVal iArray As Variant, ByVal iIndex As Long) As Variant
    Dim retArr As Variant: ref retArr, iArray
    'Es ist kein Array -> Original zurückgeben
    If Not IsArray(iArray) Then GoTo Exit_Handler
    'Der zulöschende Index ist ausserhlab des Arrays -> Original zurückgeben
    If iIndex < LBound(iArray) Or UBound(iArray) < iIndex Then GoTo Exit_Handler
    'Der Originalarray hat nur einen Eintrag -> leerer Array zurückgeben
    If LBound(iArray) = UBound(iArray) Then retArr = Array():         GoTo Exit_Handler
 
    'Ab dem zu löschenden ndex alles um eins Nach vorne schieben
    Dim i As Long: For i = iIndex To UBound(iArray) - 1
        retArr(i) = iArray(i + 1)
    Next i
    'Den Array verkürzen
    ReDim Preserve retArr(LBound(iArray) To UBound(iArray) - 1)
 
Exit_Handler:
    ref arrayRemoveItem, retArr
    Exit Function
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 = CreateObject("scripting.Dictionary")
        info.add "autoIncrFld", Empty
        info.add "fields", CreateObject("scripting.Dictionary")
        info.add "types", CreateObject("scripting.Dictionary")
        info.add "indexName", CreateObject("scripting.Dictionary")
        '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 andB(iTbl.fields(fld.Name).Attributes, 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
 
'/**
' * Escapte Quotas:     "Er sagt: 'Hallo'" -> "Er sagt: ''Hallo''"
' * @param  String  Text
' * @param  String  Quota
' * @return String
' */
Private Function escapeQuota(ByVal iText As String, Optional ByVal iQuota As String = "'") As String
    Static quota As String
    Static rx As Object:
    If rx Is Nothing Or quota <> iQuota Then
        quota = escapeRegExpPattern(iQuota)
        Set rx = cRx("/([" & quota & "])/g")
    End If
    escapeQuota = rx.replace(iText, "$1$1")
End Function
 
'/**
' * Generiert ein SQL-Name der mit [] umklammert ist, Auch wenn er bereits [] besitzt
' * @param  String  Name
' * @return String
' */
Private Function createSqlName(ByVal iName As String) As String
    Static rx As Object:  If rx Is Nothing Then Set rx = cRx("/^\[?(.*?)\]?$/")
    createSqlName = rx.replace(iName, "[$1]")
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
 
Public Property Get Cancel() As Boolean:                    Cancel = pCancel:       End Property
Public Property Let Cancel(ByVal iCancel As Boolean):       pCancel = iCancel:      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
 
' * Der Rückgabewert
Public Property Get returnValue() As Variant:               ref returnValue, pRetVal:        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
Public Property Set sqlVariables(ByRef iVariables As Object)
    Set pSqlVariables = iVariables
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
 
Public Property Get properties() As Object:                 Set properties = pProperties:   End Property
Public Property Set properties(ByRef iProp As Object):      Set pProperties = iProp:        End Property
 
Public Property Get scriptIndex() As Long():                scriptIndex = pScriptIndex:     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
    If action = saContainer And iIndex = -1 Then
        sql = Empty
    ElseIf action = saContainer Then
        sql = pScriptsO(iIndex).sql()
    Else
        sql = pCmd
    End If
End Property
 
'/**
' * Gibt das SQL-SQL-Script zurück. Mit ; am Ende. Im Falle eines Containers wird das ganze Script ausgegeben
' * @return String
' */
Public Property Get script() As String
    If action = saContainer Then
        Dim sqls() As String: ReDim sqls(count - 1)
        Dim i As Long: For i = 0 To UBound(sqls)
            sqls(i) = item(i).sql
        Next i
        script = Join(sqls, ";" & vbCrLf)
    Else
        script = pCmd
    End If
    script = script & ";"
End Property
 
'/**
' * Alias für readText
' * @param  String
' */
Public Property Let script(ByVal iScriptText As String)
    Me.readText iScriptText
End Property
 
'/**
' * Gibt einen Text je nach Action zurück
' */
Public Property Get logText() As String
    Dim Cancel As Boolean
 
    'Je nach Action das Log nachführen
    If Not haveError Then
        Select Case action
            Case saContainer:       logText = Join(pLogTextes, vbCrLf & vbCrLf)
            Case saAbout:           logText = pRetVal
        'DCL
            Case saSelect, saSelectWithParams:
                logText = printRs(pRetVal, 0, prsReturn, Cancel)
                If Not Cancel Then If pRetVal.OpenRecordset.RecordCount > 100 Then logText = "..."
            Case saShow, saShowIn, saShowVariables, saShowObjects
                logText = printRs(pRetVal, 0, prsReturn)
            Case saPrompt:            logText = "> " & pRetVal
            Case saSet:               logText = sPrintF("Set Paramter [%s] to %s", affectedItem, pRetVal)
            Case saClearCache:        logText = IIf(pRetVal = Empty, "Clear Cache", "Clear Cache for Variable [" & pRetVal & "]")
        'DML
            Case saDelete:            logText = sPrintF("%d rows deleted", pRetVal)
            Case saInsert:            logText = sPrintF("Insert %d rows", pRetVal)
            Case saSelectInto:        logText = sPrintF("Insert %d rows", pRetVal)
            Case saUpdate:            logText = sPrintF("%d rows updated", pRetVal)
        'DDL
            Case saCreate, saCreateView:
                Select Case affectedType
                    Case soTable:     logText = sPrintF("Table %s created", affectedItem)
                    Case soQueryDef:  logText = sPrintF("View %s created/replaced", affectedItem)
                    Case soIndex:     logText = sPrintF("Index %s created", affectedItem)
                End Select
            Case saAlter
                Select Case affectedType
                    Case soTable:     logText = sPrintF("Table %s altered", affectedItem)
                    Case soIndex:     logText = sPrintF("Index %s altered", affectedItem)
                End Select
            Case saDrop
                Select Case affectedType
                    Case soTable:     logText = sPrintF("Table %s droped", affectedItem)
                    Case soQueryDef:  logText = sPrintF("view %s droped", affectedItem)
                    Case soIndex:     logText = sPrintF("Index %s droped", affectedItem)
                End Select
            Case Else                   'Do nothing
        End Select
    Else
        logText = sPrintF("Error %1$d\n%2$s", error("Number"), error("Description"))
    End If
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
 
'-------------------------------------------------------------------------------
' -- private properties
'-------------------------------------------------------------------------------
'/**
' * Temporäres QueryDef mit den Paramtern
' * @return QueryDef
' */
Private Function getSqlQueryDef(Optional ByRef oSql As String) As Boolean
    oSql = trims(unicodeDecode(sql))
    getSqlQueryDef = True
End Function
Private Function queryDefWithParams(Optional ByVal iSource As Variant = Null, Optional ByVal iParams As sqlParams) 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)
                If Not andB(iParams, spNoAutoCache) Then parent.sqlVariable(vName) = cV(value, "nb")
                qdf.Parameters(i).value = cV(value, "nb")
            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
 
' ** Ob eine Zeile nur aus Trennzeichen besteht
Private Property Get rxDash(ByVal iDelemiter As String) As Object
    Dim tmpDel As String: tmpDel = escapeRegExpPattern(iDelemiter)
    Static delemiter As String
    Static rx As Object
    If rx Is Nothing Or delemiter <> tmpDel Then
        delemiter = tmpDel
        Set rx = cRx("/^" & delemiter & "?(([-_=\|\s])?)(?:\1|[\s" & delemiter & "])*$/") '"/^,?(([-_=\s])?)(?:\1|[\s,])*$/"
    End If
    Set rxDash = 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 masked2unicode(ByVal iString As String) As String
    Static rx As Object:    If rx Is Nothing Then Set rx = cRx("/\\(?!u[0-9A-F]{4})(.)/")
    masked2unicode = iString
    Do While rx.test(masked2unicode)
        masked2unicode = rx.replace(masked2unicode, char2unicode(rx.execute(masked2unicode)(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
 
'/**
' * Namend er Abfragetypen
' * @param  Long    der QueryDefTypeEnum
' * @return String
' */
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
 
'/**
' * Diese Funktion erstellt eine Array mit einer Reihe von Werten
' * Analog zu range() in PHP.
' * @param  Variant     Start
' * @param  Variant     Maximum
' * @param  Long        Schrittgrösse
' */
Private Function range(ByVal iLow As Variant, ByVal iHigh As Variant, Optional ByVal iStep As Long = 1) As Variant()
    Dim retArr() As Variant
    Dim i As Long: For i = iLow To iHigh Step iStep
        Dim idx As Long:            idx = (i \ iStep)
        ReDim Preserve retArr(idx): retArr(idx) = i
    Next i
    range = retArr
End Function
 
'/**
' * 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
 
'/**
' * Escapte alle Sonderzeichen um eine rx-Pattern zu erstellen
' *
' *     string = escapeRegExpPattern(string)
' *
' * @example    escapeRegExpPattern("Hallo Welt. Geht es dir (noch) gut?")
' *             Hallo Welt\. Geht es dir \(noch\) gut\?
' * @param  String
' * @return String
' */
Public Function escapeRegExpPattern(ByVal iPattern As String) As String
    Static rx As Object: If rx Is Nothing Then Set rx = cRx("/([\\\*\+\?\|\{\[\](\)\^\$\.\#])/g")
    escapeRegExpPattern = rx.replace(iPattern, "\$1")
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
 
'/**
' * Macht einen Bit-Vergleich
' * @param  Long
' * @param  Long
' * @return Boolean
' */
Private Function andB(ByVal iHaystack As Long, ByVal iNeedle As Long) As Boolean
    andB = ((iHaystack And iNeedle) = iNeedle)
End Function
 
'/**
' * Wandelt einen String wenn möglich in das angegebene Format um
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cast
' * @param  VbVarType
' * @param  Variant
' * @param  Boolean     : Bei True wird ein Fehler greworfen, wenn der cast() nichtr durchfürbar ist. Ansonsten wir der Eingabewert zurückgegeben
' * @return Variant
' */
Private Function cast(ByVal iType As VbVarType, ByVal iVar As Variant, Optional ByVal iStrong As Boolean = False) As Variant
On Error GoTo Err_Handler
 
    cast = iVar
    Select Case iType
        Case vbNull, vbEmpty
                            If Not (iVar = Empty Or IsNull(iVar)) Then Err.raise 13         'Type mismatch
                            cast = Choose(iType + 1, Empty, Null)
        Case vbArray:       cast = IIf(IsArray(iVar), iVar, Array(iVar))
        Case vbBoolean:     cast = CBool(NZ(iVar))
        Case vbDate:        cast = CDate(NZ(iVar))
        Case vbString:      cast = CStr(iVar)
        Case vbInteger:     cast = CInt(NZ(iVar))
        Case vbLong:        cast = CLng(NZ(iVar))
        Case vbDouble:      cast = CDbl(NZ(iVar))
        Case vbDecimal:     cast = CDec(NZ(iVar))
        Case vbByte:        cast = CByte(NZ(iVar))
        Case vbSingle:      cast = CSng(NZ(iVar))
        Case vbCurrency:    cast = CCur(NZ(iVar))
        Case Else:          cast = CVar(NZ(iVar))
    End Select
 
Exit_Hanlder:
    Exit Function
Err_Handler:
    If iStrong Then Err.raise Err.number, Err.source, Err.DESCRIPTION, Err.HelpFile, Err.HelpContext
    cast = iVar
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
' */
Private 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
 
'-------------------------------------------------------------------------------
'               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
 
'/**
' * @param  Number
' * @param  incType     Type der Encrementation. Default ist i++
' * @retrun Number
'*/
Public Function inc(ByRef i As Variant) As Variant
    i = i + 1
    inc = i
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 dbDouble:      getSQLType = "DOUBLE"
        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
 
'https://msdn.microsoft.com/en-us/library/bb243768(v=office.12).aspx
Function IsObjectLoaded(ByVal strObjectName As String, ByVal strObjectType As AcObjectType) As Boolean
    IsObjectLoaded = (SysCmd(acSysCmdGetObjectState, strObjectType, strObjectName) <> 0)
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(saAbout) = "/^\s*(ABOUT|VERSION)\s*$/i"
        patterns(saSelectInto) = "/^\s*(SELECT[\s\S]+)\bINTO\b/i"
        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+(?:UNIQUE\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+(\S+))?\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
 
'-------------------------------------------------------------------------------
' -- Version Info
'-------------------------------------------------------------------------------
 
'/**
' * Version der Klasse/Modul
' * @return String
' */
Public Property Get version() As String
    'version = C_CLASS_NAME & " Version " & C_VERSION_NR & " (" & format(C_VERSION_DATE, "DD.MM.YYYY") & ")"
    version = moduleName & " Version " & versionNr & " (" & format(versionDate, "DD.MM.YYYY") & ")"
End Property
 
'/**
' * Name der Classe/Modul
' * @return String
' */
Public Property Get moduleName() As String
    moduleName = TypeName(Me)
End Property
 
'/**
' * Die Headerzeilen der Klasse/Modul (alles vor dem 'Option Explicit')
' * @return String
' */
Public Property Get moduleHdr() As String
    Static mHdr As String
    If mHdr = Empty Then
        Dim vbCodeMod As CodeModule:    Set vbCodeMod = VBE.VBProjects(1).VBComponents(moduleName).CodeModule
        Dim lineNr As Long: For lineNr = 1 To vbCodeMod.CountOfDeclarationLines
            If vbCodeMod.lines(lineNr, 1) Like "*Option Explicit*" Then Exit For
        Next lineNr
        mHdr = vbCodeMod.lines(1, lineNr - 1)
    End If
    moduleHdr = mHdr
End Property
 
'/**
' * Versionsnummer der Klasse/Modul
' * @return String
' */
Public Property Get versionNr() As String
    Static vNr As String
    If vNr = Empty Then
        ''Version      : 1.3.1
        Dim rxV As Object:              Set rxV = cRx("/^\s*'\s*Version[\s:]+([\d\.]+)\s*$/im")
        If rxV.test(moduleHdr) Then vNr = rxV.execute(moduleHdr)(0).subMatches(0)
    End If
    versionNr = vNr
End Property
 
'/**
' * Versionsdatum der Klasse/Modul
' * @return Date
' */
Public Property Get versionDate() As Date
    Static vDate As Date
    If vDate = 0 Then
        '               05.04.2016 - ERS - Beim instanceByTableText ergänzt, dass wenn die Spaltennamen Nummern sind diese mit dem Prefix FIELD_ versehen werden
        Dim rxD As Object:              Set rxD = cRx("/^\s*'\s*(\d{2})\.(\d{2})\.(\d{4}).*$/img")
        If rxD.test(moduleHdr) Then
            Dim matches As Object:  Set matches = rxD.execute(moduleHdr)
            Dim parts As Object:    Set parts = matches(matches.count - 1).subMatches
            vDate = DateSerial(parts(2), parts(1), parts(0))
        End If
    End If
    versionDate = vDate
End Property