office交流网--QQ交流群号

Access培训群:792054000         Excel免费交流群群:686050929          Outlook交流群:221378704    

Word交流群:218156588             PPT交流群:324131555

把整个Access数据库所有对象写到一个文本文件

2017-09-12 08:05:00
Arvin Meyer
转贴
3169

使用微软未公开的函数 Application.SaveAsText 将整个Access数据库所有对象包括窗体 报表  宏 查询 模块等的内容及定义写到文本文件中去

相当于对整个Access数据库做一个完整的程序备份(不含数据库内容)




Public Sub DocDatabase()
 '====================================================================
 ' Name:    DocDatabase
 ' Purpose: Documents the database to a series of text files
 '
 ' Author:  Arvin Meyer
 ' Date:    June 02, 1999
 ' Comment: Uses the undocumented [Application.SaveAsText] syntax
 '        	To reload use the syntax [Application.LoadFromText] 
 '		Modified to set a reference to DAO 8/22/2005
 '====================================================================
On Error GoTo Err_DocDatabase
Dim dbs As DAO.Database
Dim cnt As DAO.Container
Dim doc As DAO.Document
Dim i As Integer

Set dbs = CurrentDb() ' use CurrentDb() to refresh Collections

Set cnt = dbs.Containers("Forms")
For Each doc In cnt.Documents
    Application.SaveAsText acForm, doc.Name, "D:\Document" & doc.Name & ".txt"
Next doc

Set cnt = dbs.Containers("Reports")
For Each doc In cnt.Documents
    Application.SaveAsText acReport, doc.Name, "D:\Document" & doc.Name & ".txt"
Next doc

Set cnt = dbs.Containers("Scripts")
For Each doc In cnt.Documents
    Application.SaveAsText acMacro, doc.Name, "D:\Document" & doc.Name & ".txt"
Next doc

Set cnt = dbs.Containers("Modules")
For Each doc In cnt.Documents
    Application.SaveAsText acModule, doc.Name, "D:\Document" & doc.Name & ".txt"
Next doc

For i = 0 To dbs.QueryDefs.Count - 1
    Application.SaveAsText acQuery, dbs.QueryDefs(i).Name, "D:\Document" & dbs.QueryDefs(i).Name & ".txt"
Next i

Set doc = Nothing
Set cnt = Nothing
Set dbs = Nothing

Exit_DocDatabase:
    Exit Sub


Err_DocDatabase:
    Select Case Err

    Case Else
        MsgBox Err.Description
        Resume Exit_DocDatabase
    End Select

End Sub
分享