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