I found the error in your code. Actually, I found several errors -- I take it you were in the process of adapting Dev's add-in to work with a database password? -- so I hacked away at the code until it worked. Your immediate error was with this line:
.OpenCurrentDatabase strMDBNamePath, , pwd
That would have given a compile error if you had done a Debug -> Compile Loaded Modules while editing the module, because the OpenCurrentDatabase method doesn't have a third argument. I had to do a little research to find a way of forcing Access to use the database password when opening a new current database. The trick I used was posted on The Access Web, at
http://www.mvps.org/access/modules/mdl0036.htm
Try this version of the module, which seems to work for me:
'----------- start of revised code for module modCompacter -----------
Option Compare Database
Option Explicit
Option Private Module
Private Const mconERR_FILE_NOT_EXIST = vbObjectError + 10
Private Const mconERR_NO_COMMAND_LINE = vbObjectError + 20
Private Const mconERR_INSTANCE_NOT_FOUND = vbObjectError + 30
Private Const pconQ = """"
Private Const mconSTATUS_FORM = "frmStatus"
Private mblnReopen As Boolean
Function fCompacter_EntryPoint()
'*******************************************
'Name: fCompacter_EntryPoint (Function)
'Purpose: Initiate the compact routine
'Author: Dev Ashish
'Date: 04 November 1998
'Called by: Autoexec; Boot with Shift down to bypass
'Calls: fCompactDatabase, fSetAccessWindow, frmStatus
'Inputs: None
'Output: None
'*******************************************
On Error GoTo ErrHandler
Const conERR_GENERIC = vbObjectError + 1
DoCmd.OpenForm mconSTATUS_FORM
'Hide the main Access window
Call fSetAccessWindow(SW_HIDE)
'Initiate Compact routine
If Not fCompactDatabase(Command) Then _
Err.Raise conERR_GENERIC
ExitHere:
On Error Resume Next
DoCmd.Quit
Exit Function
ErrHandler:
If Err = conERR_GENERIC Then
'do the registering here
Else
MsgBox "Compact routine failed.", _
vbCritical + vbOKOnly, _
"Critical error"
End If
Resume ExitHere
End Function
Function fCompactDatabase(strMDBNamePath As String) As Boolean
'*******************************************
'Name: fCompactDatabase (Function)
'Purpose: Close (if Open) and compact an external Jet Database
'Author: Dev Ashish
'Date: 04 November 1998
'Modified by: jn; Dirk Goldgar
'Modified to: Accept database password in strMDBNamePath,
' compact using database password
'Mod Date: 17 Noxember, 2003
'Called by:
'Calls: API, TempFile
'Inputs: strMDBNamePath - full path to MDB file
'Output: True on success, False on failure
'*******************************************
On Error GoTo Err_Handler
Dim strMsg As String
Dim strFileOnly As String
Dim strNewFile As String
Dim intI As Integer
Dim strTmpName As String
Dim intPos As Integer, pos2 As Integer
Dim pwd As String
Dim objAccess As Access.Application
Dim dbTemp As DAO.Database
'Determine whether we need to reopen the source database or not
'See if the semi colon separater is there
intPos = InStr(1, strMDBNamePath, ";")
'determine password, if present
pos2 = InStr(intPos + 1, strMDBNamePath, ";")
If intPos > 0 Then
'If string to the right is False, just close
If (pos2 > 0) Then
strTmpName = Mid$(strMDBNamePath, intPos + 1, pos2 - intPos)
Else
strTmpName = Right$(strMDBNamePath, Len(strMDBNamePath) - intPos)
End If
If (pos2 > 0) Then
pwd = Mid$(strMDBNamePath, pos2 + 1)
End If
'get a clean name for strmdbnamepath
strMDBNamePath = Left$(strMDBNamePath, intPos - 1)
Select Case UCase(strTmpName)
Case "FALSE":
mblnReopen = False
Case "TRUE":
mblnReopen = True
Case Else:
'Assume the we have to reopen
mblnReopen = True
End Select
'get a clean name for strMDBNamePath
strMDBNamePath = Left$(strMDBNamePath, intPos - 1)
Else 'Assume we have to reopen if the option isn't there
mblnReopen = True
End If
'Invalid argument value
If Len(strMDBNamePath) = 0 Then Err.Raise mconERR_NO_COMMAND_LINE
'File doesn't exist
If Len(Dir(strMDBNamePath)) = 0 Then Err.Raise mconERR_FILE_NOT_EXIST
'strip out the filename from db path
strFileOnly = Dir$(strMDBNamePath)
'Get a unique filename to compact to
strNewFile = TempFile(False)
'Try to get a handle to the other Access instance
Do While objAccess Is Nothing
intI = intI + 1
If intI = 50 Then Err.Raise mconERR_INSTANCE_NOT_FOUND
Set objAccess = GetObject(strMDBNamePath)
DoEvents
Loop
'Close the database and compact it to a new file
'close all open objects
Call sCloseAllObjects(objAccess)
With objAccess
.CloseCurrentDatabase
Call sUpdateStatusForm("Compacting " & vbCrLf & strMDBNamePath & vbCrLf _
& " to " & vbCrLf & strNewFile)
If (Len(pwd)) Then
DBEngine.CompactDatabase strMDBNamePath, strNewFile, dbLangGeneral & ";pwd=" & pwd, , ";pwd=" & pwd
Else
DBEngine.CompactDatabase strMDBNamePath, strNewFile
End If
DoEvents
Kill strMDBNamePath
DoEvents
Call sUpdateStatusForm("Copying " & vbCrLf & strNewFile & vbCrLf _
& " to " & vbCrLf & strMDBNamePath)
FileCopy strNewFile, strMDBNamePath
Do While Len(strMDBNamePath) = 0: DoEvents: Loop
'Only open if specified
If mblnReopen Then
If (Len(pwd)) Then
Set dbTemp = .DBEngine.OpenDatabase(strMDBNamePath, False, False, ";pwd=" & pwd)
.OpenCurrentDatabase strMDBNamePath
dbTemp.Close
Set dbTemp = Nothing
Else
.OpenCurrentDatabase strMDBNamePath
End If
Else
.DoCmd.Quit
End If
Kill strNewFile
End With
fCompactDatabase = True
Exit_Here:
On Error Resume Next
DoCmd.Close acForm, Forms(mconSTATUS_FORM)
Exit Function
Err_Handler:
fCompactDatabase = False
Select Case Err.Number
Case mconERR_INSTANCE_NOT_FOUND:
strMsg = "The Access instance containing the database " & vbCrLf
strMsg = strMsg & pconQ & strMDBNamePath & pconQ & vbCrLf
strMsg = strMsg & "couldn't be located."
MsgBox strMsg, vbCritical + vbOKOnly, "Access instance not found!"
Case mconERR_NO_COMMAND_LINE:
strMsg = "Invalid database name."
strMsg = strMsg & vbCrLf & vbCrLf & pconQ & pconQ & vbCrLf & vbCrLf
strMsg = strMsg & "Compacter will terminate."
MsgBox strMsg, vbCritical + vbOKOnly, "Invalid database name!"
Case mconERR_FILE_NOT_EXIST:
strMsg = "The database you specified" & vbCrLf
strMsg = strMsg & pconQ & strMDBNamePath & pconQ & vbCrLf
strMsg = strMsg & "doesn't exist." & vbCrLf & " Please check the filename and try again!"
MsgBox strMsg, vbCritical + vbOKOnly, "File not found"
Case 429:
strMsg = "The Compacter utility couldn't locate Access instance!"
MsgBox strMsg, vbExclamation + vbOKOnly, "Access instance not found"
Case Else:
MsgBox "Error: " & Err.Number & ". " & Err.Description, vbExclamation + vbOKOnly, _
"Unknown Error"
End Select
Resume Exit_Here
End Function
Private Sub sCloseAllObjects(objInstance As Access.Application)
'*******************************************
'Name: sCloseAllObjects (Sub)
'Purpose: Close all objects in a database while saving them
'Author: Dev Ashish
'Date: 04 November 1998
'Called by: Any
'Calls: None
'Inputs: objInstance - External Access Instance
'Output: None
'*******************************************
Dim i As Integer, ctr As Container, j As Integer
Dim astrObj(0 To 5) As String
Dim lodb As Database
astrObj(0) = "Tables"
astrObj(1) = "Queries"
astrObj(2) = "Forms"
astrObj(3) = "Reports"
astrObj(4) = "Scripts"
astrObj(5) = "Modules"
On Error Resume Next
With objInstance
Set lodb = .CurrentDb
For i = 0 To 5
Call sUpdateStatusForm("Closing open " & astrObj(i) & " in " & vbCrLf & lodb.Name)
Set ctr = lodb.Containers(astrObj(i))
For j = 0 To ctr.Documents.Count - 1
.DoCmd.Close i, ctr.Documents(j).Name, acSaveYes
Next j
Next i
End With
Set lodb = Nothing
End Sub
Sub sUpdateStatusForm(strText As String)
'Updates the open Status form
With Forms(mconSTATUS_FORM)
!lblStatus.Caption = strText
.Repaint
End With
End Sub
'----------- end of revised code for module modCompacter -----------
--
Dirk Goldgar, MS Access MVP
www.datagnostics.com
(please reply to the newsgroup)
you are right about the menu in that it is one i created.
i am quite sure i am executing the correct mda because i renamed the original, so there would not be interference.
here is the code from the module compacter:
Private Const mconERR_FILE_NOT_EXIST = vbObjectError + 10
Private Const mconERR_NO_COMMAND_LINE = vbObjectError + 20
Private Const mconERR_INSTANCE_NOT_FOUND = vbObjectError + 30
Private Const pconQ = """"
Private Const mconSTATUS_FORM = "frmStatus"
Private mblnReopen As Boolean
Function fCompacter_EntryPoint()
'*******************************************
'Name: fCompacter_EntryPoint (Function)
'Purpose: Initiate the compact routine
'Author: Dev Ashish
'Date: 04 November 1998
'Called by: Autoexec; Boot with Shift down to bypass
'Calls: fCompactDatabase, fSetAccessWindow, frmStatus
'Inputs: None
'Output: None
'*******************************************
On Error GoTo ErrHandler
Const conERR_GENERIC = vbObjectError + 1
DoCmd.OpenForm mconSTATUS_FORM
'Hide the main Access window
Call fSetAccessWindow(SW_HIDE)
'Initiate Compact routine
If Not fCompactDatabase(Command) Then _
Err.Raise conERR_GENERIC
ExitHere:
On Error Resume Next
DoCmd.Quit
Exit Function
ErrHandler:
If Err = conERR_GENERIC Then
'do the registering here
Else
MsgBox "Compact routine failed.", _
vbCritical + vbOKOnly, _
"Critical error"
End If
Resume ExitHere
End Function
Function fCompactDatabase(strMDBNamePath As String) As Boolean
'*******************************************
'Name: fCompactDatabase (Function)
'Purpose: Close (if Open) and compact an external Jet Database
'Author: Dev Ashish
'Date: 04 November 1998
'Called by:
'Calls: API, TempFile
'Inputs: strMDBNamePath - full path to MDB file
'Output: True on success, False on failure
'*******************************************
On Error GoTo Err_Handler
Dim strMsg As String
Dim strFileOnly As String
Dim strNewFile As String
Dim intI As Integer
Dim strTmpName As String
Dim intPos As Integer, pos2 As Integer
Dim pwd As String
Dim objAccess As Access.Application
'Determine whether we need to reopen the source database or not
'See if the semi colon separater is there
intPos = InStr(1, strMDBNamePath, ";")
'determine password, if present
pos2 = InStr(intPos + 1, strMDBNamePath, ";")
If intPos > 0 Then
'If string to the right is False, just close
If (pos2 > 0) Then
strTmpName = Mid$(strMDBNamePath, intPos + 1, pos2 - intPos)
Else
strTmpName = Right$(strMDBNamePath, Len(strMDBNamePath) - intPos)
End If
If (pos2 > 0) Then
pwd = Mid$(strMDBNamePath, pos2 + 1)
End If
'get a clean name for strmdbnamepath
strMDBNamePath = Left$(strMDBNamePath, intPos - 1)
Select Case UCase(strTmpName)
Case "FALSE":
mblnReopen = False
Case "TRUE":
mblnReopen = True
Case Else:
'Assume the we have to reopen
mblnReopen = True
End Select
'get a clean name for strMDBNamePath
strMDBNamePath = Left$(strMDBNamePath, intPos - 1)
Else 'Assume we have to reopen if the option isn't there
mblnReopen = True
End If
'Invalid argument value
If Len(strMDBNamePath) = 0 Then Err.Raise mconERR_NO_COMMAND_LINE
'File doesn't exist
If Len(Dir(strMDBNamePath)) = 0 Then Err.Raise mconERR_FILE_NOT_EXIST
'strip out the filename from db path
strFileOnly = Dir$(strMDBNamePath)
'Get a unique filename to compact to
strNewFile = TempFile(False)
'Try to get a handle to the other Access instance
Do While objAccess Is Nothing
intI = intI + 1
If intI = 50 Then Err.Raise mconERR_INSTANCE_NOT_FOUND
Set objAccess = GetObject(strMDBNamePath)
DoEvents
Loop
'Close the database and compact it to a new file
'close all open objects
Call sCloseAllObjects(objAccess)
With objAccess
.CloseCurrentDatabase
Call sUpdateStatusForm("Compacting " & vbCrLf & strMDBNamePath & vbCrLf _
& " to " & vbCrLf & strNewFile)
If (Len(pwd)) Then
DBEngine.CompactDatabase strMDBNamePath, strNewFile, ";pwd =" & pwd
DBEngine.CompactDatabase strMDBNamePath, strNewFile, , , ";pwd=" & pwd
Else
DBEngine.CompactDatabase strMDBNamePath, strNewFile
End If
DoEvents
Kill strMDBNamePath
DoEvents
Call sUpdateStatusForm("Copying " & vbCrLf & strNewFile & vbCrLf _
& " to " & vbCrLf & strMDBNamePath)
FileCopy strNewFile, strMDBNamePath
Do While Len(strMDBNamePath) = 0: DoEvents: Loop
'Only open if specified
If mblnReopen Then
If (Len(pwd)) Then
.OpenCurrentDatabase strMDBNamePath, , pwd
Else
.OpenCurrentDatabase strMDBNamePath
End If
Else
.DoCmd.Quit
End If
Kill strNewFile
End With
fCompactDatabase = True
Exit_Here:
On Error Resume Next
DoCmd.Close acForm, Forms(mconSTATUS_FORM)
Exit Function
Err_Handler:
fCompactDatabase = False
Select Case Err.Number
Case mconERR_INSTANCE_NOT_FOUND:
strMsg = "The Access instance containing the database " & vbCrLf
strMsg = strMsg & pconQ & strMDBNamePath & pconQ & vbCrLf
strMsg = strMsg & "couldn't be located."
MsgBox strMsg, vbCritical + vbOKOnly, "Access instance not found!"
Case mconERR_NO_COMMAND_LINE:
strMsg = "Invalid database name."
strMsg = strMsg & vbCrLf & vbCrLf & pconQ & pconQ & vbCrLf & vbCrLf
strMsg = strMsg & "Compacter will terminate."
MsgBox strMsg, vbCritical + vbOKOnly, "Invalid database name!"
Case mconERR_FILE_NOT_EXIST:
strMsg = "The database you specified" & vbCrLf
strMsg = strMsg & pconQ & strMDBNamePath & pconQ & vbCrLf
strMsg = strMsg & "doesn't exist." & vbCrLf & " Please check the filename and try again!"
MsgBox strMsg, vbCritical + vbOKOnly, "File not found"
Case 429:
strMsg = "The Compacter utility couldn't locate Access instance!"
MsgBox strMsg, vbExclamation + vbOKOnly, "Access instance not found"
Case Else:
MsgBox "Error: " & Err.Number & ". " & Err.Description, vbExclamation + vbOKOnly, _
"Unknown Error"
End Select
Resume Exit_Here
End Function
Private Sub sCloseAllObjects(objInstance As Access.Application)
'*******************************************
'Name: sCloseAllObjects (Sub)
'Purpose: Close all objects in a database while saving them
'Author: Dev Ashish
'Date: 04 November 1998
'Called by: Any
'Calls: None
'Inputs: objInstance - External Access Instance
'Output: None
'*******************************************
Dim i As Integer, ctr As Container, j As Integer
Dim astrObj(0 To 5) As String
Dim lodb As Database
astrObj(0) = "Tables"
astrObj(1) = "Queries"
astrObj(2) = "Forms"
astrObj(3) = "Reports"
astrObj(4) = "Scripts"
astrObj(5) = "Modules"
On Error Resume Next
With objInstance
Set lodb = .CurrentDb
For i = 0 To 5
Call sUpdateStatusForm("Closing open " & astrObj(i) & " in " & vbCrLf & lodb.Name)
Set ctr = lodb.Containers(astrObj(i))
For j = 0 To ctr.Documents.Count - 1
.DoCmd.Close i, ctr.Documents(j).Name, acSaveYes
Next j
Next i
End With
Set lodb = Nothing
End Sub
Sub sUpdateStatusForm(strText As String)
'Updates the open Status form
With Forms(mconSTATUS_FORM)
!lblStatus.Caption = strText
.Repaint
End With
End Sub
