Access 2003 - Code to turn OFF Db compress 1

[rgbanse]

Reports run from a given Db throughout the day. Rather than compress every time, is there code to compress only when criteria is met.
thx
RGB

 

[AccessGuruCarl]

RGB,
Is the db being opened/closed each time, or does it remain open through out the day?

AccessGuruCarl
Programmers helping programmers
you can't find a better site.

 

[rgbanse]

Opens and closes every time -

 

[AccessGuruCarl]

I have three scenerio's, pick one and modify as needed or use a combination.

Paste into New Modules...

Module1-AutoCompact on Size

Option Compare Database
Option Explicit
Public Function AutoCompactCurrentProject()
'Purpose:
'What this function does is look at the file size of the app
'it’s being called from. If the file size is smaller than the
'size specified, it doesn’t compact on close, if it’s larger
'it will compact on close. I don’t know if any of you have noticed
'this before, but when I deliver an application, say, when fully
'compacted the size might be 10 Mb, after using it a few times it
'might grow to 14 Mb, but there after will only grow possibly 100 Kb
'after each session. I don’t know the reason for this, the size just
'seems to bottom out. Anyway when you’ve got this approx size that the
'file bottom’s out at, in this example 14 Mb, put in a reasonable file
'size (one that won’t put a drain on system resources) that you want to
'allow the file size to grow to.

'Usage:
'Call the Function from the procedure that closes down your app
'   AutoCompactCurrentProject
'   DoCmd.Quit

    Dim fs, f, s, filespec
    Dim strProjectPath As String, strProjectName As String
    strProjectPath = Application.CurrentProject.Path
    strProjectName = Application.CurrentProject.Name
    filespec = strProjectPath & "\" & strProjectName
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFile(filespec)
    s = CLng(f.Size / 1000000)  'convert size of app from bytes to Mb’s
    If s > 20 Then 'edit the 20 (Mb’s) to the max size you want to allow your app to grow.
        Application.SetOption ("Auto Compact"), 1  'compact app
    Else
        Application.SetOption ("Auto Compact"), 0   'no don’t compact app
    End If
End Function

Module 2 - Compact at Start of each day
Use a hidden form, loaded at start-up
Create a table with the variables mentioned below

Option Compare Database
Option Explicit

Function StartTimer()

'Form_Switchboard.TimerInterval = 3000
Form_Compact_and_Repair_at_start_of_each_day.TimerInterval = 3000

End Function

Function MaintenanceCheck()

'--------------------------------------
'- This function checks to see if the -
'- user is the first to log in today. -
'- It triggers a Compact and repair   -
'- process if this is true            -
'--------------------------------------
On Local Error GoTo MCError1

    Dim stDatabaseName As String
    Dim stLastCompacted As String
    Dim stMessage As String
    Dim stSQl As String
    Dim stTimeNow As String
    Dim stToday As String
    
    Dim intSecurityLevel As Integer
        intSecurityLevel = 0

    stToday = Format$(Now, "yyyymmdd")  'Note the yyyymmdd format
    'stLastCompacted = DLookup("[LastCompacted]", "tblControl1")
    stLastCompacted = DLookup("[datLastCompacted]", "tblControl1", "[ControlID] = 'LastCompacted'")
    stDatabaseName = DLookup("[AppName]", "tblControl1", "[ControlID] = 'LastCompacted'")

'--------------------------------------
'- Database already compacted today   -
'--------------------------------------
    If stLastCompacted >= stToday Then
        Exit Function
    End If

'--------------------------------------
'- Database compact process is        -
'- required.  Display message         -
'--------------------------------------
    stMessage = "You are the first person to use this database today." & vbCrLf & vbCrLf
    
If intSecurityLevel = 1 Then
    stMessage = stMessage & "Please ask someone with Data-entry or Administrator permissions "
    stMessage = stMessage & "to log in and run start of day maintenance."
    MsgBox stMessage, vbInformation, stDatabaseName
    Exit Function
Else
    stMessage = stMessage & "When you click [OK], start of day maintenance will take place." & vbCrLf & "Please wait ..."
    MsgBox stMessage, vbInformation, stDatabaseName

    stMessage = SysCmd(acSysCmdSetStatus, "Daily Maintenance In Progress ... Please Wait")
End If

'---------------------------------------
'- Write a log record                  -
'---------------------------------------
    'stMessage = WriteLogRecord("CompactDatabase", "MaintenanceCheck", "")
    
'---------------------------------------
'- Update the Control Table record     -
'---------------------------------------
    stSQl = "UPDATE tblControl1 SET [tblControl1].[datLastCompacted] = '" & stToday & "' WHERE [tblControl1].[ControlID] = 'LastCompacted'"
    DoCmd.SetWarnings (False)
    DoCmd.RunSQL (stSQl)
    DoCmd.SetWarnings (True)

'---------------------------------------
'- Call the CompactDatabase function.  -
'- This must be the last line of code  -
'- in the MaintenanceCheck function    -
'---------------------------------------
    CompactDatabase
Exit Function

MCError1:

MsgBox CStr(Err) & " - " & Error$
Resume MCEnd

MCEnd:
End Function

Function CompactDatabase()
'------------------------------------
'- Compact the database.  This only -
'- works if it is the only code in  -
'- the function, and if the         -
'- function is called from the last -
'- line of another VB function      -
'------------------------------------
   CommandBars("Menu Bar"). _
   Controls("Tools"). _
   Controls("Database utilities"). _
   Controls("Compact and repair database..."). _
   accDoDefaultAction

End Function

This code is for the Hidden Form

Option Compare Database
Option Explicit

Private Sub Form_Load()
    StartTimer
End Sub

Private Sub Form_Timer()
    Me.TimerInterval = 0
    MaintenanceCheck
End Sub

Module 3 - Automating Database Compaction (every 5 times Used)

Option Compare Database
Option Explicit

Public booCompactTime As Boolean
Function Autoexec()
'***************************************************************************
' Automating Database Compaction (every 5 times Used)
' *************************************************************
'Purpose:
'Comments: 1. Compiles all code in the database if it is uncompiled
' 2. Writes usage info to custom database properties
' 3. Writes usage info to the Registry
' 4. Sets flag to indicate if db is due for compacting
'***************************************************************************

On Error GoTo Autoexec_Err

Dim strModule As String
Dim strProperty As String
Dim dtLastOpened As Date
Dim db As Database
Dim pty As Property
Dim lngDBTimesOpened As Long
Dim lngProfileTimesOpened As Long
Dim intRetVal As Integer

Set db = CurrentDb

'If the db is not compiled then open a module and
'force recompilation
If Not Application.IsCompiled Then
'Display a message indicating we are compiling
DoCmd.OpenForm "frmCompile", , , , acFormReadOnly
'Turn off screen updating
Application.Echo False
'Get the name of any module
strModule = db.Containers("Modules").Documents(0).Name
'Open the module so we can use the Compile Modules menu command
DoCmd.OpenModule strModule
'Compile and save all modules
Application.RunCommand acCmdCompileAndSaveAllModules
'Set a database property to indicate last compile time
MarkCompileTime
'Give audible confirmation
Beep
'Close the module we opened
DoCmd.Close acModule, strModule
'Turn screen updating back on
Application.Echo True
'Remove the warning form
DoCmd.Close acForm, "frmCompile"
End If

'Find out how many times this particular database has been opened
IncrementTimesOpened
lngDBTimesOpened = db.Properties("TimesOpened")
'If this is the first time for this database, then show the greeting form
If lngDBTimesOpened = 1 Then
DoCmd.OpenForm "frmGreeting", , , , , acDialog
Else
'Else open the greeting form unless the user has deselected the re-view check box
If GetSetting("MWSDB", "Preferences", "StartUpDialog", True) Then
DoCmd.OpenForm "frmGreeting", , , , , acDialog
End If
End If

'Write information to the Registry to indicate usage for this user
lngProfileTimesOpened = GetSetting("MWSDB", "Statistics", "UsageCount", 1)
SaveSetting "MWSDB", "Statistics", "UsageCount", lngProfileTimesOpened + 1
SaveSetting "MWSDB", "Statistics", "LastUsed", Format$(Now(), "yyyy.mm.dd hh:nn:ss")

'And finally open the switchboard form
DoCmd.OpenForm "frmSwitchboard" ' This form would contain a cmdCompactDatabase control

Autoexec_Exit:
Exit Function

Autoexec_Err:
'Turn screen updating back on
Application.Echo True

'Now handle the error
Select Case Err.Number
Case Else
Call GlobalErr("Autoexec", Err.Number)
Resume Autoexec_Exit
Resume
End Select

End Function

Sub GlobalErr(strProcName As String, intErr As Integer)
'***************************************************************************
'Purpose: To display a message box providing details of a given error
'Parameters: strProcName - the name of the procedure calling GlobalErr
' intErr - an Error code
'Returns: Nothing
'***************************************************************************

Dim strMsg As String

strMsg = "The following error occurred in the " & strProcName & " procedure"
strMsg = strMsg & Chr$(10) & Chr$(10)
strMsg = strMsg & "Error Number: " & Format$(intErr) & Chr$(10)
strMsg = strMsg & "Error Description: " & Error$

MsgBox strMsg, 48, "Unexpected Error"

GlobalErr_Exit:
Exit Sub

End Sub

Sub MarkCompileTime()
'***************************************************************************
'Purpose: To set a db property indicating when the database was last
' programmatically compiled
'Parameters: None
'Returns: Nothing
'***************************************************************************

On Error GoTo MarkCompileTime_Err

Dim pty As Property

CurrentDb.Properties("LastCompiled") = Now

MarkCompileTime_Exit:
Exit Sub

MarkCompileTime_Err:
Select Case Err.Number
Case 3270 'Error code for "Property not found"
Set pty = CurrentDb.CreateProperty("LastCompiled", dbDate, Now())
CurrentDb.Properties.Append pty
Resume
Case Else
Call GlobalErr("MarkCompileTime", Err.Number)
Resume MarkCompileTime_Exit
Resume
End Select

End Sub

Sub IncrementTimesOpened()
'***************************************************************************
'Purpose: To set a db property indicating the number of times the
' database has been opened
'Parameters: None
'Returns: Nothing
'***************************************************************************

On Error GoTo IncrementTimesOpened_Err

Dim pty As Property
Dim lngDBTimesOpened As Long

lngDBTimesOpened = CurrentDb.Properties("TimesOpened")
CurrentDb.Properties("TimesOpened") = lngDBTimesOpened + 1

'Warn the user to re-compact every five opens
If lngDBTimesOpened Mod 5 = 0 Then
booCompactTime = True
End If

IncrementTimesOpened_Exit:
Exit Sub

IncrementTimesOpened_Err:
Select Case Err.Number
Case 3270 'Error code for "Property not found"
Set pty = CurrentDb.CreateProperty("TimesOpened", dbDate, 0)
CurrentDb.Properties.Append pty
Resume
Case Else
Call GlobalErr("IncrementTimesOpened", Err.Number)
Resume IncrementTimesOpened_Exit
Resume
End Select
End Sub

Hope this helps...

AccessGuruCarl
Programmers helping programmers
you can't find a better site.

 

[AccessGuruCarl]

After re-reading your post, You want to turn OFF the compact...

Try this,

Tools -- Options -- General Tab

Un-tick Compact On Close



AccessGuruCarl
Programmers helping programmers
you can't find a better site.

 

[rgbanse]

Thanks AccessGuruCarl - You gave me just what I was looking for.
RGB