- Deutsch
- English
- Code
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