Compacting MS Access in Code

jhai_salvador 3 2K Views

Hi!

This is my submission for code snippet contest.
I also posted this code to help other members on how they can use compact & repair their MS Access Database within Visual Basic 6.0.

You also need to add Microsoft Jet and Replication 2.6 in your project reference.

To use, add the snippet in Module;

Once you have added it to the module just call CompactAccess with database location and its password like this;

Call CompactAccess("C:\Database.mdb", "12345")

I also attached a sample project on how you can use it, just check it out.

Click Here

Please note that the database should be close before compacting it, else it will not work.

Thanks,

Compacting_Database.zip (4.19 KB)
Dani commented: Good luck! +0
AndreRet commented: Nice Snippet Jhai +12 
'Database type
'MS Access Version
'MSAccess2000 = *.mdb (version 2000 - 2003)
'MSAccess2007 = *.accdb (version 2007)
Public Enum enumDatabaseType
   [MSAccess2000]
   [MSAccess2007]
End Enum

'--------------------------------------------------------------------------------
' Project    :       prjCompactAccess
' Procedure  :       CompactAccess
' Description:       This procedure is use to compact & repair ms access database
' 					 Compact & Repair function of MS Access will perform a routine 
'					 maintenance on the database to ensure database integrity.
'
' Parameters :       xDatabaseLocation (String)
'                    xDatabasePassword (String)
'                    DatabaseType (enumDatabaseType = MSAccess2000)
'--------------------------------------------------------------------------------

Public Function CompactAccess(xDatabaseLocation As String, _
                              Optional xDatabasePassword As String, _
                              Optional DatabaseType As enumDatabaseType = MSAccess2000) As Boolean

      'Microsoft Jet and Replecation 2.6
      '<EhHeader>
      On Error GoTo CompactAccess_Err

      '</EhHeader>
   
10    Dim JRO        As New JetEngine, SourceCon1 As String, SourceCon2 As String

12    Dim SourcePath As String, DesPath As String

14    SourcePath = xDatabaseLocation

16    If DatabaseType = MSAccess2000 Then
18       DesPath = App.Path & "\Compact.mdb"
20       SourceCon1 = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & SourcePath & ";Jet OLEDB:Database Password=" & xDatabasePassword & ";"
22       SourceCon2 = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DesPath & ";Jet OLEDB:Database Password=" & xDatabasePassword & ";"
24    ElseIf DatabaseType = MSAccess2007 Then
26       DesPath = App.Path & "\Compact.accdb"
28       SourceCon1 = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & SourcePath & ";Jet OLEDB:Database Password=" & xDatabasePassword & ";"
30       SourceCon2 = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & DesPath & ";Jet OLEDB:Database Password=" & xDatabasePassword & ";"
32    Else
34       MsgBox "Invalid Database or database is not yet supported with the code!", vbExclamation, "Not Supported"
36    End If

38    JRO.CompactDatabase SourceCon1, SourceCon2
40    Kill SourcePath
42    FileCopy DesPath, SourcePath
44    Kill DesPath
   
46    Set JRO = Nothing
48    CompactAccess = True

      '<EhFooter>
      Exit Function

CompactAccess_Err:
      Call prompt_err(Err, "ModDatabase", "CompactAccess")
      CompactAccess = False

      '</EhFooter>

End Function

'Procedure used to promp unexpected errors
Public Sub prompt_err(ByVal sError As ErrObject, _
                      ByVal ModuleName As String, _
                      ByVal OccurIn As String)
   
   'Dim cErr As clsErrorReport
   
   Dim s1, s2, s3, s4 As String
   Dim s5     As Long
   Dim ff     As Integer
   Dim strMsg As String
   
   s1 = ModuleName
   s2 = OccurIn
   s3 = sError.Number
   s4 = sError.Description
   
   '* Store our line # where error Occured (always 0 when line # is not use)
   s5 = Erl
   
   If s5 <> 0 Then
      strMsg = "An Unexpected Error has Occured in " & App.ProductName & " (Build " & App.Major & "." & App.Minor & "." & App.Revision & ")" & "." & vbCrLf & vbCrLf & "Please report this problem by contacting the author so it can be resolved." & vbCrLf & vbCrLf & "Technical Information:" & vbCrLf & "Error ID: " & Err.Number & vbCrLf & "Description: " & Err.Description & vbCrLf & "Module: " & ModuleName & vbCrLf & "Function: " & OccurIn & vbCrLf & vbCrLf & "Line Number: " & s5 & vbCrLf & vbCrLf & "Press Ctrl + C to copy this information to the clipboard"
   Else
      strMsg = "An Unexpected Error has Occured in " & App.ProductName & " (Build " & App.Major & "." & App.Minor & "." & App.Revision & ")" & "." & vbCrLf & vbCrLf & "Please report this problem by contacting the author so it can be resolved." & vbCrLf & vbCrLf & "Technical Information:" & vbCrLf & "Error ID: " & Err.Number & vbCrLf & "Description: " & Err.Description & vbCrLf & "Module: " & ModuleName & vbCrLf & "Function: " & OccurIn & vbCrLf & vbCrLf & "Press Ctrl + C to copy this information to the clipboard"
   End If

   MsgBox strMsg, vbExclamation, App.ProductName & ": Unexpected Error"

End Sub
Member Avatar for pritaeas
pritaeas 2,194 ¯\_(ツ)_/¯

Just a note, s1 through s4 and ff are declared (and assigned) but never used.

Edited by pritaeas
Member Avatar for jhai_salvador
jhai_salvador 48 Junior Poster

Aw, sorry, did not notice that when i remove some codes in prompt_err function.

Anyway, you can just ignore it since the code that im really sharing is CompactAccess function.

My other code snipped about prompt_err function can be seen here: http://www.daniweb.com/software-development/visual-basic-4-5-6/code/336042/easy-code-debugging-prompt_err-function

Thanks,

Be a part of the DaniWeb community

We're a friendly, industry-focused community of developers, IT pros, digital marketers, and technology enthusiasts meeting, networking, learning, and sharing knowledge.

Edit Preview