Quantcast
Channel: blog.atwork.at
Viewing all articles
Browse latest Browse all 1118

Project: VBA Module eportieren und importieren / Export and Import VBA Modules

0
0
  1. Deutsch
  2. English
  3. 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

  1. Alle Module eines ausgewählten Projekts in einen Ordner zu exportieren
  2. 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
  3. 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.

image

Im nächsten Schritt kann ausgewählt werden, die Module welchen Projekts exportiert oder aktualisiert werden sollen

image

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.

image

Wird das Projekt trotzdem ausgewählt, kommt es zu einem Abbruch.

image

Die letzte Eingabe erfordert die Auswahl des Ordners.

image

Für den Export wird im ausgewählten Ordner ein neuer Ordner mit “BackUp”, Zeitstempel und Zielprojekt im Namen erstellt.

image

Im Direktbereich wird die erfolgte Aktivität angezeigt.

image

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.

image

In the next step you can choose which modules of which project should be exported or updated

image

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.

image

If the project is selected anyway, it will be canceled.

image

The last entry requires the selection of the folder.

image

For export, a new folder with “BackUp”, time stamp and target project in the name is created in the selected folder.

image

The activity that has taken place is displayed in the direct area.

image

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

Viewing all articles
Browse latest Browse all 1118

Latest Images

Trending Articles