From 81e2a65382497af23fef2ad7fc5b1ea1a474e4c2 Mon Sep 17 00:00:00 2001 From: Lukas Ziegler Date: Sat, 6 Mar 2021 13:28:18 +0000 Subject: [PATCH] =?UTF-8?q?=E2=80=9Ecompose.vbs=E2=80=9C=20hinzuf=C3=BCgen?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- compose.vbs | 149 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 149 insertions(+) create mode 100644 compose.vbs diff --git a/compose.vbs b/compose.vbs new file mode 100644 index 0000000..9aa8a66 --- /dev/null +++ b/compose.vbs @@ -0,0 +1,149 @@ +' Usage: +' cscript compose.vbs + +' 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 \ No newline at end of file