„compose.vbs“ hinzufügen

compose.vbs

@@ -0,0 +1,149 @@
+' Usage:
+'  cscript compose.vbs <file> <path>
+
+' Reads all modules, classes, forms, macros, queries, tables and their relationships in a directory created by "decompose.vbs"
+' and composes then into an Access Database file (.accdb).
+' Requires Microsoft Access.
+Option Explicit
+
+Const acForm = 2
+Const acModule = 5
+Const acMacro = 4
+Const acReport = 3
+Const acQuery = 1
+Const acStructureOnly = 0   'change 0 to 1 if you want import StructureAndData instead of StructureOnly
+Const acCmdCompileAndSaveAllModules = &H7E
+
+Dim fso, relDoc, ACCDBFilename, sPath
+Set fso = CreateObject("Scripting.FileSystemObject")
+Set relDoc = CreateObject("Microsoft.XMLDOM")
+
+If (Wscript.Arguments.Count = 0) Then
+ MsgBox "Please provide the .accdb database file", vbExclamation, "Error"
+ Wscript.Quit()
+End If
+
+ACCDBFilename = fso.GetAbsolutePathName(Wscript.Arguments(0))
+If (Wscript.Arguments.Count = 1) Then
+ sPath = ""
+Else
+ sPath = Wscript.Arguments(1)
+End If
+
+
+importModulesTxt ACCDBFilename, sPath
+
+If (Err <> 0) And (Err.Description <> Null) Then
+    MsgBox Err.Description, vbExclamation, "Error"
+    Err.Clear
+End If
+
+
+Function importModulesTxt(ACCDBFilename, sImportpath)
+    Dim myComponent, sModuleType, sTempname, sOutstring
+
+    ' Build file and pathnames
+    Dim myType, myName, myPath
+    myType = fso.GetExtensionName(ACCDBFilename)
+    myName = fso.GetBaseName(ACCDBFilename)
+    myPath = fso.GetParentFolderName(ACCDBFilename)
+
+    ' if no path was given as argument, use a relative directory
+    If (sImportpath = "") Then
+        sImportpath = myPath & "\Source\"
+    End If
+
+    ' check for existing file and ask to overwrite with the stub
+    If fso.FileExists(ACCDBFilename) Then
+     Wscript.StdOut.Write ACCDBFilename & " already exists. Overwrite? (y/n) "
+     Dim sInput
+     sInput = Wscript.StdIn.Read(1)
+     If (sInput <> "y") Then
+      Wscript.Quit
+     Else
+      If fso.FileExists(ACCDBFilename & ".bak") Then
+       fso.DeleteFile (ACCDBFilename & ".bak")
+      End If
+      fso.MoveFile ACCDBFilename, ACCDBFilename & ".bak"
+     End If
+    End If
+
+    Wscript.Echo "starting Access..."
+    Dim oApplication
+    Set oApplication = CreateObject("Access.Application")
+    Wscript.Echo "Opening " & ACCDBFilename
+    If (Right(ACCDBFilename, 4) = ".adp") Then
+        oApplication.CreateAccessProject ACCDBFilename
+    Else
+        oApplication.NewCurrentDatabase ACCDBFilename
+    End If
+    oApplication.Visible = False
+
+    Dim folder
+    Set folder = fso.GetFolder(sImportpath)
+
+    'load each file from the import path into the stub
+    Dim myFile, objectname, objecttype
+    For Each myFile In folder.Files
+     objectname = fso.GetBaseName(myFile.Name)  'get rid of .txt extension
+     objecttype = fso.GetExtensionName(objectname)
+     objectname = fso.GetBaseName(objectname)
+
+     Select Case objecttype
+      Case "form"
+       Wscript.Echo "Importing FORM from file " & myFile.Name
+       oApplication.LoadFromText acForm, objectname, myFile.Path
+      Case "module"
+       Wscript.Echo "Importing MODULE from file " & myFile.Name
+       oApplication.LoadFromText acModule, objectname, myFile.Path
+      Case "macro"
+       Wscript.Echo "Importing MACRO from file " & myFile.Name
+       oApplication.LoadFromText acMacro, objectname, myFile.Path
+      Case "report"
+       Wscript.Echo "Importing REPORT from file " & myFile.Name
+       oApplication.LoadFromText acReport, objectname, myFile.Path
+      Case "query"
+       Wscript.Echo "Importing QUERY from file " & myFile.Name
+       oApplication.LoadFromText acQuery, objectname, myFile.Path
+      Case "table"
+       Wscript.Echo "Importing TABLE from file " & myFile.Name
+       oApplication.ImportXml myFile.Path, acStructureOnly
+      Case "rel"
+       Wscript.Echo "Found RELATIONSHIPS file " & myFile.Name & " ... opening, it will be processed after everything else has been imported"
+       relDoc.Load (myFile.Path)
+     End Select
+    Next
+
+    If relDoc.readyState Then
+     Wscript.Echo "Preparing to build table dependencies..."
+     Dim xmlRel, xmlField, accessRel, relTable, relName, relFTable, relAttr, i
+     For Each xmlRel In relDoc.SelectNodes("/Relations/Relation")   'loop through every Relation node inside .xml file
+      relName = xmlRel.SelectSingleNode("Name").Text
+      relTable = xmlRel.SelectSingleNode("Table").Text
+      relFTable = xmlRel.SelectSingleNode("ForeignTable").Text
+      relAttr = xmlRel.SelectSingleNode("Attributes").Text
+
+      'remove any possible conflicting relations or indexes
+      On Error Resume Next
+      oApplication.CurrentDb.Relations.Delete (relName)
+      oApplication.CurrentDb.TableDefs(relTable).Indexes.Delete (relName)
+      oApplication.CurrentDb.TableDefs(relFTable).Indexes.Delete (relName)
+      On Error GoTo 0
+
+      Wscript.Echo "Creating relation " & relName & " between tables " & relTable & " -> " & relFTable
+      Set accessRel = oApplication.CurrentDb.CreateRelation(relName, relTable, relFTable, relAttr)  'create the relationship object
+
+      For Each xmlField In xmlRel.SelectNodes("Field")  'in case the relationship works with more fields
+       accessRel.Fields.Append accessRel.CreateField(xmlField.SelectSingleNode("Name").Text)
+       accessRel.Fields(xmlField.SelectSingleNode("Name").Text).ForeignName = xmlField.SelectSingleNode("ForeignName").Text
+       Wscript.Echo "  Involving fields " & xmlField.SelectSingleNode("Name").Text & " -> " & xmlField.SelectSingleNode("ForeignName").Text
+      Next
+
+      oApplication.CurrentDb.Relations.Append accessRel 'append the newly created relationship to the database
+      Wscript.Echo "  Relationship added"
+     Next
+    End If
+
+    oApplication.RunCommand acCmdCompileAndSaveAllModules
+    oApplication.Quit
+End Function