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¹⁾-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.

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.

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.

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

test.sql

-- 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.

Fehlermeldungen kommen jeweils zu den einzelnen Views, in der Zusammenfassung sieht man dann nochmals welche View nicht importiert werden konnte.

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.

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.

Type um die Error-Eigenschaften weiterzureichen. Die einzelnen Elemente entsprechen den Eigenschaften des ErrObject aus VBA.

Der Enumerator enuDdlAction beschreibt die verschiedenen DDL-Aktionen.

Auswahl der Parameters die von Aussen verstellbar sind

Statische Funktion importAndRunDdlFile der DdlFileImporter Klasse. Ich verwende sie für den Aufruf über das Makro AutoKeys.

DdlFileImporterModul.bas

'-------------------------------------------------------------------------------
'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

Und die Klasse dazu. die Beschreibung der Funktionen ist im Code selber

DdlFileImporter.cls

'-------------------------------------------------------------------------------
'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 = "<semicolon>"
 
'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<ddlScript>    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))
                '<semicolon> 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<ddlScripts>
' * @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<ddlScript>
' */
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  <AcObjectType>      Type vom Objekt
' * @param  <String>            Name des gesuchten Objektes
' * @retrun <Boolean>
' * @example    If ObjectExists(acQuery, "vw_temp") then CurrentDb.QueryDefs.Delete("vw_temp")
' */
Private Function objectExists(ByVal iObjectType As AcObjectType, ByVal iObjectName As String) As Boolean
    Dim dummy As Variant
On Error Resume Next
 
    'Je nach Type unterschiedlich prüfen
    Select Case iObjectType
        Case acTable:       Set dummy = CurrentDb.TableDefs(iObjectName)
        Case acQuery:       Set dummy = CurrentDb.QueryDefs(iObjectName)
        Case acForm:        Set dummy = 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<ddlScript>
' */
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