~~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}}