blog.atwork.at

news and know-how about microsoft, technology, cloud and more.

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

  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 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

Comments (2) -

  • Alex

    8/5/2020 8:54:39 AM |

    Im Titel fehlt ein x bei "eportieren"

  • Toni Pohl

    8/5/2020 12:53:14 PM |

    Thx Alex, "x" hinzugefügt. ;)

Loading