All geek questions in one place

Export code from Microsoft Access

Is there a way to mass export Microsoft Access code to files? I see that I can export one file at a time, but there are hundreds, and I will be here all day. There is no “Export All" or multi-screen export anywhere?

+3
source share
4 answers

To display all the code on the desktop, including code from forms and reports, you can paste it into the standard module and run it by pressing F5 or by executing F8. You can first specify the name of the desktop folder.

   Sub AllCodeToDesktop()
   ''The reference for the FileSystemObject Object is Windows Script Host Object Model
   ''but it not necessary to add the reference for this procedure.

   Dim fs As Object
   Dim f As Object
   Dim strMod As String
   Dim mdl As Object
   Dim i As Integer

   Set fs = CreateObject("Scripting.FileSystemObject")

   ''Set up the file.
   ''SpFolder is a small function, but it would be better to fill in a
   ''path name instead of SpFolder(Desktop), eg "c:\users\somename\desktop"
   Set f = fs.CreateTextFile(SpFolder(Desktop) & "\" _
       & Replace(CurrentProject.Name, ".", "") & ".txt")

   ''For each component in the project ...
   For Each mdl In VBE.ActiveVBProject.VBComponents
       ''using the count of lines ...
       i = VBE.ActiveVBProject.VBComponents(mdl.Name).CodeModule.CountOfLines
       ''put the code in a string ...
       If i > 0 Then
          strMod = VBE.ActiveVBProject.VBComponents(mdl.Name).codemodule.Lines(1, i)
       End If
       ''and then write it to a file, first marking the start with
       ''some equal signs and the component name.
       f.writeline String(15, "=") & vbCrLf & mdl.Name _
           & vbCrLf & String(15, "=") & vbCrLf & strMod
   Next

   ''Close eveything
   f.Close
   Set fs = Nothing
   End Sub

To get special folders, you can use the list provided by Microsoft.

Listing special folders: http://www.microsoft.com/technet/scriptcenter/guide/sas_fil_higv.mspx?mfr=true

: http://wiki.lessthandot.com/index.php/Code_and_Code_Windows

+1

. - > analy- > document documenter.

. , PDF ( ). . ,

, .

, - . . . , , . , .

+5

.

" ":

Public Sub ExportModules()
Const cstrExtension As String = ".bas"
Dim objModule As Object
Dim strFolder As String
Dim strDestination As String

strFolder = CurrentProject.Path

For Each objModule In CurrentProject.AllModules
    strDestination = strFolder & Chr(92) & objModule.Name & cstrExtension
    Application.SaveAsText acModule, objModule.Name, strDestination
Next objModule
End Sub
+1

:

'============================================================'
' OutputCodeModules for Access
' Don Jewett, verion 2014.11.10
' Exports the following items from an Access database
'   Modules
'   Form Modules
'   Report Modules
'
' Must be imported into Access database and run from there
'============================================================'
Option Explicit
Option Compare Database

Private Const KEY_MODULES As String = "Modules"
Private Const KEY_FORMS As String = "Forms"
Private Const KEY_REPORTS As String = "Reports"

Private m_bCancel As Boolean
Private m_sLogPath As String

'------------------------------------------------------------'
' >>>>>> Run this using F5 or F8 <<<<<<<<
'------------------------------------------------------------'
Public Sub OutputModuleHelper()
    OutputModules
End Sub

Public Sub OutputModules(Optional ByVal sFolder As String)
    Dim nCount As Long
    Dim nSuccessful As Long
    Dim sLine As String
    Dim sMessage As String
    Dim sFile As String

    If sFolder = "" Then
        sFolder = Left$(CurrentDb.Name, InStrRev(CurrentDb.Name, "\") - 1)
        sFolder = InputBox("Enter folder for files", "Output Code", sFolder)
        If sFolder = "" Then
            Exit Sub
        End If
    End If

    'normalize root path by removing trailing back-slash
    If Right(sFolder, 1) = "\" Then
        sFolder = Left(sFolder, Len(sFolder) - 1)
    End If

    'make sure this folder exists
    If Not isDir(sFolder) Then
        MsgBox "Folder does not exist", vbExclamation Or vbOKOnly
        Exit Sub
    End If

    'get a new log filename
    m_sLogPath = sFolder & "\_log-" & Format(Date, "yyyy-MM-dd-nn-mm-ss") & ".txt"

    sLine = CurrentDb.Name
    writeLog sLine
    sMessage = sLine & vbCrLf

    sLine = Format(Now, "yyyy-MM-dd nn:mm:ss") & vbCrLf
    writeLog sLine
    sMessage = sMessage & sLine & vbCrLf

    'output modules
    nCount = CurrentDb.Containers(KEY_MODULES).Documents.Count
    nSuccessful = outputContainerModules(sFolder, KEY_MODULES)

    'write to the log file and final message
    sLine = nSuccessful & vbTab & "of" & vbTab & nCount & vbTab & KEY_MODULES & " exported"
    writeFile m_sLogPath, sLine, True
    sMessage = sMessage & vbTab & sLine & vbCrLf

    'output form modules
    If Not m_bCancel Then
        nCount = CurrentDb.Containers(KEY_FORMS).Documents.Count
        nSuccessful = outputContainerModules(sFolder, KEY_FORMS)

        'write to the log file and final message
        sLine = nSuccessful & vbTab & "of" & vbTab & nCount & vbTab & "Form Modules exported"
        writeFile m_sLogPath, sLine, True
        sMessage = sMessage & vbTab & sLine & vbCrLf
    End If

    'output report modules
    If Not m_bCancel Then
        nCount = CurrentDb.Containers(KEY_REPORTS).Documents.Count
        nSuccessful = outputContainerModules(sFolder, KEY_REPORTS)

        'write to the log file and final message
        sLine = nSuccessful & vbTab & "of" & vbTab & nCount & vbTab & "Report Modules exported"
        writeFile m_sLogPath, sLine, True
        sMessage = sMessage & vbTab & sLine & vbCrLf
    End If

    If Len(sMessage) Then
        MsgBox sMessage, vbInformation Or vbOKOnly, "OutputModules"
    End If

End Sub

Private Function outputContainerModules( _
        ByVal sFolder As String, _
        ByVal sKey As String) As Long

    Dim n As Long
    Dim nCount As Long
    Dim sName As String
    Dim sPath As String

    On Error GoTo EH

    'refactored this to use reference to Documents,
    'but the object reference doesn't stick around
    'and I had to roll back to this which isn't as pretty.
    'but this works (and if it ain't broke...)
    For n = 0 To CurrentDb.Containers(sKey).Documents.Count - 1

        nCount = nCount + 1
        sName = CurrentDb.Containers(sKey).Documents(n).Name

        Select Case sKey
            Case KEY_FORMS
                sName = "Form_" & sName
            Case KEY_REPORTS
                sName = "Report_" & sName
        End Select

        sPath = sFolder & "\" & sName & ".txt"
        DoCmd.OutputTo acOutputModule, sName, acFormatTXT, sPath, False

    Next 'n

    outputContainerModules = nCount

    Exit Function

EH:
    nCount = nCount - 1

    Select Case Err.Number
        Case 2289 'can't output the module in the requested format.

            'TODO: research - I think this happens when a Form/Report doesn't have a module
            Resume Next

        Case Else
            Dim sMessage As String

            writeError Err, sKey, sName, nCount

            sMessage = "An Error ocurred outputting " & sKey & ": " & sName & vbCrLf & vbCrLf _
                & "Number " & Err.Number & vbCrLf _
                & "Description:" & Err.Description & vbCrLf & vbCrLf _
                & "Click [Yes] to continue with export or [No] to stop."

            If vbYes = MsgBox(sMessage, vbQuestion Or vbYesNo Or vbDefaultButton2, "Error") Then
                Resume Next
            Else
                m_bCancel = True
                outputContainerModules = nCount
            End If

    End Select

End Function

Private Function writeFile( _
        ByVal sPath As String, _
        ByRef sMessage As String, _
        Optional ByVal bAppend As Boolean) As Boolean

    'Dim oFSO as Object
    'Dim oStream as Object
    'Const ForWriting As Long = 2
    'Const ForAppending As Long = 8
    'Dim eFlags As Long
    Dim oFSO As FileSystemObject
    Dim oStream As TextStream
    Dim eFlags As IOMode

    On Error GoTo EH

    'Set oFSO = Server.CreateObject("Scripting.FileSystemObject")
    Set oFSO = New FileSystemObject

    If bAppend Then
        eFlags = ForAppending
    Else
        eFlags = ForWriting
    End If

    Set oStream = oFSO.OpenTextFile(sPath, eFlags, True)
    oStream.WriteLine sMessage

    writeFile = True

    GoTo CLEAN
EH:
    writeFile = False

CLEAN:
    If Not oFSO Is Nothing Then
        Set oFSO = Nothing
    End If
    If Not oStream Is Nothing Then
        Set oStream = Nothing
    End If
End Function

Private Sub writeError( _
    ByRef oErr As ErrObject, _
    ByVal sType As String, _
    ByVal sName As String, _
    ByVal nCount As Long)

    Dim sMessage As String

    sMessage = "An Error ocurred outputting " & sType & ": " & sName & " (" & nCount & ")" & vbCrLf _
        & "Number " & oErr.Number & vbCrLf _
        & "Description:" & oErr.Description & vbCrLf & vbCrLf

    writeLog sMessage

End Sub

Private Sub writeLog( _
    ByRef sMessage As String)

    On Error GoTo EH

    writeFile m_sLogPath, sMessage & vbCrLf, True

    Exit Sub
EH:
    'swallow errors?
End Sub


Private Function isDir(ByVal sPath As String) As Boolean
    On Error GoTo EH

    If Right$(sPath, 1) <> "\" Then
        sPath = sPath & "\"
    End If

    If Dir$(sPath & ".", vbDirectory) = "." Then
        isDir = True
    ElseIf Len(sPath) = 3 Then
        If Dir$(sPath, vbVolume) = Left(sPath, 1) Then
            isDir = True
        End If
    End If

    Exit Function
EH:
    isDir = False
End Function
0

Source: https://habr.com/ru/post/1744616/

More articles:


All Articles