我有个asp的,你改改就可以在vb下用了!
------------------------------------------
<% Const Jet_Conn_Partial = "Provider=Microsoft.Jet.OLEDB.4.0; Data source="
Dim strDatabase, strFolder, strFileName'#################################################
'# Edit the following two lines
'# Define the full path to where your database is
strFolder = "F:\InetPub\wwwroot\_db\"
'# Enter the name of the database
strDatabase = "YourAccessDatabase.mdb"
'# Stop editing here
'##################################################Private Sub dbCompact(strDBFileName)
Dim SourceConn
Dim DestConn
Dim oJetEngine
Dim oFSOSourceConn = Jet_Conn_Partial & strFolder & strDatabase
DestConn = Jet_Conn_Partial & strFolder & "Temp" & strDatabaseSet oFSO = Server.CreateObject("Scripting.FileSystemObject")
Set oJetEngine = Server.CreateObject("JRO.JetEngine")With oFSOIf Not .FileExists(strFolder & strDatabase) Then
Response.Write ("Not Found: " & strFolder & strDatabase)
Stop
Else
If .FileExists(strFolder & "Temp" & strDatabase) Then
Response.Write ("Something went wrong last time " _
& "Deleting old database... Please try again")
.DeleteFile (strFolder & "Temp" & strDatabase)
End If
End If
End WithWith oJetEngine
.CompactDatabase SourceConn, DestConn
End WithoFSO.DeleteFile strFolder & strDatabase
oFSO.MoveFile strFolder & "Temp" _
& strDatabase, strFolder& strDatabaseSet oFSO = Nothing
Set oJetEngine = Nothing
End SubPrivate Sub dbList()
Dim oFolders
Set oFolders = Server.CreateObject("Scripting.FileSystemObject")
Response.Write ("<Select Name=""DBFileName"">")
For Each Item In oFolders.GetFolder(strFolder).Files
If LCase(Right(Item, 4)) = ".mdb" Then
Response.Write ("<Option Value=""" & Replace(Item, strFolder, "") _
& """>" & Replace(Item, strFolder, "") & "</Option>")
End If
Next
Response.Write ("</Select>")Set oFolders = Nothing
End Sub
%>
<%
' Compact database and tell the user the database is optimized
Select Case Request.form("cmd")
Case "Compact"
dbCompact Request.form("DBFileName")
Response.Write ("Database " & Request.form("DBFileName") & " is optimized.")
End Select
%><p><font size="4">Compact and repair database</font></p>
<form method="POST" action="">
<p><%dbList%><input type="submit" value="Compact" name="cmd"></p>
</form>
------------------------------------------
<% Const Jet_Conn_Partial = "Provider=Microsoft.Jet.OLEDB.4.0; Data source="
Dim strDatabase, strFolder, strFileName'#################################################
'# Edit the following two lines
'# Define the full path to where your database is
strFolder = "F:\InetPub\wwwroot\_db\"
'# Enter the name of the database
strDatabase = "YourAccessDatabase.mdb"
'# Stop editing here
'##################################################Private Sub dbCompact(strDBFileName)
Dim SourceConn
Dim DestConn
Dim oJetEngine
Dim oFSOSourceConn = Jet_Conn_Partial & strFolder & strDatabase
DestConn = Jet_Conn_Partial & strFolder & "Temp" & strDatabaseSet oFSO = Server.CreateObject("Scripting.FileSystemObject")
Set oJetEngine = Server.CreateObject("JRO.JetEngine")With oFSOIf Not .FileExists(strFolder & strDatabase) Then
Response.Write ("Not Found: " & strFolder & strDatabase)
Stop
Else
If .FileExists(strFolder & "Temp" & strDatabase) Then
Response.Write ("Something went wrong last time " _
& "Deleting old database... Please try again")
.DeleteFile (strFolder & "Temp" & strDatabase)
End If
End If
End WithWith oJetEngine
.CompactDatabase SourceConn, DestConn
End WithoFSO.DeleteFile strFolder & strDatabase
oFSO.MoveFile strFolder & "Temp" _
& strDatabase, strFolder& strDatabaseSet oFSO = Nothing
Set oJetEngine = Nothing
End SubPrivate Sub dbList()
Dim oFolders
Set oFolders = Server.CreateObject("Scripting.FileSystemObject")
Response.Write ("<Select Name=""DBFileName"">")
For Each Item In oFolders.GetFolder(strFolder).Files
If LCase(Right(Item, 4)) = ".mdb" Then
Response.Write ("<Option Value=""" & Replace(Item, strFolder, "") _
& """>" & Replace(Item, strFolder, "") & "</Option>")
End If
Next
Response.Write ("</Select>")Set oFolders = Nothing
End Sub
%>
<%
' Compact database and tell the user the database is optimized
Select Case Request.form("cmd")
Case "Compact"
dbCompact Request.form("DBFileName")
Response.Write ("Database " & Request.form("DBFileName") & " is optimized.")
End Select
%><p><font size="4">Compact and repair database</font></p>
<form method="POST" action="">
<p><%dbList%><input type="submit" value="Compact" name="cmd"></p>
</form>
解决方案 »
- 求救:VB操作EXCEL出现DISPLAYALERTS的APPLICATION方法失败!
- VB如何清除一个结构?
- 卸载图标出现了,但是桌面图标没有出现?~?~~重新编译Setup1.Exe时出错~!!!提示gstrDIR_DEST变量未定义!!
- 怎么样把打开的记录集都关掉!急啊!
- 请问怎样让光标自动定位?
- 怎样利用Internet Transfer控件向一个网页中的表单提交数据?
- 求助!!!!
- 数据表中的字符匹配
- win98下面如何访问win2000的文件夹的文件(急)
- 什么叫SAPI,TAPI啊???
- 简单的问题……………送分了快来***
- 在access数据库中如何使用VB保存图片?拜托!!!
版本:VB6 以前使用 DAO 時,Microsoft 有提供 CompactDatabase Method 來压缩 Microsoft Access 文件,RepairDatabase Method 來修复损坏的 Microsoft Access 文件,。可是自从 ADO 出來之后,好像忘了提供相对的压缩及修复 Microsoft Access 文件的功能。現在 Microsoft 发现了这个问题了,也提供了解決方法,不过有版本上的限制!限制說明如下:ActiveX Data Objects (ADO), version 2.1
Microsoft OLE DB Provider for Jet, version 4.0 這是 Microsoft 提出的 ADO 的延伸功能:Microsoft Jet OLE DB Provider and Replication Objects (JRO)这个功能在 JET OLE DB Provider version 4.0 (Msjetoledb40.dll) 及 JRO version 2.1 (Msjro.dll) 中第一次被提出!
這些必要的 DLL 文件在您安裝了 MDAC 2.1 之后就有了,您可以在以下的网页中下载 MDAC 的最新版本!Universal Data Access Web Site在下载之前先到 VB6 中檢查一下,【控件】【設定引用項目】中的 Microsoft Jet and Replication Objects X.X library 如果已经是 2.1 以上的版本,您就可以不用下载了!在您安裝了 MDAC 2.1 或以上的版本之后,您就可以使用 ADO 來压缩或修复 Microsoft Access 文件,下面的步骤告訴您如何使用 CompactDatabase Method 來压缩 Microsoft Access 文件:1、新建一個新表单,选择功能表中的【控件】【設定引用項目】。
2、加入 Microsoft Jet and Replication Objects X.X library,其中 ( X.X 大于或等于 2.1 )。
3、在适当的地方加入以下的程序代码,記得要修改 data source 的內容及目地文件的路径:Dim jro As jro.JetEngine
Set jro = New jro.JetEngine
jro.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=d:\\nwind2.mdb", _ '來源文件
"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=d:\\abbc2.mdb;Jet OLEDB:Engine Type=4" '目的文件在 DAO 3.60 之后,RepairDatabase Method 已经无法使用了,以上的程序代码显示了 ADO CompactDatabase Method 的用法,而它也取代了 DAO 3.5 時的 RepairDatabase method!
Function RepairDB(dbName As String) As Boolean
'修复数据库
On Error Resume Next
RepairDatabase dbName
If Err <> 0 Then RepairDB = True
End FunctionFunction CompactDB(dbName As String, pwd As String) As Boolean
'修复数据库,要压缩的数据库必须是关闭的。
On Error GoTo ErrHandle
If pwd <> "" Then pws = ";pwd=" & pwd
Name dbName As "bak" & dbName
CompactDatabase "bak" & dbName, dbName, pwd, , pwd
Kill "bak" & dbName
CompactDB = True
Exit Function
ErrHandle:
CompactDB = False
End Function