~~DISCUSSION~~ ====== [VBA][Access] Klasse DdlFileImporter ====== Ms Access hat ein Query-Designer. Der ist nett und niedlich um einfache Abfragen zusammenzuklicken. Leider ein wenig zu viel Klicki-Bunti. Bei komplexeren Abfragen wird es sehr schnell unübersichtlich. Wenn man Formeln hat muss man dauernd von Lanks nach Rechts scrollen, in die Felder Klicken und mittels rechter Mausraste die Formal im Zoom-Fenster anschauen. Formatiert ist dort gar nix, was das lesen bei komplexeren Formeln fast verunmöglicht. Auch die SQL-Ansischt zeigt sich wie ein Klotz. Keine Formatierung möglich (oder wenn, wird sie mit dem Schliessen der Abfrage wieder verworfen). Als weitere Schwierigkeit kommt dazu, dass man schnell mehrere Abfragen für eine einzige Ausgabe hat. Zusätzlich kennt MS Access die DDL((Data Definition Language))-Befehle CREATE OR REPLACE VIEW nicht. So konnte und so wollte ich nicht arbeiten. Also überlegte ich mir, die Abfragen auszulagern. Zuerst kopierte ich jeweils die Formatierten SQL-Strings in die SQL-Ansicht der Abfrage. Aber dies hat keine Zukunft. Darum erstellt ich mir ein DDL-Loader. ===== Anforderungen ===== Die folgenden Anforderungen stellte ich mir *Ich will meine SQL-Statements in Text-Dateien speichern und mit externen Editoren (zb Sublime Text) bearbeiten. *In einer Datei sollen alle Abfragen gespeichert sein, die zusammengehören. *Es muss möglich sein mittels -- Zeilen auszukommentieren. *Der Import muss einfach sein. Datei auswählen und fertig. *Ggf später erweitern um CREATE/ALTER TABLE, INSERT VALUES etc. Aus dieser Anforderung entstand meine Klasse DdlFileImporter mit dem dazugehörigen Modul DdlFileImporterModul. ===== Anwendung ===== Die einfachste Anwendung ist, die folgende. Ich erstellte ein Makro **AutoKeys** um Tastatur-Kürzel mit einer Funktion zu hinterlegen. In dem Fall nehme **CTRL+SHIFT+L** für Load. ^ Macro Name ^ Action ^ Argument ^ | ^+l | runCode | importAndRunDdlFile () | Auf meinem PC erstelle ich eine SQL-Datei mit CREATE OR REPLACE VIEW...; Statements drin. Wie bei allen DBMS muss auch hier jedes Statement mit einem ; geschlossen werden -- Tesquery 1 CREATE OR REPLACE VIEW vw_test_basis AS SELECT t.id, -- Mit unterscheidung nach code IIF( t.code = 'alpha', t.value_1, t.value_2 ) AS my_value FROM my_table AS t ; -- Testquery 2. Mitt Parameter CREATE OR REPLACE VIEW vw_test AS -- Da der ; am Ende vom Parameter nicht die View schliessen sollte, ist er mit einem \ markiert PARAMETERS P_MIN_VALUE Text ( 255 )\; SELECT basis.* FROM vw_test_basis AS basis WHERE basis.my_value > [P_MIN_VALUE] ; Wenn ich jetzt irgendwo im MS Access die Tastenkombination CTRL+SHIFT+L drücke, öffnet sich ein Dateiauswahlfenster. Ich wähle meine SQL-Datei aus und die Datei wird verarbeitet. Am Schluss bekomme ich eine Benachrichtigung als Popup mit der Angabe welche Views erstellt/ersetzt wurden. {{ :ddlimport_1.png }} Fehlermeldungen kommen jeweils zu den einzelnen Views, in der Zusammenfassung sieht man dann nochmals welche View nicht importiert werden konnte. ====== Klasse/Modul ====== ===== Modul DdlFileImporterModul ===== Wieder eine dieser Unzgänglichkeiten von VBA unter MS Access. Man keine keine Typen als Public in einer Klasse hinterlegen. Ergo muss neben der Klasse noch ein Modul hinzu. Dafür kann ich auch gleich die Funktion importAndRunDdlFile() darin ablegen, die ich für das AutoKeys-Makro verwende. ==== Definitionen ==== === Datentypen === == ddlScript == Der Datentyp ddlScript beschtreibt ein einzelnes SQL-Statement inkl Angaben über Errors etc. Die genaue Beschreibung der einzelnen Felder sind ist im Code. Dieser Typ wird zur Komunikation innherhalb der Klasse verwendet. Als Array von diesem Typ kommt aber auch der Rückgabewerte einiger Methoden vor, so dass man das Resultat auch aussserhalb weiterverarbeiten kann. == ddlError == Type um die Error-Eigenschaften weiterzureichen. Die einzelnen Elemente entsprechen den Eigenschaften des ErrObject aus VBA. === Enumeratoren === == enuDdlAction == Der Enumerator enuDdlAction beschreibt die verschiedenen DDL-Aktionen. == enuDdlParam == Auswahl der Parameters die von Aussen verstellbar sind === Methodes === == importAndRunDdlFile() == Statische Funktion importAndRunDdlFile der DdlFileImporter Klasse. Ich verwende sie für den Aufruf über das Makro AutoKeys. '------------------------------------------------------------------------------- 'File : DdlFileImporterModul ' Copyright mpl by ERB software ' All rights reserved ' http://wiki.yaslaw.info/wikka/vbaPrintF 'Environment : VBA 2007 + 'Version : 1.0 'Name : Modul zur Klasse DdlFileImporter 'Author : Stefan Erb (ERS) 'History : 16.10.2013 - ERS - Creation ' 'References : Microsoft VBScript Regular Expressions 5.5 ' Microsoft Scripting Runtime ' 'Description : Leider ist es nicht möglich Enum und Type als Public in einer Klasse zu speichern. ' Darum ist dies das Modul mit den Definitionen zr Klasse DdlFileImporter '------------------------------------------------------------------------------- Option Explicit Option Compare Database '------------------------------------------------------------------------------- ' Public Members '------------------------------------------------------------------------------- '/** ' * Auswahl der verschiedenen DDL-Aktionen ' */ Public Enum enuDdlAction ddlaCreate = 0 ddlaReplace ddlaAlter ddlaDelete End Enum '/** ' * Auswahl der versch. überschreibbaren Parameters. Siehe Methoden setParam() und getParam() ' */ Public Enum enuDdlParam ddlpViewNamePos 'Position (Index) des Viewnames im Pattern für die Regexp. Default: 0 ddlpViewSqlPos 'Position (Index) des SQL-Scripts im Pattern für die Regexp. Default: 1 End Enum '/** ' * Type um die Error-Eigenschaften weiterzureichen. Siehe Beschreibung des ErrObjects ' */ Public Type ddlError number As Long description As String source As String helpFile As String helpContext As String End Type '/** ' * Type mit allen Information über ein DDL-Script ' */ Public Type ddlScript offset As Long 'Ab dieser Zeichennummer beginnt das Script in der Datei objectName As String 'Name des Objektes (der View/Tabelle) acType As AcObjectType 'Typ des Objektes. acQuery/acTable action As enuDdlAction 'Aktion des Scripts sql As String 'Das SQL-Statement. Im Falle einer View nur der SELECT-Teil withError As Boolean 'Flag ob ein Fehler aufgetretten ist error As ddlError 'Die Information über ev. Fehler fileName As String 'Name der Datei filePath As String 'Pfad der Datei End Type '/** ' * Statische Funktion importAndRunDdlFile der DdlFileImporter Klasse. ' * Eigentlich währe es eine Sub. Doch um sie in das Autokey-Makro einzubinden muss es eine Funktion sein ' * (Wie hirnrissig. Genau für ausführungen ohen Rückgabewert sind Subs vorgesehen....) ' * @param String Pfad in dem das Dialogfesnter beginnt. Standart: MS Access DB Pfad ' */ Private staticDdlFileImporter As DdlFileImporter Public Function importAndRunDdlFile(Optional ByVal iFolderPath As Variant = Null) If staticDdlFileImporter Is Nothing Then Set staticDdlFileImporter = New DdlFileImporter Call staticDdlFileImporter.importAndRunDdlFile(iFolderPath) End Function ===== Klasse DdlFileImporter ===== Und die Klasse dazu. die Beschreibung der Funktionen ist im Code selber '------------------------------------------------------------------------------- 'File : DdlFileImporter ' Copyright mpl by ERB software ' All rights reserved ' http://wiki.yaslaw.info/dokuwiki/DdlFileImporter 'Environment : VBA 2007 + 'Version : 1.1 'Name : DdlFileImporter 'Author : Stefan Erb (ERS) 'History : 16.10.2013 - ERS - Creation ' : 04.11.2013 - ERS - ; parsen hinzugefügt ' 'References : Microsoft VBScript Regular Expressions 5.5 ' Microsoft Scripting Runtime ' 'Description : Verarbeitung von DDL-Komandos (zb. CREATE OR REPLACE VIEW xy AS select...) ' aus Dateien '------------------------------------------------------------------------------- Option Explicit Option Compare Database 'Pattern um Kommentarzeilen zu entfernen Private Const C_SQL_COMMENT_PATTERN As String = "^(\s*(--|#).*)$" 'Pattern für CREAT OR REPLACE VIEW Private Const C_DDL_VIEW_PATTERN As String = "CREATE\s+OR\s+REPLACE\s+VIEW\s+(\S+)\s+AS\s+([^;]+);" Private Const C_SEMICOLON_PATTERN As String = "\;" Private Const C_SEMICOLON_PLACEHOLDERS As String = "" 'Wird verwendet um herauszufinden ob ein Array bereits Dimensioniert ist Private Declare Sub GetSafeArrayPointer Lib "msvbvm60.dll" Alias "GetMem4" (pArray() As Any, sfaPtr As Long) '------------------------------------------------------------------------------- ' Public Members '------------------------------------------------------------------------------- 'Die Enums und Types sind im Modul DdlFileImporterModul definiert '/** ' * RegExp die verwendet werden. Diese können von aussen angepasst werden um eigene Formate zu parsen ' * Mit der Methode resetToDefault() werden sie wieder auf den Standart der Klasse zurückgesetzt ' */ '/** ' * RegExp umd ie Kommentarzeilen zu entfernen ' */ Public sqlCommentRegExp As New regexp '/** ' * RegExp um die Views zu erkennen. Der erste Treffer ist der Objektname, der Zwiete das Script selber ' */ Public ddlViewRegExp As New regexp Private Params As Dictionary '------------------------------------------------------------------------------- ' Public Methodes '------------------------------------------------------------------------------- '/** ' * Setzt alle Patterns zurück ' */ Public Function resetToDefault() Set Params = New Dictionary 'Den Kommentar-Parser initialisieren sqlCommentRegExp.Multiline = True sqlCommentRegExp.IgnoreCase = True sqlCommentRegExp.Global = True sqlCommentRegExp.pattern = C_SQL_COMMENT_PATTERN 'Den View-Parser initialisieren ddlViewRegExp.Multiline = False ddlViewRegExp.IgnoreCase = True ddlViewRegExp.Global = True ddlViewRegExp.pattern = C_DDL_VIEW_PATTERN 'Die Parameter dazu Call Params.add(ddlpViewNamePos, 0) Call Params.add(ddlpViewSqlPos, 1) End Function '/** ' * ÜBerschreibt ein Parameter. Genaueres zu den einzelnen Parameter ist bei der ' * Beschreibung zu enuDdlParam. ' * @param enuDdlParam Parameter der überschrieben werden soll ' * @param Variant Neuer Wert ' */ Public Sub setParam(ByVal iParam As enuDdlParam, ByVal iValue As Variant) Params(iParam) = iValue End Sub '/** ' * Gibt den Wert eines Parameters zurück ' * @param enuDdlParam Parameter der ausgegeben werden soll ' * @return Variant Aktueller Wert des Parameters ' */ Public Function getParam(ByVal iParam As enuDdlParam) As Variant getParam = Params(iParam) End Function '/** ' * Liest ein SQL/DDL File ein ' * @param String Pfad in dem das Dialogfesnter beginnt. Standart: MS Access DB Pfad ' */ Public Sub importAndRunDdlFile(Optional ByVal iFolderPath As Variant = Null) Dim ddlPath As Variant Dim oFileDialog As FileDialog Dim installedViews() As ddlScript Dim FSO As New FileSystemObject Dim i As Integer Dim msg As String If IsNull(iFolderPath) Then iFolderPath = CurrentProject.path 'http://www.0711office.de/vba/FileDialog/default.htm Set oFileDialog = Application.FileDialog(msoFileDialogFilePicker) With oFileDialog .title = "Select SQL File" .ButtonName = "Import" .AllowMultiSelect = True .InitialView = msoFileDialogViewDetails 'Filter setzen .filterS.Clear .filterS.add "SQL File", "*.sql", 1 .filterS.add "DDL File", "*.ddl", 2 .filterS.add "TXT File", "*.txt", 3 .filterS.add "Alles", "*.*", 4 .FilterIndex = 1 .InitialFileName = iFolderPath If .show = True Then For Each ddlPath In .SelectedItems 'Verarbeitung starten und ausgeben Call parseDdlFile(CStr(ddlPath)) Next End If End With Set oFileDialog = Nothing Set FSO = Nothing End Sub '/** ' * Führt ein DDL-File aus ' * @param String Pfad der Sql-Datei ' * @param Boolean True: Die DLL werden ausgeführt. False: Es werden nur die Namen ausgelesen und zurückgegeben ' * @param Boolean True: Neue View ungefragt erstellen ' * @return Array Ein Array mit ddlScriptTypen in dme alle Informationen über ide einzelnen Objekte enthalten sind ' */ Public Function parseDdlFile( _ ByVal iPath As String, _ Optional ByVal iExecute As Boolean = True, _ Optional ByVal iForce As Boolean = False, _ Optional ByVal ishowResult As Boolean = True _ ) As ddlScript() Dim FSO As New FileSystemObject Dim mc As MatchCollection Dim txt As String Dim i As Integer Dim dSc As ddlScript Dim scripts() As ddlScript On Error GoTo Err_Handler 'Kommentar RegExp initialisieren 'Alles einlesen und Kommentare entfernen txt = sqlCommentRegExp.replace(FSO.OpenTextFile(iPath, ForReading).ReadAll, "") 'Markierte ; ersetzen \; ersetzen txt = replace(txt, C_SEMICOLON_PATTERN, C_SEMICOLON_PLACEHOLDERS) '=== QUERYDEF === 'Prüfen ob überhaubt Views enthalten sind If ddlViewRegExp.test(txt) Then 'Alle Treffer auslesen Set mc = ddlViewRegExp.execute(txt) For i = 0 To mc.count - 1 With dSc .acType = acQuery .objectName = mc(i).SubMatches(Params(ddlpViewNamePos)) .sql = mc(i).SubMatches(Params(ddlpViewSqlPos)) ' wieder in ein ; wandeln .sql = replace(.sql, C_SEMICOLON_PLACEHOLDERS, ";") .offset = mc(i).FirstIndex .filePath = iPath .fileName = FSO.getFileName(iPath) If haveScripts(scripts) Then ReDim Preserve scripts(UBound(scripts) + 1): scripts(UBound(scripts)) = dSc Else ReDim scripts(0): scripts(0) = dSc End If End With Next End If '//TODO CREATE TABLE, ALTER TABLE, CREATE INDEX etc. If haveScripts(scripts) Then 'Die Scrippte nach offset sortieren. Das ist im Moment eigentlich noch nicht nötig. 'Sobald aber weitere DDL-Befehle abgedeckt sind, werden so die Scripte wieder in die 'Originalreiehenfolge gesetz Call sortScriptsByOffset(scripts) 'Die DDL-Scripte in der Richtigen Reihenfolge abarbeiten If iExecute Then For i = 0 To UBound(scripts) With scripts(i) Select Case .acType Case acQuery: Call createOrReplaceView(scripts(i)) End Select 'Im Fehlerfall den Fehler ausgeben If .withError Then Call showError(scripts(i)) End With Next End If If ishowResult And iExecute Then Call showResult(scripts) ElseIf ishowResult And iExecute Then Call MsgBox("No Scripts imported", vbOKOnly + vbInformation, "DDL Import") End If Exit_Handler: parseDdlFile = scripts Set mc = Nothing Set FSO = Nothing Exit Function Err_Handler: Call Err.Raise(Err.number, "parseDdlFile" & Err.Source, Err.description, Err.helpFile, Err.helpContext) GoTo Exit_Handler Resume End Function '------------------------------------------------------------------------------- ' Private Methodes '------------------------------------------------------------------------------- '/** ' * Berprüft ob ein Array von ddlScripts Einträge hat oder nicht ' * @param Array ' * @return Boolean ' */ Private Function haveScripts(ByRef scripts() As ddlScript) As Boolean Dim sfaPtr As Long Call GetSafeArrayPointer(scripts(), sfaPtr) haveScripts = (sfaPtr > 0) End Function '/** ' * CREATE OR REPLACE VIEW ' * @param ddlScript Referenz auf ein ddlScript-Type mit allen Angaben die man so braucht ' * @param Boolean True: Neue View ungefragt erstellen ' * @return Boolean Erfolg/Misserfolg ' */ Private Function createOrReplaceView(ByRef ddlS As ddlScript, Optional ByVal iForce As Boolean = False) As Boolean On Error GoTo Err_Handler If Not objectExists(acQuery, ddlS.objectName) Then 'View neu erstellen ddlS.action = enuDdlAction.ddlaCreate If iForce Then Call CurrentDb.CreateQueryDef(ddlS.objectName, ddlS.sql) ElseIf MsgBox("Query " & ddlS.objectName & " erstellen?", vbYesNo + vbQuestion) = vbYes Then Call CurrentDb.CreateQueryDef(ddlS.objectName, ddlS.sql) End If Else 'View ersetzen ddlS.action = ddlaReplace CurrentDb.QueryDefs(ddlS.objectName).sql = ddlS.sql End If createOrReplaceView = True Exit_Handler: Exit Function Err_Handler: createOrReplaceView = False ddlS.error = raiseDdlError(Err) ddlS.withError = True Err.Clear GoTo Exit_Handler End Function '/** ' * Speichert die Error-Informationen bevor Err durch VBA zurückgesetzt wird ' * @param ErrObject Das Error-Objekt ' * @return ddlError Ein ddlError-Type ' */ Private Function raiseDdlError(ByRef iErr As ErrObject) As ddlError raiseDdlError.number = iErr.number raiseDdlError.description = iErr.description raiseDdlError.Source = iErr.Source raiseDdlError.helpFile = iErr.helpFile raiseDdlError.helpContext = iErr.helpContext End Function '/** ' * erstellt eine Message-Box mit den Infromationen über das File und dessen Scripte ' * @param Array ' */ Public Sub showResult(ByRef iScripts() As ddlScript) Dim i As Integer Dim msg As String If haveScripts(iScripts) Then msg = "File processed" & vbCrLf For i = LBound(iScripts) To UBound(iScripts) With iScripts(i) msg = msg & vbCrLf & _ IIf(.withError, "Not ", vbNullString) & _ Choose(.action + 1, "Create", "Replace", "Alter", "Delete") & _ Choose(.acType + 1, " Table", " View") & _ " [" & .objectName & "] " & _ IIf(.withError, " (Error: " & .error.number & ")", vbNullString) End With Next i 'Auswerten und Rückmeldung Call MsgBox( _ Prompt:=Trim(msg), _ Buttons:=vbOKOnly + vbInformation, _ title:="DDL Import: " & iScripts(0).fileName _ ) Else Call MsgBox("No Scripts imported", vbOKOnly + vbInformation, "DDL Import") End If End Sub '/** ' * Gibt eine Fehlermeldung aufgrund des ddlError am Bildschirm aus ' * @param ddlScript ' */ Public Sub showError(ByRef iScript As ddlScript) With iScript Call MsgBox( _ Prompt:="Error on " & .objectName & " [" & .error.number & "]" & vbCrLf & .error.description, _ Buttons:=vbOKOnly + vbCritical, _ title:=.objectName, _ helpFile:=.error.helpFile, _ Context:=.error.helpContext) End With End Sub '------------------------------------------------------------------------------- ' Private Helper Methodes '------------------------------------------------------------------------------- '/** ' * Prüft ob ein bestimmtest Access-Objekt existiert ' * @param Type vom Objekt ' * @param Name des gesuchten 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 = CurrentProject.AllForms(iObjectName) Case acReport: Set dummy = CurrentProject.AllReports(iObjectName) Case acModule: Set dummy = CurrentProject.AllModules(iObjectName) Case acMacro: Set dummy = CurrentProject.AllMacros(iObjectName) 'Bei anderen Objekttypen False ausgeben: Case Else: Err.Raise (-1) End Select 'Wenn kein Fehler aufgetretten ist, exisitert das Objekt objectExists = (Err.number = 0) Err.Clear Call dummy.Close Set dummy = Nothing End Function '/** ' * Sortiert ein Array von ddlScripts nach dem Offset. Also in der Reihenfolge wie sie in ' * der Datei stehen ' * Insperiert durch: http://www.vbarchiv.net/archiv/tipp_details.php?pid=372 ' * @param Array ' */ Private Sub sortScriptsByOffset(ByRef ioScripts() As ddlScript, _ Optional ByVal iStart As Variant, _ Optional ByVal iEnd As Variant) ' Wird die Bereichsgrenze nicht angegeben, ' so wird das gesamte Array sortiert If IsMissing(iStart) Then iStart = LBound(ioScripts) If IsMissing(iEnd) Then iEnd = UBound(ioScripts) Dim i As Long Dim j As Long Dim h As Variant Dim x As Variant Dim aStart As Integer Dim aEnd As Integer i = iStart: j = iEnd x = ioScripts((iStart + iEnd) / 2).offset ' Array aufteilen Do While (ioScripts(i).offset < x): i = i + 1: Wend While (ioScripts(j).offset > x): j = j - 1: Wend If (i <= j) Then ' Wertepaare miteinander tauschen h = ioScripts(i).offset ioScripts(i).offset = ioScripts(j).offset ioScripts(j).offset = h i = i + 1: j = j - 1 End If Loop Until (i > j) ' Rekursion (Funktion ruft sich selbst auf) If (iStart < j) Then sortScriptsByOffset ioScripts, iStart, j If (i < iEnd) Then sortScriptsByOffset ioScripts, i, iEnd End Sub '/** ' * Initialisierung ' */ Private Sub Class_Initialize() Call resetToDefault End Sub Private Sub Class_Terminate() Set Params = Nothing End Sub {{tag>VBA MS_Access Library}}