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 Project Dim VBC As Variant 'VBComponents Dim VBP As Variant 'VBProject Dim v_Type As Double Dim v_FolderName As String Dim v_BackupFolderName As String Dim v_FileName As String Dim v_Skip As Boolean Dim v_FileExtension As String Dim v_ThisProject As Variant Dim v_ThisProjectName As String Dim v_String As String Dim W As Object Dim v_Options As Variant ReDim arr_Filename(50) As String ReDim arr_Projects(1 To 1000) As Variant Dim i As Integer 'We need debug window for logging For Each W In Application.VBE.Windows If W.Type = vbext_wt_Immediate Then W.Visible = True W.WindowState = vbext_ws_Normal End If Next 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 model Call 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 options If v_Options = "" Then MsgBox "Macro cancelled." Exit Sub End If If 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" Exit Sub End If Else MsgBox "Invalid input. Macro will be terminated" Exit Sub End If For i = 1 To Application.VBE.VBProjects.Count Set VBP = Application.VBE.VBProjects(i) 'Names of VBProjects are not unique 'Use project name for VBProjects in a project For Each P In Application.Projects If P.VBProject Is VBP Then arr_Projects(i) = P.Name End If Next P 'VBProjects not within a project have a filename If arr_Projects(i) = "" Then arr_Filename = Split(VBP.FileName, "\") arr_Projects(i) = arr_Filename(UBound(arr_Filename)) End If 'We can't change modules in current VBProject. We can use this project for export only If VBP Is Application.VBE.ActiveVBProject And v_Options <> 1 Then arr_Projects(i) = "DO NOT SELECT " + arr_Projects(i) End If v_String = v_String & i & " - " & arr_Projects(i) & vbCrLf Next i ReDim 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 selection If v_ThisProject = "" Then MsgBox "No project selected. Macro will be terminated" Exit Sub End If If 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" Exit Sub End If Else MsgBox "Invalid input. Macro will be terminated" Exit Sub 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 changed If VBP Is Application.VBE.ActiveVBProject And v_Options <> 1 Then MsgBox "Current VBProject cannot be modified. Macro will be terminated" Exit Sub End If v_FolderName = SelectFolder() & "\" v_FileName = Dir(v_FolderName, vbNormal) 'If there is any file continue If v_FolderName = "\" Then MsgBox ("No folder") Exit Sub End If 'If there is any file continue If v_FileName = "" Then MsgBox ("No files") Exit Sub 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 files If v_Options = 1 Or v_Options = 2 Then Debug.Print "Export all Modules" For Each VBC In VBP.VBComponents Select Case VBC.Type Case 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" Case Else v_Skip = True End Select VBC.Export v_BackupFolderName + VBC.Name + "." + v_FileExtension Debug.Print VBC.Name + "." + v_FileExtension + " exported" On Error Resume Next Next Else Debug.Print "Export only replaced Modules" End If 'import files in folder If v_Options = 2 Or v_Options = 3 Then v_FileName = Dir(v_FolderName, vbNormal) 'loop all files in folder Do While v_FileName <> "" v_Skip = False If Split(v_FileName, ".")(1) <> "frx" Then 'class ThisProject has to be handled on text base If v_FileName <> "ThisProject.cls" Then On Error Resume Next 'check existance Set VBC = VBP.VBComponents(Split(v_FileName, ".")(0)) 'no export and remove if module in folder does not yet exist If Err.Number = 0 Then Select Case VBC.Type Case 1 'vbext_ct_StdModule v_FileExtension = "bas" Case 2 'vbext_ct_ClassModule v_FileExtension = "cls" Case 3 'vbext_ct_MSForm v_FileExtension = "frm" Case Else 'skip files with invalid file extension v_Skip = True End Select 'skip files when file extension does not match with existing module type If 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 previously If v_Options = 3 And v_Skip = False Then VBC.Export v_BackupFolderName + VBC.Name + "." + v_FileExtension Debug.Print v_FileName + " exported" End If On Error GoTo 0 'remove only if not skipped by previous conditions If v_Skip = False And Err.Number = 0 Then VBP.VBComponents.Remove VBComponent:=VBC Debug.Print v_FileName + " removed" End If End If Else Debug.Print "No " + Split(v_FileName, ".")(0) + " to be removed" End If On Error GoTo 0 If v_Skip = False Then VBP.VBComponents.Import v_FolderName + v_FileName Debug.Print v_FileName + " imported" End If Else 'keep current ThisProjectin VBC Set VBC = VBP.VBComponents("ThisProject") 'Import ThisProject.cls - will be imported as normal class module Set 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 previously If v_Options = 3 Then VBC.Export v_BackupFolderName + VBC.Name + ".cls" Debug.Print v_FileName + " exported" End If '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 any If 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.Name End If v_ThisProjectName = v_ThisProject.Name 'remove normal class module created by import VBP.VBComponents.Remove VBComponent:=v_ThisProject Debug.Print v_ThisProjectName + " removed" End If End If v_FileName = Dir() Loop End If Debug.Print "*** " & Application.VBE.SelectedVBComponent.Name & " completed at " & Date & " " & Time & " ***" Debug.Print "*********************************************************" End Sub Sub EnableReferences(RefGuid As String) Dim strGUID As Variant Dim theRefs As Variant Dim theRef As Variant Dim i As Long '***************************************************************************** '**** Set references for SmartArt, Excel, Word and Powerpoint '***************************************************************************** Set theRefs = Application.VBE.ActiveVBProject.References 'Application.VBE.VBProjects(1).References With theRefs '****Remove broken references For i = theRefs.Count To 1 Step -1 Set theRef = .Item(i) If theRef.isbroken = True Then .References.Remove theRef End If Next i '****Errors have to be omitted in this case On Error Resume Next .AddFromGuid Guid:=RefGuid, Major:=1, Minor:=0 'Evaluate error Select Case Err.Number Case 32813 'Reference already set, no action required Case vbNullString 'Reference successfully set Case Else 'Error while setting reference - exit sub GoTo Ref_Error End Select End With '****Re-enable errors On Error GoTo 0 Exit Sub Ref_Error: MsgBox "There was an issue activating" & vbNewLine _ & "a required reference." & vbNewLine _ & "Macro ended!", vbCritical + vbOKOnly, "Error!" Exit Sub End Sub Function SelectFolder() As String Dim sFolder As String Dim xlApp As Object 'Assign Excel app to Object Set xlApp = CreateObject("Excel.Application") With xlApp.FileDialog(msoFileDialogFolderPicker) Debug.Print "*** Patience please" If .Show = -1 Then ' if OK is pressed sFolder = .SelectedItems(1) End If End With xlApp.Quit Set xlApp = Nothing If sFolder <> "" Then ' if a file was chosen SelectFolder = sFolder End If End Function