Экспорт форм MS Access и классов / модулей рекурсивно в текстовые файлы?
Я нашел код на древней доске объявлений, который красиво экспортирует весь код VBA из классов, модулей и форм (см. ниже):
Option Explicit
Option Compare Database
Function SaveToFile() 'Save the code for all modules to files in currentDatabaseDirCode
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
I = InStrRev(CurrentDb.Name, "")
TopDir = VBA.Left(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 = Application.CurrentProject.AllModules.Count - 1
For I = 0 To Last
Name = CurrentProject.AllModules(I).Name
WasOpen = True 'Assume already open
If Not CurrentProject.AllModules(I).IsLoaded Then
WasOpen = False 'Not currently open
DoCmd.OpenModule Name 'So open it
End If
LineCount = Access.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, Access.Modules(Name).Lines(1, LineCount)
Close #F
If Not WasOpen Then
DoCmd.Close acModule, Name 'It wasn't open, so close it again
End If
Next
'--- SAVE FORMS MODULES CODE ---
Last = Application.CurrentProject.AllForms.Count - 1
For I = 0 To Last
Name = CurrentProject.AllForms(I).Name
WasOpen = True
If Not CurrentProject.AllForms(I).IsLoaded Then
WasOpen = False
DoCmd.OpenForm Name, acDesign
End If
LineCount = Access.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, Access.Forms(Name).Module.Lines(1, LineCount)
Close #F
If Not WasOpen Then
DoCmd.Close acForm, Name
End If
Next
MsgBox "Created source files in " & Path
End Function
однако этот код не решает мою проблему, так как у меня есть 110 ms-access *.mdb
мне нужно экспортировать vba из текстовых файлов, подходящих для grepping.
пути к 110 файлам, которые меня интересуют, уже хранятся в таблице, и мой код уже получил эту информацию рекурсивно (наряду с некоторыми другая фильтрация) ... Итак, рекурсивная часть выполнена.
большинство из этих файлов открываются одним файлом безопасности пользователя доступа,.mdw
и я попробовал несколько методов их открытия. ADO и ADOX отлично работали, когда я искал связанные таблицы в этих каталогах...но приведенный выше код включает находясь внутри базы данных, вы экспортируете данные из, и я хочу иметь возможность сделать это из отдельной базы данных, которая открывает все mdb
s и выполняет экспорт по каждому из них.
одна из моих попыток заключалась в использовании класса PrivDBEngine для подключения к базам данных извне, но это не позволяет мне получить доступ к объекту приложения, который требуется для экспорта кода выше.
Private Sub exportToFile(db_path As String, db_id As String, loginInfo As AuthInfoz, errFile As Variant)
Dim pdbeNew As PrivDBEngine
Dim db As DAO.Database
Dim ws As DAO.Workspace
Dim rst As DAO.Recordset
Dim cn As ADODB.Connection ' ADODB.Connection
Dim rs As ADODB.Recordset ' ADODB.Recordset
Dim strConnect As String
Dim blnReturn As Boolean
Dim Doc As Document
Dim mdl As Module
Dim lngCount As Long
Dim strForm As String
Dim strOneLine As String
Dim sPtr As Integer
Set fso = CreateObject("Scripting.FileSystemObject")
Set exportFile = fso.CreateTextFile("E:TicketsCSN1006218vbacode" & db_id & ".txt", ForAppending)
' Export stuff...
On Error GoTo errorOut
Set pdbeNew = New PrivDBEngine
With pdbeNew
.SystemDB = loginInfo.workgroup
.DefaultUser = loginInfo.username
.DefaultPassword = loginInfo.password
End With
Set ws = pdbeNew.Workspaces(0)
Set db = ws.OpenDatabase(db_path)
For Each Doc In db.Containers("Modules").Documents
DoCmd.OpenModule Doc.Name
Set mdl = Modules(Doc.Name)
exportFile.WriteLine ("---------------------")
exportFile.WriteLine ("Module Name: " & Doc.Name)
exportFile.WriteLine ("Module Type: " & mdl.Type)
exportFile.WriteLine ("---------------------")
lngCount = lngCount + mdl.CountOfLines
'For i = 1 To lngCount
' strOneLine = mdl.Lines(i, 1)
' exportFile.WriteLine (strOneLine)
'Next i
Set mdl = Nothing
DoCmd.Close acModule, Doc.Name
Next Doc
Close_n_exit:
If Not (db Is Nothing) Then
Call wk.Close
Set wk = Nothing
Call db.Close
End If
Call exportFile.Close
Set exportFile = Nothing
Set fso = Nothing
Exit Sub
errorOut:
Debug.Print "----------------"
Debug.Print "BEGIN: Err"
If err.Number <> 0 Then
Msg = "Error # " & Str(err.Number) & " was generated by " _
& err.Source & Chr(13) & "Error Line: " & Erl & Chr(13) & err.Description
'MsgBox Msg, , "Error", err.HelpFile, err.HelpContext
Debug.Print Msg
End If
Resume Close_n_exit
End Sub
есть ли в любом случае доступ к application
объект PrivDBEngine
? У меня есть много модулей, которые нуждаются в grepping.
6 ответов
вы также можете попробовать этот код. Он сохранит типы файлов элементов (.бас .cls,.кадр) Не забудьте обратиться к / проверить Библиотека Расширяемости Microsoft Visual Basic Для Приложений in VBE > инструменты > ссылки
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
вы можете использовать доступ.Объект приложения.
кроме того, чтобы избежать нескольких диалоговых окон подтверждения при открытии баз данных, просто измените уровень безопасности в Tools / Macros / Security.
и чтобы открыть несколько баз данных с пользователем / паролем, вы можете присоединиться к рабочей группе (инструменты / безопасность / администратор рабочей группы) и войти в систему с нужным пользователем/паролем (из базы данных с функцией SaveToFile), а затем запустить код. Помните, позже, чтобы присоединиться к рабочая группа по умолчанию (вы можете попытаться присоединиться к несуществующей рабочей группе, и access вернется к умолчанию).
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
Я добавил код для модулей отчетов. Когда у меня будет время, я попытаюсь изменить код.
Я считаю это большим вкладом. Спасибо, что поделился.
в отношении
как и для MS Excel, вы также можете использовать цикл над Application.VBE.VBProjects(1).VBComponents
и с помощью Export
метод экспорта модулей / классов / форм:
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
только занимает долю секунды, чтобы выполнить.
Ура
прекрасный ответ клон.
просто небольшое изменение, если вы пытаетесь открыть MDBs, который имеет запуск формы и/или макрос AutoExec и выше, похоже, не всегда работает надежно.
глядя на этот ответ на другом сайте: by pass startup form / macros и прокрутка почти до конца обсуждения-это код, который временно избавляется от настроек формы запуска и извлекает макрос AutoExec на ваш база данных, прежде чем писать над ней с помощью макроса TempAutoExec (который ничего не делает), выполняет некоторую работу (между строками 'Read command bars и app.CloseCurrentDatabase), а затем исправляет все снова.
другой способ-сохранить наиболее используемый код в одном внешнем мастере.MDB-компонента и присоедините его к любому счету *.mdbs корыто модули - >инструменты - >ссылки - >обзор ->...\мастер.mdb
единственная проблема в old 97 Access вы можете отлаживать, редактировать и сохранять непосредственно в пункте назначения.MDB-компонента, но во всех новых, начиная с MA 2000, опция "Сохранить" исчезла и любые предупреждения о закрытом несохраненном коде
IDK, почему никто не предложил это раньше, но вот небольшой фрагмент кода, который я использую для этого. Довольно просто и просто
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