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 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> '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 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 Type vom Objekt ' * @param Name des geushcten Objektes ' * @retrun ' * @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 => 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 => 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 ' */ 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