标签：压缩 - flyinweb's blog

标签：压缩
<%   
'#######以下是一个类文件，下面的注解是调用类的方法################################################   
'# 注意：如果系统不支持建立Scripting.FileSystemObject对象，那么数据库压缩功能将无法使用   
'# Access 数据库类   
'# CreateDbFile 建立一个Access 数据库文件   
'# CompactDatabase 压缩一个Access 数据库文件   
'# 建立对象方法:   
'# Set a = New DatabaseTools   
'# by (萧寒雪) s.f.   
'#########################################################################################   
 
Class DatabaseTools   
 
    Public function CreateDBfile(byVal dbFileName,byVal DbVer,byVal SavePath)   
        '建立数据库文件   
        'If DbVer is 0 Then Create Access97 dbFile   
        'If DbVer is 1 Then Create Access2000 dbFile   
        On error resume Next   
        If Right(SavePath,1)<>"\" Or Right(SavePath,1)<>"/" Then SavePath = Trim(SavePath) & "\"   
        If Left(dbFileName,1)="\" Or Left(dbFileName,1)="/" Then dbFileName = Trim(Mid(dbFileName,2,Len(dbFileName)))   
        If DbExists(SavePath & dbFileName) Then   
            Response.Write ("对不起，该数据库已经存在!")   
            CreateDBfile = False   
        Else   
            Dim Ca   
            Set Ca = Server.CreateObject("ADOX.Catalog")   
            If Err.number<>0 Then   
                Response.Write ("无法建立，请检查错误信息  
                " & Err.number & " 
                " & Err.Description)   
                Err.Clear   
                Exit function   
            End If   
            If DbVer=0 Then   
                call Ca.Create("Provider=Microsoft.Jet.OLEDB.3.51;Data Source=" & SavePath & dbFileName)   
            Else   
                call Ca.Create("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & SavePath & dbFileName)   
            End If   
            Set Ca = Nothing   
            CreateDBfile = True   
        End If   
    End function   
 
    Public function CompactDatabase(byVal dbFileName,byVal DbVer,byVal SavePath)   
        '压缩数据库文件   
        '0 为access 97   
        '1 为access 2000   
        On Error resume next   
        If Right(SavePath,1)<>"\" Or Right(SavePath,1)<>"/" Then SavePath = Trim(SavePath) & "\"   
        If Left(dbFileName,1)="\" Or Left(dbFileName,1)="/" Then dbFileName = Trim(Mid(dbFileName,2,Len(dbFileName)))   
        If DbExists(SavePath & dbFileName) Then   
            Response.Write ("对不起，该数据库已经存在!")   
            CompactDatabase = False   
        Else   
            Dim Cd   
            Set Cd =Server.CreateObject("JRO.JetEngine")   
            If Err.number<>0 Then   
                Response.Write ("无法压缩，请检查错误信息  
                " & Err.number & " 
                " & Err.Description)   
                Err.Clear   
                Exit function   
            End If   
            If DbVer=0 Then   
                call Cd.CompactDatabase("Provider=Microsoft.Jet.OLEDB.3.51;Data Source=" & SavePath & dbFileName,"Provider=Microsoft.Jet.OLEDB.3.51;Data   
                Source=" & SavePath & dbFileName & ".bak.mdb;Jet OLEDB;Encrypt Database=True")   
            Else   
                call Cd.CompactDatabase("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" &   
                SavePath & dbFileName,"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" &   
                SavePath & dbFileName & ".bak.mdb;Jet OLEDB;Encrypt Database=True")   
            End If   
            '删除旧的数据库文件   
            call DeleteFile(SavePath & dbFileName)   
            '将压缩后的数据库文件还原   
            call RenameFile(SavePath & dbFileName & ".bak.mdb",SavePath & dbFileName)   
            Set Cd = False   
            CompactDatabase = True   
        End If   
    end function   
 
    Public function DbExists(byVal dbPath)   
        '查找数据库文件是否存在   
        On Error resume Next   
        Dim c   
        Set c = Server.CreateObject("ADODB.Connection")   
        c.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbPath   
        If Err.number<>0 Then   
            Err.Clear   
            DbExists = false   
        else   
            DbExists = True   
        End If   
        set c = nothing   
    End function   
 
    Public function AppPath()   
        '取当前真实路径   
        AppPath = Server.MapPath("./")   
    End function   
 
    Public function AppName()   
        '取当前程序名称   
        AppName = Mid(Request.ServerVariables("SCRIPT_NAME"),(InStrRev(Request.ServerVariables("SCRIPT_NAME") ,"/",-1,1))+1,Len(Request.ServerVariables("SCRIPT_NAME")))   
    End Function   
 
    Public function DeleteFile(filespec)   
        '删除一个文件   
        Dim fso   
        Set fso = CreateObject("Scripting.FileSystemObject")   
        If Err.number<>0 Then   
        Response.Write("删除文件发生错误!请查看错误信息  
        " & Err.number & " 
        " & Err.Description)   
        Err.Clear   
        DeleteFile = False   
        End If   
        call fso.DeleteFile(filespec)   
        Set fso = Nothing   
        DeleteFile = True   
    End function   
 
    Public function RenameFile(filespec1,filespec2)   
        '修改一个文件   
        Dim fso   
        Set fso = CreateObject("Scripting.FileSystemObject")   
        If Err.number<>0 Then   
        Response.Write("修改文件名时发生错误!请查看错误信息  
        " & Err.number & " 
        " & Err.Description)   
        Err.Clear   
        RenameFile = False   
        End If   
        call fso.CopyFile(filespec1,filespec2,True)   
        call fso.DeleteFile(filespec1)   
        Set fso = Nothing   
        RenameFile = True   
    End function   
 
End Class   
%>   
 
 现在已可以压缩有密码的数据库，代码如下，但是压缩之后的数据库密码就没有了！如何解决？  
 
<%  
Const JET_3X = 4  
 
Function CompactDB(dbPath, boolIs97)  
    Dim fso, Engine, strDBPath  
    strDBPath = left(dbPath,instrrev(DBPath,"\"))  
    Set fso = CreateObject("Scripting.FileSystemObject")  
 
    If fso.FileExists(dbPath) Then      
        Set Engine = CreateObject("JRO.JetEngine")  
 
        If boolIs97 = "True" Then 
            Engine.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbpath, _  
            "Provider=Microsoft.Jet.OLEDB.4.0;Jet OLEDB:Database Password='XXXXXXXX';Data Source=" & strDBPath & "temp.mdb;" _  
            & "Jet OLEDB:Engine Type=" & JET_3X  
        Else 
        Engine.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Jet OLEDB:Database Password='XXXXXXXX';Data Source=" & dbpath, _  
        "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strDBPath & "temp.mdb" 
        End If 
 
        fso.CopyFile strDBPath & "temp.mdb",dbpath  
        fso.DeleteFile(strDBPath & "temp.mdb")  
        Set fso = nothing  
        Set Engine = nothing  
 
        CompactDB = "你的数据库, " & dbpath & ", 已经压缩成功!" & vbCrLf  
 
    Else 
        CompactDB = "数据库名称或路径不正确. 请重试!" & vbCrLf  
    End If 
 
End Function 
%>