[分享]学以致用，改造后对后台数据库压缩及重定义

fannky

今天上夜班，花了两个小时弄明白了两件事：

1、压缩后台数据库 ，经改进可以同时压缩多个后台连接数据库

2、更新后台数据库

兴奋之余，也拿来与大家分享分享。原理来源于此站，我只是按我所需进行了扩展，相信有朋友可以用得上哦

大家给点掌声萨~~斑竹来点奖励萨~~~

Private Sub 开始压缩_Click()
Dim StrFTemp As String
Dim StrFName As String
Dim Lstar As Long, Lend As Long
''''''''''''''''''''''''
Dim rst As ADODB.Recordset
Dim StrSql As String
Set rst = New ADODB.Recordset
StrSql = "select database from MSysObjects group by database HAVING (((database)<>''))"
rst.Open StrSql, CurrentProject.Connection, adOpenStatic
If rst.RecordCount > 0 Then
Do While Not rst.EOF
StrFName = rst("database")
StrFTemp = "d:\temp001.mdb"    '可在此处稍加修改，保存临时文件与源文件名相对应
If Dir(StrFTemp) <> "" Then Kill StrFTemp
If Dir(StrFName) <> "" Then Name StrFName As StrFTemp Else MsgBox StrFName & "不存在，无法进行压缩！"
DBEngine.CompactDatabase StrFTemp, StrFName
Kill Strftemp       '如果为了防止压缩失败，可保留对应的临时文件

MsgBox "已经成功压缩" & StrFName

rst.MoveNext
Loop
End If
''''''''''''''''''''''''
End Sub

'======================================================

以下为更新后台连接数据库

Public Function CheckLinks() As Boolean
' 检查到后台数据库的链接；如果链接存在且正确的话，返回 True 。
    Dim dbs As Database, rst As DAO.Recordset
    Set dbs = CurrentDb()
    ' 打开链接表查看表链接信息是否正确。
    On Error Resume Next
    Set rst = dbs.OpenRecordset("BaseData")
    rst.Close
    ' 如果没有错误，返回 True 。
    If Err = 0 Then
        CheckLinks = True
    Else
        CheckLinks = False
    End If
End Function

Private Sub Form_load()
If CheckLinks = False Then
MsgBox "本地后台数据库错误,需要重新设定数据源", vbInformation + vbOKOnly, "系统:严重错误"
On Error GoTo link_Err
'删除原有连接表
Dim rst As ADODB.Recordset
Dim StrSql As String
Set rst = New ADODB.Recordset
StrSql = "select * from MSysObjects where database<>''"
rst.Open StrSql, CurrentProject.Connection, adOpenStatic
If rst.RecordCount > 0 Then
Do While Not rst.EOF
DoCmd.DeleteObject acTable, rst("name")
rst.MoveNext
Loop
Else
Resume ReferLink
End If
'删除原有连接表'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''End
ReferLink:
DoCmd.RunCommand acCmdLinkTables ' 打开链接表管理器

link_Exit:
    Exit Sub

link_Err:
        MsgBox "用户取消了和服务器上后台表的连接", , "系统消息..."
         
          Resume link_Exit
End If

End Sub

[此贴子已经被作者于2007-1-20 5:55:04编辑过]

yinwenjun

学习研究

bpchan

学习！！！

DABEN

在学习谢

DABEN

问2003正在连接的数据库不能改名和压缩要如何解决？？

chenyingfengsx

学习哦