Exporting MS Access Forms and Class / Modules Recursively to text files?

后端 未结 6 1123
时光取名叫无心
时光取名叫无心 2020-12-01 05:57

I found some code on an ancient message board that nicely exports all of the VBA code from classes, modules and forms (see below):

Option Explicit
Option Com         


        
相关标签:
6条回答
  • 2020-12-01 06:16

    You can use the Access.Application object.

    Also, in order to avoid multiple confirmation dialogs when opening the databases, just change the security level in Tools / Macros / Security.

    And to open multiple databases with user/password you can join the workgroup (Tools / Security / Workgroup administrator) and log in with the desired user/password (from the database with the SaveToFile function), then run the code. Remember, later on, to join the default workgroup (you can try to join an inexistent workgroup and access will revert to the default).

    Option Explicit
    Option Compare Database
    
    
    'Save the code for all modules to files in currentDatabaseDir\Code
    Public Function SaveToFile()
    
       On Error GoTo SaveToFile_Err
        
       Dim Name As String
       Dim WasOpen As Boolean
       Dim Last As Integer
       Dim i As Integer
       Dim TopDir As String, Path As String, FileName As String
       Dim F As Long                          'File for saving code
       Dim LineCount As Long                  'Line count of current module
        
       Dim oApp As New Access.Application
        
       ' Open remote database
       oApp.OpenCurrentDatabase ("D:\Access\myDatabase.mdb"), False
    
        
       i = InStrRev(oApp.CurrentDb.Name, "\")
       TopDir = VBA.Left(oApp.CurrentDb.Name, i - 1)
       Path = TopDir & "\" & "Code"           'Path where the files will be written
        
       If (Dir(Path, vbDirectory) = "") Then
          MkDir Path                           'Ensure this exists
       End If
        
       '--- SAVE THE STANDARD MODULES CODE ---
        
       Last = oApp.CurrentProject.AllModules.Count - 1
        
       For i = 0 To Last
          Name = oApp.CurrentProject.AllModules(i).Name
          WasOpen = True                       'Assume already open
        
             If Not oApp.CurrentProject.AllModules(i).IsLoaded Then
                WasOpen = False                    'Not currently open
                oApp.DoCmd.OpenModule Name              'So open it
             End If
        
          LineCount = oApp.Modules(Name).CountOfLines
          FileName = Path & "\" & Name & ".vba"
        
          If (Dir(FileName) <> "") Then
            Kill FileName                      'Delete previous version
          End If
        
          'Save current version
          F = FreeFile
          Open FileName For Output Access Write As #F
          Print #F, oApp.Modules(Name).Lines(1, LineCount)
          Close #F
        
          If Not WasOpen Then
             oApp.DoCmd.Close acModule, Name         'It wasn't open, so close it again
          End If
       Next
        
       '--- SAVE FORMS MODULES CODE ---
        
       Last = oApp.CurrentProject.AllForms.Count - 1
       
       For i = 0 To Last
          Name = oApp.CurrentProject.AllForms(i).Name
          WasOpen = True
        
          If Not oApp.CurrentProject.AllForms(i).IsLoaded Then
             WasOpen = False
             oApp.DoCmd.OpenForm Name, acDesign
          End If
        
          LineCount = oApp.Forms(Name).Module.CountOfLines
          FileName = Path & "\" & Name & ".vba"
        
          If (Dir(FileName) <> "") Then
             Kill FileName
          End If
        
          F = FreeFile
          Open FileName For Output Access Write As #F
          Print #F, oApp.Forms(Name).Module.Lines(1, LineCount)
          Close #F
        
          If Not WasOpen Then
             oApp.DoCmd.Close acForm, Name
          End If
       Next
       
       '--- SAVE REPORTS MODULES CODE ---
        
       Last = oApp.CurrentProject.AllReports.Count - 1
       
       For i = 0 To Last
          Name = oApp.CurrentProject.AllReports(i).Name
          WasOpen = True
        
          If Not oApp.CurrentProject.AllReports(i).IsLoaded Then
             WasOpen = False
             oApp.DoCmd.OpenReport Name, acDesign
          End If
        
          LineCount = oApp.Reports(Name).Module.CountOfLines
          FileName = Path & "\" & Name & ".vba"
        
          If (Dir(FileName) <> "") Then
             Kill FileName
          End If
        
          F = FreeFile
          Open FileName For Output Access Write As #F
          Print #F, oApp.Reports(Name).Module.Lines(1, LineCount)
          Close #F
        
          If Not WasOpen Then
             oApp.DoCmd.Close acReport, Name
          End If
       Next
       
       MsgBox "Created source files in " & Path
        
       ' Reset the security level
       Application.AutomationSecurity = msoAutomationSecurityByUI
       
    SaveToFile_Exit:
       
       If Not oApp.CurrentDb Is Nothing Then oApp.CloseCurrentDatabase
       If Not oApp Is Nothing Then Set oApp = Nothing
       Exit function
    
    SaveToFile_Err:
    
       MsgBox ("Error " & Err.Number & vbCrLf & Err.Description)
       Resume SaveToFile_Exit
    
    End Function
    

    I have added code for the Reports modules. When I get some time I'll try to refactor the code.

    I find this a great contribution. Thanks for sharing.

    Regards

    ================= EDIT ==================

    After a while I found the way to export the whole database (tables and queries included) and have been using it for version control in Git.

    Of course, if you have really big tables what you really want is a backup. This I use with the tables in its initial state, many of them empty, for development purposes only.

             Option Compare Database
             Option Explicit
    
      Private Const VB_MODULE               As Integer = 1
      Private Const VB_CLASS                As Integer = 2
      Private Const VB_FORM                 As Integer = 100
      Private Const EXT_TABLE               As String = ".tbl"
      Private Const EXT_QUERY               As String = ".qry"
      Private Const EXT_MODULE              As String = ".bas"
      Private Const EXT_CLASS               As String = ".cls"
      Private Const EXT_FORM                As String = ".frm"
      Private Const CODE_FLD                As String = "code"
    
      Private Const mblnSave                As Boolean = True               ' False: just generate the script
    '
    '
    
    Public Sub saveAllAsText()
    
                Dim oTable                  As TableDef
                Dim oQuery                  As QueryDef
                Dim oCont                   As Container
                Dim oForm                   As Document
                Dim oModule                 As Object
                Dim FSO                     As Object
            
                Dim strPath                 As String
                Dim strName                 As String
                Dim strFileName             As String
        
    '**
        On Error GoTo errHandler
        
        strPath = CurrentProject.path
        Set FSO = CreateObject("Scripting.FileSystemObject")
        strPath = addFolder(FSO, strPath, Application.CurrentProject.name & "_" & CODE_FLD)
        strPath = addFolder(FSO, strPath, Format(Date, "yyyy.mm.dd"))
    
        
        For Each oTable In CurrentDb.TableDefs
            strName = oTable.name
            If left(strName, 4) <> "MSys" Then
                strFileName = strPath & "\" & strName & EXT_TABLE
                If mblnSave Then Application.ExportXML acExportTable, strName, strFileName, strFileName & ".XSD", strFileName & ".XSL", , acUTF8, acEmbedSchema + acExportAllTableAndFieldProperties
                Debug.Print "Application.ImportXML """ & strFileName & """, acStructureAndData"
            End If
        Next
        
        For Each oQuery In CurrentDb.QueryDefs
            strName = oQuery.name
            If left(strName, 1) <> "~" Then
                strFileName = strPath & "\" & strName & EXT_QUERY
                If mblnSave Then Application.SaveAsText acQuery, strName, strFileName
                Debug.Print "Application.LoadFromText acQuery, """ & strName & """, """ & strFileName & """"
            End If
        Next
        
        Set oCont = CurrentDb.Containers("Forms")
        For Each oForm In oCont.Documents
            strName = oForm.name
            strFileName = strPath & "\" & strName & EXT_FORM
            If mblnSave Then Application.SaveAsText acForm, strName, strFileName
            Debug.Print "Application.LoadFromText acForm, """ & strName & """, """ & strFileName & """"
        Next
        
        strPath = addFolder(FSO, strPath, "modules")
        For Each oModule In Application.VBE.ActiveVBProject.VBComponents
            strName = oModule.name
            strFileName = strPath & "\" & strName
            Select Case oModule.Type
                Case VB_MODULE
                    If mblnSave Then oModule.Export strFileName & EXT_MODULE
                    Debug.Print "Application.VBE.ActiveVBProject.VBComponents.Import """ & strFileName & EXT_MODULE; """"
                Case VB_CLASS
                    If mblnSave Then oModule.Export strFileName & EXT_CLASS
                    Debug.Print "Application.VBE.ActiveVBProject.VBComponents.Import """ & strFileName & EXT_CLASS; """"
                Case VB_FORM
                    ' Do not export form modules (already exported the complete forms)
                Case Else
                    Debug.Print "Unknown module type: " & oModule.Type, oModule.name
            End Select
        Next
        
        If mblnSave Then MsgBox "Files saved in  " & strPath, vbOKOnly, "Export Complete"
    
    Exit Sub
    
    errHandler:
        MsgBox "Error " & Err.Number & ": " & Err.Description & vbCrLf
        Stop: Resume
    
    End Sub
    '
    
    '
    ' Create a folder when necessary. Append the folder name to the given path.
    '
    Private Function addFolder(ByRef FSO As Object, ByVal strPath As String, ByVal strAdd As String) As String
        addFolder = strPath & "\" & strAdd
        If Not FSO.FolderExists(addFolder) Then MkDir addFolder
    End Function
    '
    

    EDIT2


    When saving queries, they often get changed in trivial aspects which I don't want to get commited to the git repository. I changed the code so it just exports the SQL code in the query.

    For Each oQuery In CurrentDb.QueryDefs
        strName = oQuery.Name
        If Left(strName, 1) <> "~" Then
            strFileName = strPath & "\" & strName & EXT_QUERY
            saveQueryAsText oQuery, strFileName
        End If
    Next
    
    '
    ' Save just the SQL code in the query
    '
    Private Sub saveQueryAsText(ByVal oQuery As QueryDef, ByVal strFileName As String)
            
       Dim intFile As Integer
    
       intFile = FreeFile
       Open strFileName For Output As intFile
       Print #intFile, oQuery.sql
       Close intFile
    
    End Sub
    

    And to import and recreate the database I use another module, mDBImport. In the repository, the modules are contained in the 'modules' subfolder:

    Private Const repoPath As String = "C:\your\repository\path\here"
    
    Public Sub loadFromText(Optional ByVal strPath As String = REPOPATH)
    
       dim FSO as Object
    
       Set oFolder = FSO.GetFolder(strPath)
       Set FSO = CreateObject("Scripting.FileSystemObject")
    
       For Each oFile In oFolder.files
          Select Case FSO.GetExtensionName(oFile.Path)
          Case "tbl"
             Application.ImportXML oFile.Path, acStructureAndData
          Case "qry"
             intFile = FreeFile
             Open oFile.Path For Input As #intFile
             strSQL = Input$(LOF(intFile), intFile)
             Close intFile
             CurrentDb.CreateQueryDef Replace(oFile.Name, ".qry", ""), strSQL
            
          Case "frm"
             Application.loadFromText acForm, Replace(oFile.Name, ".frm", ""), oFile.Path
          End Select
       Next oFile
    
       ' load modules and class modules
       strPath = FSO.BuildPath(strPath, "modules")
       If Not FSO.FolderExists(strPath) Then Err.Raise vbObjectError + 4, , "Modules folder doesn't exist!"
       Set oFolder = FSO.GetFolder(strPath)
       
       With Application.VBE.ActiveVBProject.VBComponents
          For Each oFile In oFolder.files
             Select Case FSO.GetExtensionName(oFile.Path)
             Case "cls", "bas"
                If oFile.Name <> "mDBImport.bas" Then .Import oFile.Path
             End Select
          Next oFile
       End With
    
       MsgBox "The database objects where correctly loaded.", vbOKOnly, "LoadFromText"
    
    Exit Sub
    
    errHandler:
       MsgBox Err.Description, vbCritical + vbOKOnly
    
    End Sub
    
    0 讨论(0)
  • 2020-12-01 06:25

    another way is keep most used code in one external master.mdb and join it to any count of *.mdbs trough Modules->Tools->References->Browse->...\master.mdb

    the only problem in old 97 Access you can Debug, Edit and Save directly in destination.mdb, but in all newer, since MA 2000, 'Save' option is gone and any warnings on close unsaved code

    0 讨论(0)
  • 2020-12-01 06:27

    Like for MS Excel, you can also use a loop over the Application.VBE.VBProjects(1).VBComponents and use the Export method to export your modules/classes/forms:

    Const VB_MODULE = 1
    Const VB_CLASS = 2
    Const VB_FORM = 100
    Const EXT_MODULE = ".bas"
    Const EXT_CLASS = ".cls"
    Const EXT_FORM = ".frm"
    Const CODE_FLD = "Code"
    
    Sub ExportAllCode()
    
    Dim fileName As String
    Dim exportPath As String
    Dim ext As String
    Dim FSO As Object
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    ' Set export path and ensure its existence
    exportPath = CurrentProject.path & "\" & CODE_FLD
    If Not FSO.FolderExists(exportPath) Then
        MkDir exportPath
    End If
    
    ' The loop over all modules/classes/forms
    For Each c In Application.VBE.VBProjects(1).VBComponents
        ' Get the filename extension from type
        ext = vbExtFromType(c.Type)
        If ext <> "" Then
            fileName = c.name & ext
            debugPrint "Exporting " & c.name & " to file " & fileName
            ' THE export
            c.Export exportPath & "\" & fileName
        Else
            debugPrint "Unknown VBComponent type: " & c.Type
        End If
    Next c
    
    End Sub
    
    ' Helper function that translates VBComponent types into file extensions
    ' Returns an empty string for unknown types
    Function vbExtFromType(ByVal ctype As Integer) As String
        Select Case ctype
            Case VB_MODULE
                vbExtFromType = EXT_MODULE
            Case VB_CLASS
                vbExtFromType = EXT_CLASS
            Case VB_FORM
                vbExtFromType = EXT_FORM
        End Select
    End Function
    

    Only takes a fraction of a second to execute.

    Cheers

    0 讨论(0)
  • 2020-12-01 06:28

    Lovely answer Clon.

    Just a slight variation if you are trying to open MDBs that has a startup form and/or a AutoExec macro and above doesn't always seem to work reliably.

    Looking at this answer on another website: By pass startup form / macros and scrolling almost to the end of the discussion is some code which temporarily gets rid of the startup form settings and extracts the AutoExec macro to your database before writing over it with an TempAutoExec macro (which does nothing), does some work (between lines 'Read command bars and app.CloseCurrentDatabase) and then fixes everything back again.

    0 讨论(0)
  • 2020-12-01 06:31

    IDK why no one has suggested this before, but here is a small piece of code I use for this. Pretty simple and straightforward

    Public Sub VBAExportModule()
        On Error GoTo Errg
        Dim rs As DAO.Recordset
        Set rs = CurrentDb.OpenRecordset("SELECT MSysObjects.Name FROM MSysObjects WHERE Type=-32761", dbOpenDynaset, dbSeeChanges)
    
        Do Until rs.EOF
            Application.SaveAsText acModule, rs("Name"), "C:\" & rs("Name") & ".txt"
            rs.MoveNext
        Loop
    
    Cleanup:
        If Not rs Is Nothing Then rs.Close
        Set rs = Nothing
        Exit Sub
    Errg:
        GoTo Cleanup
    End Sub
    
    0 讨论(0)
  • 2020-12-01 06:32

    You can also try this code. It will preserve the items' filetypes (.bas, .cls, .frm) Remember to refer to / Check the Microsoft Visual Basic For Applications Extensibility Library in VBE > Tools > References

    Public Sub ExportAllCode()
    
        Dim c As VBComponent
        Dim Sfx As String
    
        For Each c In Application.VBE.VBProjects(1).VBComponents
            Select Case c.Type
                Case vbext_ct_ClassModule, vbext_ct_Document
                    Sfx = ".cls"
                Case vbext_ct_MSForm
                    Sfx = ".frm"
                Case vbext_ct_StdModule
                    Sfx = ".bas"
                Case Else
                    Sfx = ""
            End Select
    
            If Sfx <> "" Then
                c.Export _
                    Filename:=CurrentProject.Path & "\" & _
                    c.Name & Sfx
            End If
        Next c
    
    End Sub
    
    0 讨论(0)
提交回复
热议问题