MSOffice小知识:Access数据库的生成、修理压缩和版本转换

Author:水如烟

在前面的基本框架中给出了代码下载。到现在，其中一些文件需要修改，主要的是考虑了远程对象的使用，就是CreateObject(Application,Server)，加了Server。只是，现在给出的代码还是只是支持本地的。

修改后的有关文件如下：
ApplicationBase.vb

Option   Strict   Off
Namespace  uOffice
     Public   MustInherit   Class  ApplicationBase
         Implements  IDisposable

         Friend  gOfficeApplication  As  ApplicationEnum
         Protected  gApplicationObject  As   Object

         Private  gBeforeProcessStartTime  As   Date
         Private  gAfterProcessStartTime  As   Date

         Private  gServer  As   String   =   ""

         Friend   Sub  CreateInstance( ByVal  officeApplication  As  ApplicationEnum,  ByVal  server  As   String )
            gOfficeApplication  =  officeApplication
            gServer  =  server
            CreateInstance()
         End Sub

         Private   Sub  CreateInstance()
             ' 保留原有配置
            SaveDefaultPropertiesWhenApplicationInitialize()

             ' 取实例前时间
            gBeforeProcessStartTime  =  Now

             ' 实例
             Select   Case  gOfficeApplication
                 Case  ApplicationEnum.Access
                    gApplicationObject  =   CreateObject (SR.GetString( " Office_Application_Access " ), gServer)
                 Case  ApplicationEnum.Excel
                    gApplicationObject  =   CreateObject (SR.GetString( " Office_Application_Excel " ), gServer)
                 Case  ApplicationEnum.Word
                    gApplicationObject  =   CreateObject (SR.GetString( " Office_Application_Word " ), gServer)
             End   Select

             ' 取实例后时间
            gAfterProcessStartTime  =  Now
         End Sub

         ' '' <summary>
         ' '' 退出主进程
         ' '' </summary>
         Public   Sub  Quit()
             ' 置回默认设置,如Excel.DisplayAlerts = True
            ResetDefaultPropertiesBeforeApplicationRelease()

             ' 释放其它对象,如Excel.Worksheets
            RealseInternalComObjectsBeforeApplicationRelease()

             ' 释放主进程,如Excel
            Application_Quit()

             ' 保证完全退出
             Try
                ApplicationRelease()
             Catch  ex  As  Exception
             End   Try
         End Sub

         ' '' <summary>
         ' '' 退出其它Com对象
         ' '' </summary>
         Protected   MustOverride   Sub  RealseInternalComObjectsBeforeApplicationRelease()

         Protected   Overridable   Sub  Application_Quit()
            gApplicationObject.Quit()
         End Sub

         ' '' <summary>
         ' '' 退出OfficeApplication进程
         ' '' </summary>
         Private   Sub  ApplicationRelease()
            ComObjReleaseMethod.ReleaseComObject(gApplicationObject)
             Select   Case  gOfficeApplication
                 Case  ApplicationEnum.Access
                    ComObjReleaseMethod.KillProcess(SR.GetString( " Office_ProcessName_Access " ), gBeforeProcessStartTime, gAfterProcessStartTime, gServer)
                 Case  ApplicationEnum.Excel
                    ComObjReleaseMethod.KillProcess(SR.GetString( " Office_ProcessName_Excel " ), gBeforeProcessStartTime, gAfterProcessStartTime, gServer)
                 Case  ApplicationEnum.Word
                    ComObjReleaseMethod.KillProcess(SR.GetString( " Office_ProcessName_Word " ), gBeforeProcessStartTime, gAfterProcessStartTime, gServer)
             End   Select
         End Sub

         ' '' <summary>
         ' '' 保存默认设置
         ' '' </summary>
         Protected   MustOverride   Sub  SaveDefaultPropertiesWhenApplicationInitialize()

         ' '' <summary>
         ' '' 置回默认设置
         ' '' </summary>
         Protected   MustOverride   Sub  ResetDefaultPropertiesBeforeApplicationRelease()

         ' ///以下为实现IDisposable接口IDE自动创建的代码
         Private  disposedValue  As   Boolean   =   False          '  To detect redundant calls

         '  IDisposable
         Protected   Overridable   Sub  Dispose( ByVal  disposing  As   Boolean )
             If   Not   Me .disposedValue  Then
                 If  disposing  Then
                     '  TODO: free unmanaged resources when explicitly called
                    Quit()
                 End   If

                 '  TODO: free shared unmanaged resources
             End   If
             Me .disposedValue  =   True
         End Sub

#Region  " IDisposable Support "
         '  This code added by Visual Basic to correctly implement the disposable pattern.
         Public   Sub  Dispose()  Implements  IDisposable.Dispose
             '  Do not change this code.  Put cleanup code in Dispose(ByVal disposing As Boolean) above.
            Dispose( True )
            GC.SuppressFinalize( Me )
         End Sub
#End Region

     End Class
End Namespace

ApplicationBaseCommon.vb

Option   Strict   Off

Namespace  uOffice
    Partial  Public   Class  ApplicationBase

         ' '' <summary>
         ' '' 设置对象可见性
         ' '' </summary>
         ' '' <param name="visible"></param>
         ' '' <remarks></remarks>
         Public   Sub  SetVisible( ByVal  visible  As   Boolean )
             Me .gApplicationObject.Visible  =  visible
         End Sub

         ' '' <summary>
         ' '' 服务器
         ' '' </summary>
         ' '' <remarks>本地时字符串为空,否则如\\MyComputer</remarks>
         Public   ReadOnly   Property  Server()  As   String
             Get
                 Return  gServer
             End   Get
         End Property

         ' '' <summary>
         ' '' 版本号
         ' '' </summary>
         Public   ReadOnly   Property  Version()  As   String
             Get
                 Return   Me .gApplicationObject.Version
             End   Get
         End Property

         ' '' <summary>
         ' '' 默认文件地址
         ' '' </summary>
         ' '' <remarks>一般在MyDocuments目录下,按具体情形重载</remarks>
         Public   Overridable   ReadOnly   Property  DefaultFilePath()  As   String
             Get
                 Return  System.Environment.GetFolderPath(Environment.SpecialFolder.MyDocuments)
             End   Get
         End Property

         ' '' <summary>
         ' '' 稍停数秒
         ' '' </summary>
         ' '' <param name="seconds">秒数</param>
         ' '' <remarks></remarks>
         Protected   Sub  WaitingSeconds( ByVal  seconds  As   Integer )
             Dim  tmpNow  As   Date   =  Now
             While  Now.Subtract(tmpNow).Seconds  <  seconds
                Windows.Forms.Application.DoEvents()
             End   While
         End Sub

     End Class
End Namespace

ComObjReleaseMethod.vb

Namespace  uOffice
     Friend   Class  ComObjReleaseMethod

         Friend   Shared   Sub  Invoke( ByVal  comObj  As   Object ,  ByVal  methodName  As   String ,  ByVal  parameters()  As   Object )
             Dim  mMethod  As  Reflection.MethodInfo  =  comObj.GetType.GetMethod(methodName)
            mMethod.Invoke(comObj, parameters)
         End Sub

         Friend   Shared   Sub  ReleaseComObject( ByVal  comObj  As   Object )
            System.Runtime.InteropServices.Marshal.ReleaseComObject(comObj)
            comObj  =   Nothing
         End Sub

         Friend   Shared   Sub  KillProcess( ByVal  comObjProcessName  As   String ,  ByVal  beforeProcessStartTime  As   Date ,  ByVal  afterProcessStartTime  As   Date )

             Dim  mProcessList  As  Process()
             Dim  mProcessStartTime  As   Date

            mProcessList  =  Process.GetProcessesByName(comObjProcessName)

             For   Each  tmpProcess  As  Process  In  mProcessList
                mProcessStartTime  =  tmpProcess.StartTime
                 If  mProcessStartTime.CompareTo(beforeProcessStartTime)  >   0   AndAlso  mProcessStartTime.CompareTo(afterProcessStartTime)  <   0   Then
                    tmpProcess.Kill()
                 End   If
             Next

         End Sub

         Friend   Shared   Sub  KillProcess( ByVal  comObjProcessName  As   String ,  ByVal  beforeProcessStartTime  As   Date ,  ByVal  afterProcessStartTime  As   Date ,  ByVal  Server  As   String )
             ' 暂只支持本地
             If  Server  =   ""   Then
                KillProcess(comObjProcessName, beforeProcessStartTime, afterProcessStartTime)
             Else

             End   If

         End Sub

         Friend   Shared   Sub  KillProcess( ByVal  comObjProcessName  As   String )

             Dim  mProcessList  As  Process()

            mProcessList  =  Process.GetProcessesByName(comObjProcessName)

             For   Each  tmpProcess  As  Process  In  mProcessList
                tmpProcess.Kill()
             Next

         End Sub

     End Class
End Namespace

相应的，有关的AccessApplication文件修改如下：

Namespace  uOffice
     Public   Class  AccessApplication
         Inherits  ApplicationBase

         Protected   Overrides   Sub  SaveDefaultPropertiesWhenApplicationInitialize()

         End Sub

         Protected   Overrides   Sub  ResetDefaultPropertiesBeforeApplicationRelease()

         End Sub

         Protected   Overrides   Sub  RealseInternalComObjectsBeforeApplicationRelease()

         End Sub

         Sub   New ()
             Me .CreateInstance(ApplicationEnum.Access,  "" )
         End Sub

         Sub   New ( ByVal  server  As   String )
             Me .CreateInstance(ApplicationEnum.Access, server)
         End Sub

         Private   Function  CurrentApplication()  As  Microsoft.Office.Interop.Access.Application
             Return   DirectCast ( Me .gApplicationObject, Microsoft.Office.Interop.Access.Application)
             ' Return Me.gApplicationObject
         End Function

     End Class
End Namespace

为实现Access数据库的生成、修理压缩和版本转换，增加了以下文件。
AccessApplicationCommon.vb

Namespace  uOffice
    Partial  Public   Class  AccessApplication

         ' '' <summary>
         ' '' 默认数据库路径
         ' '' </summary>
         Public   Overrides   ReadOnly   Property  DefaultFilePath()  As   String
             Get
                 ' 以下的字串是Default Database Directory
                 Return   Me .CurrentApplication.GetOption(SR.GetString( " Office_Access_Default_Database_Directory " )).ToString
             End   Get
         End Property

         ' 取数据库文件全名
         Private   Function  FullFileName( ByVal  file  As   String )  As   String
             Dim  mFullfilename  As   String   =  file.Trim

             If  mFullfilename  =   ""   Then   Return   ""

             If  mFullfilename.IndexOf( " \ " )  =   - 1   Then   ' 默认目录上
                mFullfilename  =   Me .DefaultFilePath  &  mFullfilename
             End   If

             Dim  filename  As   String   =  mFullfilename.Substring(mFullfilename.LastIndexOf( " \ " )  +   1 )  ' 取文件名称,检查是否有后缀,没有加上.mdb
             If  filename.IndexOf( " . " )  =   - 1   Then
                mFullfilename  &=   " .mdb "
             End   If

             Return  mFullfilename
         End Function

     End Class
End Namespace

AcFileFormatEnum.vb

Namespace  uOffice

     Public   Enum  AcFileFormatEnum
        Access2  =   2
        Access2000  =   9
        Access2002  =   10
        Access95  =   7
        Access97  =   8
     End Enum

End Namespace

这部分功能实现的主文件
AccessApplicationDatabase.vb

Option   Strict   Off

Namespace  uOffice
    Partial  Public   Class  AccessApplication

         ' '' <summary>
         ' '' 关闭当前数据库
         ' '' </summary>
         Public   Sub  CloseCurrentDatabase()
             If   Me .CurrentApplication.CurrentDb IsNot  Nothing   Then
                 Me .CurrentApplication.CloseCurrentDatabase()
             End   If

             ' 停1秒后执行
            WaitingSeconds( 1 )

         End Sub

         ' '' <summary>
         ' '' 删除数据库
         ' '' </summary>
         ' '' <param name="file">数据库文件名</param>
         Public   Sub  DeleteDatabase( ByVal  file  As   String )
            file  =  FullFileName(file).ToLower

             If   Not  IO.File.Exists(file)  Then   Exit Sub

             ' 如果它是当前打开的数据库，则要关闭
             If   Me .CurrentApplication.CurrentDb IsNot  Nothing   AndAlso  IO.File.Equals(file,  Me .CurrentApplication.CurrentDb.Name.ToLower)  Then
                 Me .CloseCurrentDatabase()
             End   If

            IO.File.Delete(file)

             ' 停1秒后执行
            WaitingSeconds( 1 )
         End Sub

         ' '' <summary>
         ' '' 打开数据库
         ' '' </summary>
         ' '' <param name="file">数据库文件名</param>
         ' '' <param name="exclusive">独占打开</param>
         ' '' <param name="password">密码</param>
         ' '' <remarks></remarks>
         Public   Sub  OpenCurrentDatabase( ByVal  file  As   String ,  ByVal  exclusive  As   Boolean ,  ByVal  password  As   String )
            file  =  FullFileName(file)

             If   Not  IO.File.Exists(file)  Then   Exit Sub

             ' 关闭当前数据库
            CloseCurrentDatabase()

             Me .CurrentApplication.OpenCurrentDatabase(file, exclusive, password)

         End Sub

         ' '' <summary>
         ' '' 共享打开数据库，空密码
         ' '' </summary>
         ' '' <param name="file">数据库文件名</param>
         ' '' <remarks></remarks>
         Public   Sub  OpenCurrentDatabase( ByVal  file  As   String )

             Me .OpenCurrentDatabase(file,  False ,  "" )

         End Sub

         ' '' <summary>
         ' '' 创建数据库
         ' '' </summary>
         ' '' <param name="file">数据库文件名.如果网络支持，也可以按以下形式指定网络路径：\\Server\Share\Folder\Filename</param>
         ' '' <remarks>若已存在相同文件的数据库，则被删除</remarks>
         Public   Sub  CreateDatabase( ByVal  file  As   String )
            file  =  FullFileName(file).ToLower

             ' 若已存在，则删除
            DeleteDatabase(file)

             ' 关闭当前数据库
             Me .CloseCurrentDatabase()

             ' 生成新数据库并给置为当前数据库
             Me .CurrentApplication.NewCurrentDatabase(file)
         End Sub

         ' '' <summary>
         ' '' 压缩和修复指定的数据库
         ' '' </summary>
         ' '' <param name="SourceFile">要压缩和修复的数据库或项目文件的完整路径和文件名</param>
         ' '' <param name="DestinationFile">完整的路径和文件名，代表所返回文件的保存位置</param>
         ' '' <returns>如果处理成功，返回 True</returns>
         ' '' <remarks></remarks>
         Public   Function  RepairDatabase( ByVal  SourceFile  As   String ,  ByVal  DestinationFile  As   String )  As   Boolean

            SourceFile  =  FullFileName(SourceFile)
            DestinationFile  =  FullFileName(DestinationFile)

             ' 如果要处理的数据库为当前打开的数据库，则要关闭
             If   Me .CurrentApplication.CurrentDb IsNot  Nothing   AndAlso   Me .CurrentApplication.CurrentDb.Name.ToLower.Equals(SourceFile.ToLower)  Then
                 Me .CloseCurrentDatabase()
             End   If

             ' 如果目的文件存在，则删除
             If  IO.File.Exists(DestinationFile)  Then  IO.File.Delete(DestinationFile)

             ' 滞1秒后执行
            WaitingSeconds( 1 )

             Return   Me .CurrentApplication.CompactRepair(SourceFile, DestinationFile,  True )
         End Function

         ' '' <summary>
         ' '' 转换版本
         ' '' </summary>
         ' '' <param name="SourceFile">待转换的文件名称</param>
         ' '' <param name="DestinationFile">转换后的文件名称</param>
         ' '' <param name="DestinationFileFormat">转换后的文件版本</param>
         ' '' <remarks>并非所有版本都能转换成功</remarks>
         Public   Sub  ConvertAccessProject( ByVal  SourceFile  As   String ,  ByVal  DestinationFile  As   String ,  ByVal  DestinationFileFormat  As  AcFileFormatEnum)
            SourceFile  =  FullFileName(SourceFile)
            DestinationFile  =  FullFileName(DestinationFile)

             Me .CurrentApplication.ConvertAccessProject(SourceFile, DestinationFile, DestinationFileFormat)
         End Sub

     End Class
End Namespace

至于其它功能，比如设密码、建用户组，可以参考Access、Dao的帮助文档，并辅以Reflector来做。我不再写这部分的代码了。
至于一些关键参数，比如Default Database Directory是怎么知道的，我是查了注册表。我手头的资料也非常的有限。

对于Access，如何取表，建立和修改表，这部分可以用Sql语句实现了，可以脱离Access.Application来做。当然，上面的部分，可以用别的方法来实现，我只是提供了在Access环境下的一种实现方法。