从Microsoft Access导出代码

Question

有没有办法将Microsoft Access代码批量导出到文件？我看到我一次可以导出一个文件，但有数百个，我会整天在这里。那里没有“全部导出”或多处选择导出？

Answer 1

输出所有代码到桌面上，包括窗体和报表代码，可以粘贴到一个标准模块并通过按下运行F5或通过F8进行切换。您可能希望先填写桌面文件夹的名称。

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 

要获得特殊的文件夹，可以使用Microsoft提供的列表。

枚举特殊文件夹：http://www.microsoft.com/technet/scriptcenter/guide/sas_fil_higv.mspx?mfr=true

来源：http://wiki.lessthandot.com/index.php/Code_and_Code_Windows

Answer 2

界面中一次只能输出一个以上的模块。

您可以编写自己的“导出所有”等同容易：

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 

Answer 3

你可以做到这一点，而不必在所有写任何代码。从菜单中选择tools-> analyze-> database documenter。

这会给你一些打印出代码的选项。然后，您可以在查看报告时将它发送给您的PDF打印机（如果有的话）。或者，只需打印到文本文件打印机。或者，您甚至可以点击报告菜单栏中的单词选项，并将结果发送至单词

数据库记录器具有打印所有代码（包括表单中的代码）的规定。

因此，代替一些建议的代码示例，您可以在不必编写任何代码的情况下执行此操作。请使用文档中的其他选项。记录员将产生大量的数据库中的每个属性和对象的信息。所以，如果您不取消选中某些选项，那么您将很容易清空全尺寸打印纸盒。这个记录器因此导致巨大的打印输出。

Answer 4

这里是我的版本：

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