VB uses ADOX compression to repair class modules of Access Database Files

 

Option explicit '//*********************************** * ********************************** '/class module name: clscompactdatabase '// All Rights Reserved: mitmeter Co., Ltd.' // developer: Lee '// QQ: 14035344 '// http://www.duanliqing.kudo.cn' // http://leek.woku.com '// creation date: 2010-07-28' // Function Description: process database file backup '// Note: Reference Microsoft Jet and replication objects X. X library, where (X. X is greater than or equal to 2.1 ). '//************************************* * *********************************** Temporary Folder path of the system private declare function gettemppath lib "Kernel32" alias _ "gettemppatha" (byval nbufferlength as long, byval lpbuffer as string) as longprivate sub errmessage (byval procedure as string, _ optional byval afferrmsg as string) ''===================================================== ========================== 'developer: duan Liqing 'compilation time :' Program name: errmessage parameter description: procedure process or function name 'optional parameter: afferrmsg additional description error message prompt text' Function Description: error messages used in the class module, feature to easily Track Error Sources ====================== dim strmsg as string strmsg = strmsg &" errnumber: "& err. number & vbcrlf strmsg = strmsg & "errdescription:" & err. description & vbcrlf if Len (afferrmsg) <> 0 then strmsg = strmsg & "afferrmsg:" & afferrmsg & Vbcrlf end if '* empty line strmsg = strmsg & "" & vbcrlf' * class module name strmsg = strmsg & "module: "&" clsbin "& vbcrlf strmsg = strmsg &" procedure: "& procedure & vbcrlf '* a blank line strmsg = strmsg &" & vbcrlf strmsg = strmsg & "Please required y my software's tech support" & vbcrlf strmsg = strmsg & "at QQ: 14035344 about this issue. "& vbcrlf strmsg = strmsg &" Please e-mail to lee_software@sohu.com.cn "& Vbcrlf strmsg = strmsg & "Please provide the Support Technician with" & vbcrlf strmsg = strmsg & "information shown in this dialog" & vbcrlf strmsg = strmsg & "box as well as an explanation what you were "& vbcrlf strmsg = strmsg &" doing when this error occurred. "& vbcrlf msgbox strmsg, vbcritical," clscompactdatabase "Err. clear end sub '* obtain the path to the temporary system folder' * only use the private function subgettemporar for the compressed Database Ypath () const max_path = 260 dim strfolder as string dim lngresult as long strfolder = string (max_path, 0) lngresult = gettemppath (max_path, strfolder) if lngresult <> 0 then subgettemporarypath = left (strfolder, instr (strfolder, CHR (0)-1) else subgettemporarypath = "" End ifend functionpublic sub subcompjetactdatabase (location as string, optional backuporiginal as Boolean = true) ''============ ========================================================== ====== 'Developer: duan Liqing 'writing time: 'process name: subcompactjetdatabase' parameter description: Location database file directory 'backup database required?' Function Description: Compressed database, removing the database operation takes longer than 'note: the <dbengine> Object ''================================ of Dao must be applied. ======================== on error goto compacterr dim strbackupfile as string dim strtempfile as string 'Check whether the database file exists if Len (Dir (location )) then' if a backup is required, perform the backup if Backuporiginal = true then strbackupfile = subgettemporarypath & "backup. mdb "If Len (Dir (strbackupfile) then kill strbackupfile filecopy location, strbackupfile end if 'create temporary file name strtempfile = subgettemporarypath &" temp. mdb "If Len (Dir (strtempfile) then kill strtempfile dim jro as jro. jetengine set jro = new jro. jetengine 'to the source file jro. compactdatabase "provider = Microsoft. jet. oledb.4.0; Data Source =" & Location & "; Jet oledb: Database Password = Duan", _ "provider = Microsoft. jet. oledb.4.0; Data Source = "& strtempfile" compressed to generate tempdb. MDB 'delete the original database file kill location' copy the temporary database file that has just been compressed to the original location filecopy strtempfile, location' Delete the temporary file kill strtempfile else end if msgbox "the database has been compressed! ", Vbokonly + vbexclamationexit subcompacterr: dim safferrmsg as string safferrmsg =" the database cannot be compressed when it is opened! Please exit the program and try again! "Call errmessage (" subcompactjetdatabase ", safferrmsg) end sub

Programming: Lee QQ; 14035344