Deutsch
Nachdem ich jahrelang Zeit verbraucht habe, mit rechten Mausklicks Module für BackUp-Zwecke zu exportieren und neue oder geänderte Module zu importieren, habe ich vor einiger Zeit Code geschrieben, womit ich das automatisiere. Ich habe den Code jetzt etwas abgewandelt, da UserForms nicht als Plaintext bereitgestellt werden können. Hier ist der Code, der die Auswahlmöglichkeit bietet
- Alle Module eines ausgewählten Projekts in einen Ordner zu exportieren
- Alle Module eines ausgewählten Projekts in einen Unterordner zu exportieren und alle Module aus dem darüberliegenden Ordner zu importieren. Eventuell bereits vorhandene Module werden bei Bedarf zuvor entfernt
- Nur die Module eine ausgewählten Projekts in einen Unterordner zu exportieren, die im darüberliegenden Ordner zum Import bereitstehen.
Beim Start erscheint erst eine Auswahlmöglichkeit für die Aktion.
Im nächsten Schritt kann ausgewählt werden, die Module welchen Projekts exportiert oder aktualisiert werden sollen
Wenn eine Aktualisierung von Modulen durchgeführt werden soll, darf der untenstehende Code nicht im Zielprojekt liegen. Die Liste der möglichen Zielprojekte enthält in diesem Fall einen Hinweis.
Wird das Projekt trotzdem ausgewählt, kommt es zu einem Abbruch.
Die letzte Eingabe erfordert die Auswahl des Ordners.
Für den Export wird im ausgewählten Ordner ein neuer Ordner mit “BackUp”, Zeitstempel und Zielprojekt im Namen erstellt.
Im Direktbereich wird die erfolgte Aktivität angezeigt.
Der Import einer Datei ThisProject.cls wird gesondert behandelt, Kommentare dazu sind im Code.
Ein wichtiger Hinweis zum Testen (ich übernehme keine Garantie bei Fehlfunktion, beantworte aber gerne Fragen dazu:
Verwenden Sie nicht Global.MPT als Zielprojekt beim Testen. Das ist das einzige Projekt, das Änderungen an Modulen auch ohne explizites Speichern übernimmt.
In Makros implementieren / Implement Macros wird beschrieben, wie ein Makro in Project übernommen werden kann. Mehr Beispielmakros sind unter VBA zu finden.
English
After spending years of exporting modules for back-up purposes and importing new or modified modules with right mouse clicks, I wrote code some time ago, which I use to automate this. I have modified the code a bit now, since UserForms cannot be provided as plain text. Here is the code that gives the choice to
1. export all modules of a selected project to a folder
2. export all modules of a selected project into a subfolder and import all modules from the folder above. Any existing modules will be removed beforehand if necessary
3.only export the modules of a selected project to a subfolder that are available for import in the folder above.
At the start, a selection option for the action appears.
In the next step you can choose which modules of which project should be exported or updated
If modules are to be updated, the code below must not be in the target project. In this case, the list of possible target projects contains a note.
If the project is selected anyway, it will be canceled.
The last entry requires the selection of the folder.
For export, a new folder with “BackUp”, time stamp and target project in the name is created in the selected folder.
The activity that has taken place is displayed in the direct area.
The import of a ThisProject.cls file is handled separately, comments are in the code.
An important note for testing (I do not guarantee malfunction, but will be happy to answer questions):
Do not use Global.MPT as target project when testing. This is the only project that takes over changes of modules without explicit saving.
Implementing Macros / Implement Macros describes how to apply a macro to Project. More sample code is available at VBA.
Code
Sub BackupImportModules()'***********************************************************************************'Code is provided “AS IS” without warranty of any kind, either expressed or implied,'including but not limited to the implied warranties of merchantability and/or'fitness for a particular purpose.'***********************************************************************************Dim P As ProjectDim VBC AsVariant'VBComponentsDim VBP AsVariant'VBProjectDim v_Type AsDoubleDim v_FolderName AsStringDim v_BackupFolderName AsStringDim v_FileName AsStringDim v_Skip AsBooleanDim v_FileExtension AsStringDim v_ThisProject AsVariantDim v_ThisProjectName AsStringDim v_String AsStringDim W AsObjectDim v_Options AsVariantReDim arr_Filename(50) AsStringReDim arr_Projects(1 To 1000) AsVariantDim i AsInteger'We need debug window for loggingForEach W In Application.VBE.WindowsIf W.Type = vbext_wt_Immediate Then W.Visible = True W.WindowState = vbext_ws_NormalEndIfNext W'separate old debug messages from current run Debug.Print "*******************************************************" Debug.Print "*** "& Application.VBE.SelectedVBComponent.Name & " started at "& Date& " "& Time & " ***"'Enable Excel as reference since there is no "FileDialog(msoFileDialogFolderPicker)" in Project object modelCall EnableReferences("{00020813-0000-0000-C000-000000000046}") '{00020813-0000-0000-C000-000000000046} for Excel'1 - Export only'2 - Export all modules and import/replace existing ones from specified folder'3 - Export only modules existing in specified folder and import/replace them v_Options = InputBox("1 - Export all modules" + _ vbCrLf + "2 - Export all modules and import from folder" + _ vbCrLf + "3 - Export only modules from folder and import these", _"Please Select Option 1/2/3", "1")'catch input for import and export optionsIf v_Options = ""Then MsgBox "Macro cancelled."ExitSub End IfIf IsNumeric(v_Options) Then v_Options = CInt(v_Options)If v_Options < 1 Or v_Options > 3 Then MsgBox "Invalid input. Macro will be terminated"ExitSub End IfElse MsgBox "Invalid input. Macro will be terminated"ExitSub End IfFor i = 1 To Application.VBE.VBProjects.CountSet VBP = Application.VBE.VBProjects(i)'Names of VBProjects are not unique'Use project name for VBProjects in a projectForEach P In Application.ProjectsIf P.VBProject Is VBP Then arr_Projects(i) = P.NameEndIfNext P'VBProjects not within a project have a filenameIf arr_Projects(i) = ""Then arr_Filename = Split(VBP.FileName, "\") arr_Projects(i) = arr_Filename(UBound(arr_Filename))EndIf'We can't change modules in current VBProject. We can use this project for export onlyIf VBP Is Application.VBE.ActiveVBProject And v_Options <> 1 Then arr_Projects(i) = "DO NOT SELECT " + arr_Projects(i)EndIf v_String = v_String & i & " - "& arr_Projects(i) & vbCrLfNext iReDim Preserve arr_Projects(1 To i - 1) v_ThisProject = InputBox("Please enter number of target project"& vbCrLf & v_String, "Target Project Selection")'catch input for project selectionIf v_ThisProject = ""Then MsgBox "No project selected. Macro will be terminated"ExitSub End IfIf IsNumeric(v_ThisProject) Then v_ThisProject = CInt(v_ThisProject)If v_ThisProject < 1 Or v_ThisProject > UBound(arr_Projects) Then MsgBox "Invalid input. Macro will be terminated"ExitSub End IfElse MsgBox "Invalid input. Macro will be terminated"ExitSub End If Debug.Print "*** "& arr_Projects(v_ThisProject) & " selected"Set VBP = Application.VBE.VBProjects(CInt(v_ThisProject))'Make sure that current VBProject will not be changedIf VBP Is Application.VBE.ActiveVBProject And v_Options <> 1 Then MsgBox "Current VBProject cannot be modified. Macro will be terminated"ExitSub End If v_FolderName = SelectFolder() & "\" v_FileName = Dir(v_FolderName, vbNormal)'If there is any file continueIf v_FolderName = "\"Then MsgBox ("No folder")ExitSub End If'If there is any file continueIf v_FileName = ""Then MsgBox ("No files")ExitSub End If'Create backup folder as subfolder v_BackupFolderName = v_FolderName + "Backup" + Format(Now(), "yyyyMMddhhmmss") + "_" + Replace(Replace(Replace(arr_Projects(v_ThisProject), "(", ""), ")", ""), "+", "") MkDir v_BackupFolderName v_BackupFolderName = v_BackupFolderName + "\"'export all filesIf v_Options = 1 Or v_Options = 2 Then Debug.Print "Export all Modules"ForEach VBC In VBP.VBComponentsSelectCase VBC.TypeCase 1 'vbext_ct_StdModule v_FileExtension = "bas"Case 2 'vbext_ct_ClassModule v_FileExtension = "cls"Case 3 'vbext_ct_MSForm v_FileExtension = "frm"Case 100 'ThisProject v_FileExtension = "cls"CaseElse v_Skip = TrueEndSelect VBC.Export v_BackupFolderName + VBC.Name + "." + v_FileExtension Debug.Print VBC.Name + "." + v_FileExtension + " exported"OnErrorResumeNextNextElse Debug.Print "Export only replaced Modules"EndIf'import files in folderIf v_Options = 2 Or v_Options = 3 Then v_FileName = Dir(v_FolderName, vbNormal)'loop all files in folderDoWhile v_FileName <> "" v_Skip = FalseIf Split(v_FileName, ".")(1) <> "frx"Then'class ThisProject has to be handled on text baseIf v_FileName <> "ThisProject.cls"ThenOnErrorResumeNext'check existanceSet VBC = VBP.VBComponents(Split(v_FileName, ".")(0))'no export and remove if module in folder does not yet existIf Err.Number = 0 ThenSelectCase VBC.TypeCase 1 'vbext_ct_StdModule v_FileExtension = "bas"Case 2 'vbext_ct_ClassModule v_FileExtension = "cls"Case 3 'vbext_ct_MSForm v_FileExtension = "frm"CaseElse'skip files with invalid file extension v_Skip = TrueEndSelect'skip files when file extension does not match with existing module typeIf Split(v_FileName, ".")(UBound(Split(v_FileName, "."))) <> v_FileExtension Then v_Skip = True Debug.Print v_FileName + " skipped, since Type does not match file extension"Else'only export if not all modules exported previouslyIf v_Options = 3 And v_Skip = FalseThen VBC.Export v_BackupFolderName + VBC.Name + "." + v_FileExtension Debug.Print v_FileName + " exported"EndIfOnErrorGoTo 0'remove only if not skipped by previous conditionsIf v_Skip = FalseAnd Err.Number = 0 Then VBP.VBComponents.Remove VBComponent:=VBC Debug.Print v_FileName + " removed"EndIfEndIfElse Debug.Print "No " + Split(v_FileName, ".")(0) + " to be removed"EndIfOnErrorGoTo 0If v_Skip = FalseThen VBP.VBComponents.Import v_FolderName + v_FileName Debug.Print v_FileName + " imported"EndIfElse'keep current ThisProjectin VBCSet VBC = VBP.VBComponents("ThisProject")'Import ThisProject.cls - will be imported as normal class moduleSet v_ThisProject = VBP.VBComponents.Import(v_FolderName + v_FileName) Debug.Print v_FileName + " imported as " + v_ThisProject.Name'only export if not all modules exported previouslyIf v_Options = 3 Then VBC.Export v_BackupFolderName + VBC.Name + ".cls" Debug.Print v_FileName + " exported"EndIf'delete code from current ThisProject VBC.CodeModule.DeleteLines StartLine:=1, Count:=VBC.CodeModule.CountOfLines Debug.Print "ThisProject - Lines removed"'Add all lines from imported "ThisProject.cls" if anyIf v_ThisProject.CodeModule.CountOfLines > 0 Then VBC.CodeModule.AddFromString String:=v_ThisProject.CodeModule.Lines(1, v_ThisProject.CodeModule.CountOfLines) Debug.Print "ThisProject - Lines added from " + v_ThisProject.NameEndIf v_ThisProjectName = v_ThisProject.Name'remove normal class module created by import VBP.VBComponents.Remove VBComponent:=v_ThisProject Debug.Print v_ThisProjectName + " removed"EndIfEndIf v_FileName = Dir()LoopEndIf Debug.Print "*** "& Application.VBE.SelectedVBComponent.Name & " completed at "& Date& " "& Time & " ***" Debug.Print "*********************************************************"EndSubSub EnableReferences(RefGuid AsString)Dim strGUID AsVariantDim theRefs AsVariantDim theRef AsVariantDim i AsLong'*****************************************************************************'**** Set references for SmartArt, Excel, Word and Powerpoint'*****************************************************************************Set theRefs = Application.VBE.ActiveVBProject.References 'Application.VBE.VBProjects(1).ReferencesWith theRefs'****Remove broken referencesFor i = theRefs.Count To 1 Step -1Set theRef = .Item(i)If theRef.isbroken = TrueThen .References.Remove theRefEndIfNext i'****Errors have to be omitted in this caseOnErrorResumeNext .AddFromGuid Guid:=RefGuid, Major:=1, Minor:=0'Evaluate errorSelectCase Err.NumberCase 32813'Reference already set, no action requiredCase vbNullString'Reference successfully setCaseElse'Error while setting reference - exit subGoTo Ref_ErrorEndSelectEndWith'****Re-enable errorsOnErrorGoTo 0ExitSub Ref_Error: MsgBox "There was an issue activating"& vbNewLine _& "a required reference."& vbNewLine _& "Macro ended!", vbCritical + vbOKOnly, "Error!"ExitSub End Sub Function SelectFolder() AsStringDim sFolder AsStringDim xlApp AsObject'Assign Excel app to ObjectSet xlApp = CreateObject("Excel.Application")With xlApp.FileDialog(msoFileDialogFolderPicker) Debug.Print "*** Patience please"If .Show = -1 Then' if OK is pressed sFolder = .SelectedItems(1)EndIfEndWith xlApp.QuitSet xlApp = NothingIf sFolder <> ""Then' if a file was chosen SelectFolder = sFolderEndIfEndFunction