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环境下的一种实现方法。
