Invalid Reference when starting database

[boblarson]

Is the Autoexec macro enough to make that happen?

Yes, if you call the procedure from the AutoExec macro, it will run that before any forms load or references are checked.

 

[mafhobb]

Well, that did not fix it...

I added all the changes (jsstreettech.com) and added some message boxes to know what was happening.

On my computer it all worked fine and I got the "jstchecktablelinks_full" msbox which means that this sub was called and the login form appeared right after that.

On my other user's who is using Runtime, I was not that lucky. The message boxes told me that the Autoexec did start and that the code "jstchecktablelinks_full" also got started. No other errors or messages other than "Invalid Database Object reference" when the login form was started.

The funny thing is that I have added a message box to the beginning of each sub yet I got no other message box. Does this mean that there are no problems with the table links and the problem is elsewhere?

Here is the code for the autolinker

'--------------------------------------------------------------------
'
' Copyright 1996-2011 J Street Technology, Inc.
' www.JStreetTech.com
'
' This code may be used and distributed as part of your application
' provided that all comments remain intact.
'
' J Street Technology offers this code "as is" and does not assume
' any liability for bugs or problems with any of the code.  In
' addition, we do not provide free technical support for this code.
'
'--------------------------------------------------------------------
Option Compare Database
Option Explicit

'Revised Type Declare for compatability with NT
Type tagOPENFILENAME
    lStructSize         As Long
    hwndOwner           As Long
    hInstance           As Long
    lpstrFilter         As String
    lpstrCustomFilter   As Long
    nMaxCustFilter      As Long
    nFilterIndex        As Long
    lpstrFile           As String
    nMaxFile            As Long
    lpstrFileTitle      As String
    nMaxFileTitle       As Long
    lpstrInitialDir     As String
    lpstrTitle          As String
    Flags               As Long
    nFileOffset         As Integer
    nFileExtension      As Integer
    lpstrDefExt         As String
    lCustData           As Long
    lpfnHook            As Long
    lpTemplateName      As Long
End Type

Private Declare Function GetOpenFileName Lib "comdlg32.dll" _
    Alias "GetOpenFileNameA" (OPENFILENAME As tagOPENFILENAME) As Long
  
Private Sub HandleError(strLoc As String, strError As String, intError As Integer)
    MsgBox strLoc & ": " & strError & " (" & intError & ")", 16, "CheckTableLinks"
End Sub

Private Function TableLinkOkay(strTableName As String) As Boolean
'Function accepts a table name and tests first to determine if linked
'table, then tests link by performing refresh link.
'Error causes TableLinkOkay = False, else TableLinkOkay = True
    MsgBox "TableLinkOkay"
    Dim CurDB As DAO.Database
    Dim tdf As TableDef
    Dim strFieldName As String
    On Error GoTo TableLinkOkayError
    Set CurDB = DBEngine.Workspaces(0).Databases(0)
    Set tdf = CurDB.TableDefs(strTableName)
    TableLinkOkay = True
    If tdf.Connect <> "" Then
        strFieldName = tdf.Fields(0).Name    'Do not test if nonlinked table
    End If
    TableLinkOkay = True
TableLinkOkayExit:
    Exit Function
TableLinkOkayError:
    TableLinkOkay = False
    GoTo TableLinkOkayExit
End Function

'----------------------------------------------------------------
Private Function Relink(tdf As TableDef) As Boolean
'Function accepts a tabledef and tests first to determine if linked
'table, then links table by performing refresh link.
'Error causes Relink = False, else Relink = True
    MsgBox "Relink"
    On Error GoTo RelinkError
    Relink = True
    If tdf.Connect <> "" Then
        tdf.RefreshLink     'Do not test if local or system table
    End If
    Relink = True
RelinkExit:
        Exit Function
RelinkError:
    Relink = False
    GoTo RelinkExit
End Function

'---------------------------------------------------------------------------
Private Sub RelinkTables(strCurConnectProp As String, intResultcode As Integer)
'This subroutine accepts a table connect property and displays a dialog to allow
'modification of table links.  Routine verifies link for each modification.
'intResultcode = 0 if cancel ocx or no link change, 1 if new links OK, and
'2 if link check fails.
    MsgBox "RelinkTables"

    Dim CurDB As DAO.Database
    Dim NewDB As Database
    Dim tdf As TableDef
    Dim strFilter As String
    Dim strDefExt As String
    Dim strTitle As String
    Dim OPENFILENAME As tagOPENFILENAME
    Dim strFileName As String
    Dim strFileTitle As String
    Dim APIResults As Long
    Dim intSlashLoc As Integer
    Dim intConnectCharCt As Integer
    Dim strDBName As String
    Dim strPath As String
    Dim strNewConnectProp As String
    Dim intNumTables As Integer
    Dim intTableIndex As Integer
    Dim strTableName As String
    Dim strSaveCurConnectProp As String
    Dim strMsg As String
    Dim varReturnVal
    Dim strAccExt As String
    
    Const OFN_PATHMUSTEXIST = &H1000
    Const OFN_FILEMUSTEXIST = &H800
    Const OFN_HIDEREADONLY = &H4
    
    On Error GoTo RelinkTablesError
    
    'Returned by GetOpenFileName
    'Revised to handle to the Win32 structure
    'strFileName = Space$(256)
    'strFileTitle = Space$(256)
    strFileName = String(256, 0)
    strFileTitle = String(256, 0)
    
    Set CurDB = DBEngine.Workspaces(0).Databases(0)
    strSaveCurConnectProp = strCurConnectProp
    
    'Parse table connect property to get data base name
        intSlashLoc = 1
        intConnectCharCt = Len(strCurConnectProp)
        Do Until InStr(intSlashLoc, strCurConnectProp, "\") = 0
            intSlashLoc = InStr(intSlashLoc, strCurConnectProp, "\") + 1
        Loop
        strDBName = Right$(strCurConnectProp, intConnectCharCt - intSlashLoc + 1)
        strPath = Right$(strCurConnectProp, intConnectCharCt - 10)
        strPath = Left$(strPath, intSlashLoc - 12)
        
    'Set up display of dialog
    'October 2009 - now handles Access 2007 formats ACCDB and ACCDE
    strAccExt = "*.accdb; *.mdb; *.mda; *.accda; *.mde; *.accde"
    strFilter = "Microsoft Office Access (" & strAccExt & ")" & Chr$(0) & strAccExt & Chr$(0) & _
                "All Files (*.*)" & Chr$(0) & "*.*" & _
                Chr$(0) & Chr$(0)
    strTitle = "Find new location of " & strDBName
    strDefExt = "mdb"
    
    'Revisions to handle to the Win32 structure
    'See changes to type declare
    '-----------------------------------------------------------
    With OPENFILENAME
        .lStructSize = Len(OPENFILENAME)
        .hwndOwner = Application.hWndAccessApp
        .lpstrFilter = strFilter
        .nFilterIndex = 1
        .lpstrFile = strDBName & String(256 - Len(strDBName), 0)
        .nMaxFile = Len(strFileName) - 1
        .lpstrFileTitle = strFileTitle
        .nMaxFileTitle = Len(strFileTitle) - 1
        .lpstrTitle = strTitle
        .Flags = OFN_PATHMUSTEXIST Or OFN_FILEMUSTEXIST Or OFN_HIDEREADONLY
        .lpstrDefExt = strDefExt
        .hInstance = 0
        .lpstrCustomFilter = 0
        .nMaxCustFilter = 0
        .lpstrInitialDir = strPath
        .nFileOffset = 0
        .nFileExtension = 0
        .lCustData = 0
        .lpfnHook = 0
        .lpTemplateName = 0
    End With
    '-----------------------------------------------------------
    APIResults = GetOpenFileName(OPENFILENAME)
    intResultcode = APIResults
    If APIResults = 1 Then      '1 if user selected file
        strNewConnectProp = ";DATABASE=" & OPENFILENAME.lpstrFile
        If Trim(strNewConnectProp) <> Trim(strSaveCurConnectProp) Then
        
    'Open New Database and create New Connect Property
            DoCmd.Hourglass True
            Set NewDB = OpenDatabase(OPENFILENAME.lpstrFile, False, True)
         
    'Set tables connect property to new connect & test
            intNumTables = CurDB.TableDefs.Count
            varReturnVal = SysCmd(acSysCmdInitMeter, "Linking Access Database", intNumTables)
            For intTableIndex = 0 To intNumTables - 1
                DoEvents
                varReturnVal = SysCmd(acSysCmdUpdateMeter, intTableIndex)
                Set tdf = CurDB.TableDefs(intTableIndex)
                If tdf.Connect = strCurConnectProp Then
                    tdf.Connect = strNewConnectProp
                    strTableName = tdf.Name
                    If Not Relink(tdf) Then
                        'Link failed, restore previous connect property and generate msgs
                        tdf.Connect = strCurConnectProp
                        intResultcode = 2       'Link failed
                        strSaveCurConnectProp = Right(strSaveCurConnectProp, intConnectCharCt - 10)
                        strMsg = "Access Table: " & strTableName & " link failed using selected database." & vbCrLf & vbCrLf & "Table is still linked to previous database path: " & strSaveCurConnectProp & "."
                        strTitle = "Failed Access Table Link"
                        MsgBox strMsg, 16, strTitle
                    End If
                End If
            Next intTableIndex
        varReturnVal = SysCmd(acSysCmdRemoveMeter)
        Else
            intResultcode = 0   'No change in Link
        End If
    End If
        
RelinkTablesExit:
    Exit Sub
    
RelinkTablesError:
    HandleError "RelinkTables", Error, Err
    Resume RelinkTablesExit
    Resume
End Sub

'------------------------------------------------------------------
Public Sub jstCheckTableLinks(CheckMode As String, LinksChanged As Boolean, LinksOK As Boolean, Optional CheckAppFolder As Boolean)
MsgBox "jstCheckTableLinks"
'
'INPUT:
'CheckMode = "prompt", Subroutine queries operator for location of
'   each database required by linked tables.  Msgbox for each failed link
'   and summary Msgbox on final link status (success or failure) if any
'   links were changed.  If no links changed, then no summary status.
'
'CheckMode = "full", Subroutine identifies invalid table links
'   and queries operator for location of database(s) required to satisfy
'   failed links.  Msgbox for each failed link and summary Msgbox
'   if link failures.  No Msgbox appears if all links are valid.
'
'CheckMode = "quick", same as "full" except that only the first table for
'   each linked database is checked.  If the link is not valid, the user is
'   is prompted for the location of the database and all tables in that
'   database are relinked.
'
'CheckAppFolder = True, override linked table connections if the same database name
'   exists in the application folder.  If False or not specified, no override occurs.
'
'OUTPUT:
'LinksChanged = true if at least one table link was changed.
'               false if no links where changed.
'LinksOK =      true if all links are OK upon subroutine exit.
'               false if least one table link was not successful.
'--------------------------------------------------------------------

    Dim CurDB As Database
    Dim tdf As TableDef
    Dim TableConnectPropBadArray() As String, intDBBadCount As Integer
    Dim TableConnectPropChkArray() As String, intDBChkCount As Integer
    Dim UniquePathArray() As Variant, intDBCount As Integer, intDBIndex As Integer, intDBOverrideIndex As Integer
    Dim bOverride As Boolean
    Dim bPathFound As Boolean
    Dim strUniqueDBPath As String
    Dim strFileSearch As String
    Dim intTableIndex As Integer
    Dim intNumTables As Integer
    Dim strTableName As String
    Dim strFieldName As String
    Dim intBadIndex As Integer
    Dim intChkIndex As Integer
    Dim fFound As Integer
    Dim fAllFound As Integer
    Dim fLinkGood As Integer
    Dim strCurConnectProp As String
    Dim intResultcode As Integer
    Dim strMsg As String
    Dim strTitle As String
    Dim intNoLinksChanged As Integer
    Dim varReturnVal As Variant
    
    On Error GoTo CheckTableLinksError
    DoCmd.Hourglass True
    varReturnVal = SysCmd(acSysCmdSetStatus, "Checking linked databases.")
    Set CurDB = DBEngine.Workspaces(0).Databases(0)
    
    'Get number of tables.
    intNumTables = CurDB.TableDefs.Count
    ReDim TableConnectPropBadArray(intNumTables)     'Set largest size
    ReDim TableConnectPropChkArray(intNumTables)     'Set largest size
    ReDim UniquePathArray(intNumTables, 1)
        
    'If app configured to first check in applicaiton folder for linked databases
    If CheckAppFolder = True Then
        For intTableIndex = 0 To intNumTables - 1
            Set tdf = CurDB.TableDefs(intTableIndex)
            'If there is a connect string
            If tdf.Connect & "" <> "" Then
                bPathFound = False
                'Loop through the array to check for pre-existence of database to preserve uniqueness of db paths
                For intDBIndex = 0 To (intNumTables - 1)
                    If tdf.Connect = UniquePathArray(intTableIndex, 0) Then
                        bPathFound = True
                        Exit For
                    End If
                Next
                        
                'If the path was not found in the array, add it to the unique array of paths.
                If bPathFound = False Then
                    UniquePathArray(intDBCount, 1) = 0
                    UniquePathArray(intDBCount, 0) = tdf.Connect
                    intDBCount = intDBCount + 1
                End If
            End If
        Next
        
        'Loop through all databases in array; set Override 'flag'(second column of array)
        For intDBIndex = 0 To intDBCount
            strUniqueDBPath = UniquePathArray(intDBIndex, 0)
            UniquePathArray(intDBIndex, 1) = ExistsInAppFolder(strUniqueDBPath)
        Next
        
    End If
    
    'Set up Array of Databases (all if forcelink is true, failed links if
    '   forcelink is false) (local and system tables will pass test).
    varReturnVal = SysCmd(acSysCmdInitMeter, "Checking linked databases.", intNumTables)
    LinksOK = True   'Assume success
    For intTableIndex = 0 To intNumTables - 1
        DoEvents
        varReturnVal = SysCmd(acSysCmdUpdateMeter, intTableIndex)
        Set tdf = CurDB.TableDefs(intTableIndex)
        fFound = False
          
        If Left(tdf.Connect, 10) = ";DATABASE=" Then
            'BGC -- changed from NOT "ODBC" to = ";DATABASE=" explicitly to get Access tables only
          
            strCurConnectProp = tdf.Connect
                            
            If CheckAppFolder = True Then
                bOverride = False
                    For intDBOverrideIndex = 0 To intDBCount
                        If tdf.Connect & "" <> "" And tdf.Connect = UniquePathArray(intDBOverrideIndex, 0) And UniquePathArray(intDBOverrideIndex, 1) = True Then
                            bOverride = True
                            strFileSearch = UniquePathArray(intDBOverrideIndex, 0)
                            tdf.Connect = ";DATABASE=" & PathOnly(CurDB.Name) & FileOnly(strFileSearch)
                            Exit For
                        End If
                    Next
    
            End If
            
            If bOverride = True Then
                If Not Relink(tdf) Then
                    'Link failed, restore previous connect property and generate msgs
                    tdf.Connect = strCurConnectProp
                    'intResultcode = 2       'Link failed
                    strMsg = "Application Folder Table: " & tdf.Name & " link failed." & vbCrLf & vbCrLf & "The current path for this linked table is: " & strCurConnectProp & "."
                    strTitle = "Failed Table Link"
                    MsgBox strMsg, 16, strTitle
                End If
            Else ' regular table, not overridden
            
                Select Case CheckMode
                Case "prompt"
                    ' put each connect string into the Bad array to force prompting later
                    For intBadIndex = 0 To intDBBadCount
                        If tdf.Connect = TableConnectPropBadArray(intBadIndex) Then
                            fFound = True
                            Exit For
                        End If
                    Next intBadIndex
                    If Not fFound Then
                        TableConnectPropBadArray(intDBBadCount) = tdf.Connect
                        intDBBadCount = intDBBadCount + 1
                    End If
                
                Case "full"
                    ' check each link, and put each bad connect string into
                    ' the Bad array to prompt later
                    For intBadIndex = 0 To intDBBadCount
                        If tdf.Connect = TableConnectPropBadArray(intBadIndex) Then
                            fFound = True
                            Exit For
                        End If
                    Next intBadIndex
                    If Not fFound Then
                        If Not TableLinkOkay(tdf.Name) Then
                            TableConnectPropBadArray(intDBBadCount) = tdf.Connect
                            intDBBadCount = intDBBadCount + 1
                            LinksOK = False
                        End If
                    End If
                
                Case "quick"
                    ' for each link, see if it has already been checked.
                    ' if it hasn't, add it to the checked array,
                    ' and check it.  If the link is bad, add it to the bad array to prompt later.
                    For intChkIndex = 0 To intDBChkCount
                        If tdf.Connect = TableConnectPropChkArray(intChkIndex) Then
                            fFound = True
                            Exit For
                        End If
                    Next intChkIndex
                    If Not fFound Then
                        TableConnectPropChkArray(intDBChkCount) = tdf.Connect
                        intDBChkCount = intDBChkCount + 1
                        If Not TableLinkOkay(tdf.Name) Then
                            TableConnectPropBadArray(intDBBadCount) = tdf.Connect
                            intDBBadCount = intDBBadCount + 1
                            LinksOK = False
                        End If
                    End If
            
                Case Else
                    MsgBox "CheckMode parameter """ & CheckMode & """ is not valid.  It must be ""prompt"", ""full"" or ""quick"".", vbCritical + vbOKOnly
                    LinksChanged = False
                    GoTo CheckTableLinksExit
                    
                End Select
            End If ' overridden table
        End If ' an Access linked table
            
        
    Next intTableIndex
    varReturnVal = SysCmd(acSysCmdRemoveMeter)
    
    'Prompt user to locate each database in TableConnectPropBadArray.
    varReturnVal = SysCmd(acSysCmdSetStatus, "Linking databases.")
    fAllFound = True   'Assume success in relinking all tables.
    intNoLinksChanged = 0    'Avoid successful message if no links were changed.
    For intBadIndex = 0 To intDBBadCount - 1
        DoEvents
        strCurConnectProp = TableConnectPropBadArray(intBadIndex)
        RelinkTables strCurConnectProp, intResultcode
        intNoLinksChanged = intNoLinksChanged + intResultcode
        If CheckMode = "prompt" Then
            If intResultcode = 2 Then fAllFound = False   'Failed relink.
        Else
            If Not intResultcode = 1 Then fAllFound = False
        End If
    Next intBadIndex
    
    'Display summary messages based upon forcelink value
    strTitle = "Database Links"
    If fAllFound = False Then
        strMsg = "One or more Access database tables may not be correctly linked."
        MsgBox strMsg, 16, strTitle
        LinksOK = False
    Else
        If CheckMode = "prompt" And intNoLinksChanged <> 0 Then
            strMsg = "All Access databases were linked successfully."
            MsgBox strMsg, 0, strTitle
        End If
        If CheckMode <> "prompt" Then LinksOK = True
    End If
    
    'Setup links changed flag.
    If intNoLinksChanged = 0 Then
        LinksChanged = False
    Else
        LinksChanged = True
    End If

CheckTableLinksExit:
    DoCmd.Hourglass False
    varReturnVal = SysCmd(acSysCmdClearStatus)
    Exit Sub
CheckTableLinksError:
    HandleError "CheckTableLinks", Error, Err
    Resume CheckTableLinksExit
End Sub

Public Function jstCheckTableLinks_Prompt()
    'prompt for new database locations of linked tables
    jstCheckTableLinks CheckMode:="prompt", LinksChanged:=False, LinksOK:=False, CheckAppFolder:=False
    MsgBox "jstCheckTableLinks_Prompt"
End Function

Public Function jstCheckTableLinks_Full()
    'check linked tables
    jstCheckTableLinks CheckMode:="full", LinksChanged:=False, LinksOK:=False, CheckAppFolder:=False
    MsgBox "jstCheckTableLinks_Full"
End Function

Public Function jstCheckTableLinks_Quick()
    'check linked tables, only the first per database
    jstCheckTableLinks CheckMode:="quick", LinksChanged:=False, LinksOK:=False, CheckAppFolder:=False
    MsgBox "jstCheckTableLinks_Quick"
End Function

Private Function ExistsInAppFolder(strPath As String) As Boolean
    On Error GoTo Err_ExistsInAppFolder
    MsgBox "ExistsInAppFolder"

    Dim db As Database
    Dim I As Integer
    Dim lngPos As Long
    Dim strDBName As String
    Dim strAppPath As String
    Dim strCurrPath As String
    
    ExistsInAppFolder = False
    
    Set db = CurrentDb
     
    strDBName = FileOnly(strPath)
    strCurrPath = PathOnly(db.Name)
         
    If FileExists(strCurrPath & strDBName) Then
        ExistsInAppFolder = True
    End If
     
Exit_ExistsInAppFolder:
    On Error Resume Next
    db.Close
    Set db = Nothing
    Exit Function

Err_ExistsInAppFolder:
    ExistsInAppFolder = False
    Resume Exit_ExistsInAppFolder
    Resume
End Function

Private Function FileExists(Path As Variant) As Boolean
    On Error GoTo Err_FileExists
    
    MsgBox "FileExists"
    Dim varRet As Variant
    
    If IsNull(Path) Then
        FileExists = False
        Exit Function
    End If
    
    varRet = Dir(Path)
    
    If Not IsNull(varRet) And varRet <> "" Then
        FileExists = True
    Else
        FileExists = False
    End If

Exit_FileExists:
    Exit Function

Err_FileExists:
    FileExists = False
    Resume Exit_FileExists

End Function

Private Function FileOnly(WholePath As Variant) As Variant
    On Error GoTo Err_FileOnly
    
    MsgBox "FileOnly"
    Dim FileOnlyPos
    
    If IsNull(WholePath) Then
        FileOnly = Null
        Exit Function
    End If
    
    FileOnlyPos = InStrRight(WholePath, "\") + 1
    
    FileOnly = Mid(WholePath, FileOnlyPos)
    
Exit_FileOnly:
    Exit Function
Err_FileOnly:
    MsgBox Err.Number & ", " & Err.Description
    Resume Exit_FileOnly
End Function

Private Function PathOnly(WholePath As Variant) As Variant
    On Error GoTo Err_PathOnly
    
    MsgBox "PathOnly"
    Dim FileOnlyPos
    
    If IsNull(WholePath) Then
        PathOnly = Null
        Exit Function
    End If
    
    FileOnlyPos = InStrRight(WholePath, "\") + 1
    
    PathOnly = Left(WholePath, FileOnlyPos - 1)
    
Exit_PathOnly:
    Exit Function
Err_PathOnly:
    MsgBox Err.Number & ", " & Err.Description
    Resume Exit_PathOnly
End Function

Private Function InStrRight(SearchString As Variant, soughtString As Variant) As Variant
    On Error GoTo Err_InStrRight
    
    MsgBox "InStrRight"
    Dim SoughtLen As Integer
    Dim Found As Integer
    Dim Pos As Integer
    
    If IsNull(SearchString) Or IsNull(soughtString) Then
        InStrRight = Null
        Exit Function
    End If
    
    If SearchString = "" Or soughtString = "" Then
        InStrRight = 0
        Exit Function
    End If
    
    SoughtLen = Len(soughtString)
    Found = False
    Pos = Len(SearchString) - SoughtLen + 1
    
    Do While Pos > 0 And Not Found
        If Mid(SearchString, Pos, SoughtLen) = soughtString Then
            Found = True
        Else
            Pos = Pos - 1
        End If
    Loop
    
    InStrRight = Pos
Exit_InStrRight:
    Exit Function
Err_InStrRight:
    MsgBox Err.Number & ", " & Err.Description
    Resume Exit_InStrRight
End Function

ideas?

mafhobb

 

[boblarson]

ideas?

Yes, I do - What code do you have for your Login Form? Do you have any place where you might declare a recordset object like this:

Dim rs As Recordset

instead of

Dim rs As DAO.Recordset

or

Dim rs As ADODB.Recordset

depending on which you might be using?

If not, there may be some other code that is causing the issue, so posting what is on the login form might help.

 

[mafhobb]

Hi Boblarson

Here is what's on the login form

Option Compare Database
Const MaxAttempts = 3
Dim Attempts As Integer
Dim bFlag As Boolean
Dim bReset As Boolean
Dim Repeat As Boolean


Private Sub CboUser_AfterUpdate()
'/Enable the login button
If Trim(Me.CboUser & "") <> "" Then
    Me.CmdLogin.Enabled = True
    '/Get the users permissions for RBAC
    strUserName = FindUserName()
    StrLoginName = Me.CboUser
    StrComputerName = FindComputerName()
    LngUserID = Me.CboUser.Column(0)
    StrPassword = DecryptKey(Me.CboUser.Column(4))
    blnChangeOwnPassword = Me.CboUser.Column(5)
    intPasswordExpireDays = Me.CboUser.Column(6)
    intAccessLevel = Me.CboUser.Column(7)
    
    
End If


'/Does the user have a current password

If DecryptKey(Me.CboUser.Column(4)) = "Not Set" Then
    bFlag = False
    MsgBox "You have not set up a user login password yet." & vbNewLine & "You must set one up before you can access the application.", vbExclamation + vbOKOnly, "Setup Login Password"
    
    Me.TxtOldPWD.Visible = False
    Me.TxtNewPWD.Visible = True
    Me.TxtConPWD.Visible = True
    Me.LblNew.Caption = "New Password:"
    Me.LblCon.Caption = "Confirm Password:"
Else
    bFlag = True
    Me.TxtOldPWD.Visible = True
    Me.TxtNewPWD.Visible = False
    Me.TxtConPWD.Visible = False
End If

'/If the user has a password and they can change their own password is it due to expire
If bFlag = True And intPasswordExpireDays > 0 And blnChangeOwnPassword = True Then
    Dim DaysLeft As Integer
    Dim DateExpire As Date
    DateExpire = DateAdd("d", intPasswordExpireDays, Me.CboUser.Column(15))
    DaysLeft = DateDiff("d", Date, DateExpire)
    '/Which option to choose
    Select Case DaysLeft
        Case Is < 0 ' Mandatory change
            MsgBox "Your password has expired. You must change it now.", vbExclamation + vbOKOnly, "Expired Password"
            Me.TxtOldPWD.Visible = True
            Me.LblOld.Caption = "Old Password:"
            bReset = True
        Case Is < 8 ' Optional change
            If MsgBox("Your password expires in " & DaysLeft & " day(s)." & vbNewLine & "Do you want to change it now?", vbQuestion + vbYesNo + vbDefaultButton1, "Password Expires") = vbYes Then
                Me.TxtOldPWD.Visible = True
                Me.TxtNewPWD.Visible = True
                Me.TxtConPWD.Visible = True
                Me.LblOld.Caption = "Old Password:"
                Me.LblNew.Caption = "New Password:"
                Me.LblCon.Caption = "Confirm Password:"
                
                bReset = True
            End If
        Case Else ' Not applicable for change
            Me.LblOld.Caption = "Password:"
            bReset = False
    End Select
    
End If

    
    

'/Which control to go to
If bFlag = False Then
    Me.TxtNewPWD.SetFocus
Else
    Me.TxtOldPWD.SetFocus
End If

End Sub


Private Sub CboUser_NotInList(NewData As String, Response As Integer)
   Dim s As String
   s = "'" & NewData & "'" & vbCrLf
   s = s & "Is not a valid user name, please retry" & vbCrLf
   s = s & "or refer to your system administrator " & vbCrLf
   s = s & "to add this new user to the database."
   MsgBox s, vbExclamation + vbOKOnly, "'" & NewData & "' not in list"
    Response = acDataErrContinue


End Sub

Private Sub CmdExit_Click()
    DoCmd.Quit
End Sub

Private Sub CmdLogin_Click()
'/First thing needed is to decide which option to take
'/If there is an entry in the txtoldpwd field this is an existing password
'/If there is an entry in the txtconpwd field this is a new password setup
'/If there is an entry in all three then the user has reset their password

'/If password has been reset then all the validation has taken place
'/so can open the main menu straight away


If bReset = True Then
    '/Create a login event for this user
    '/flag that the user is currently logged in
    Call CreateSession(LngUserID)
    Call LogMeIn(LngUserID)
    '/Open the main form and close this one
    DoCmd.OpenForm "Welcome"
    DoCmd.Close acForm, "FrmLogin"
    Exit Sub
End If


If Trim(Me.TxtOldPWD & "") <> "" Then
    '/does it match the users password
    If Trim(Me.TxtOldPWD & "") <> DecryptKey(Me.CboUser.Column(4)) Then
        '/No Match
        MsgBox "The password you have entered cannot be recognised.", vbExclamation + vbOKOnly, "Invalid Password"
        Me.TxtOldPWD = ""
        Attempts = Attempts + 1
        
        '/Three tries and your out
        If Attempts = MaxAttempts Then
            MsgBox "Maximum number of attempts has been reached", vbExclamation + vbOKOnly, "Login aborted"
            DoCmd.Quit
            Exit Sub
        End If
        Exit Sub
    End If
    '/Create a login event for this user
    '/flag that the user is currently logged in
    Call CreateSession(LngUserID)
    Call LogMeIn(LngUserID)
    '/Open the main form and close this one
    DoCmd.OpenForm "Welcome"
    DoCmd.Close acForm, "FrmLogin"
Else
    '/Has the user go a password
    If DecryptKey(Me.CboUser.Column(4)) <> "Not Set" Then
        MsgBox "You must enter you password first", vbExclamation + vbOKOnly, "Mandatory Requirement"
        Attempts = Attempts + 1
        
        '/three tries and your out.
        If Attempts = MaxAttempts Then
            MsgBox "Maximum number of attempts has been reached", vbExclamation + vbOKOnly, "Login aborted"
            DoCmd.Quit
            Exit Sub
        Else
            Exit Sub
        End If
        
    End If
    '/New password setup
    '/Compare both both entries as matching
    '/Is there an entry in either of the text boxes
    If Trim(Me.TxtNewPWD & "") = "" Then
        MsgBox "You must enter a new password. Cannot be left blank.", vbExclamation + vbOKOnly, "Invalid Password"
        Exit Sub
    End If
    If Trim(Me.TxtConPWD & "") = "" Then
        MsgBox "You must confirm the new password. Cannot be left blank.", vbExclamation + vbOKOnly, "Invalid Password Confirmation"
        Exit Sub
    End If
    '/do they match
    If Trim(Me.TxtNewPWD & "") <> Trim(Me.TxtConPWD & "") Then
        MsgBox "Passwords do not match.", vbExclamation + vbOKOnly, "Invalid Password Confirmation"
        Me.TxtConPWD.SetFocus
        Exit Sub
    Else
        '/they both match so we can add this new password to the users record
        Dim rs As DAO.Recordset
        Set rs = CurrentDb.OpenRecordset("Select * From [Tbl-Permissions] Where FKUserID=" & Me.CboUser.Column(0))
        If Not rs.EOF And Not rs.BOF Then
            rs.Edit
            rs("LoginName") = strUserName
            rs("PWD") = EncryptKey(Me.TxtConPWD)
            rs("fldDatePWD") = Date
            rs.Update
            rs.Close
        End If
        Set rs = Nothing
        MsgBox "You password has been set", vbInformation + vbOKOnly, "New Password"

        '/Create a login event for this user
        '/flag that the user is currently logged in
        Call CreateSession(LngUserID)
        Call LogMeIn(LngUserID)
        '/Open the main form and close this one
        DoCmd.OpenForm "Welcome"
        DoCmd.Close acForm, "FrmLogin"
    End If
    
    
End If


        
        

End Sub

Private Sub Form_Open(Cancel As Integer)
    Dim strGroupWithAccess As String
    
    'Here you would set the name of the group with access to this form.

    strGroupWithAccess = "PS-FP-01 Product Support Database Access"
    
    'Test if the user has access. If not, set Cancel to True and the form will not open.
    Cancel = Not IsMemberOfSecurityGroups(strGroupWithAccess)
    
    If Cancel = True Then
        MsgBox "You have no access to this database. You are not a member of the required security group.", vbExclamation
    End If

End Sub

''Private Sub Form_Timer()
    '/first thing connect ot the database
    '/As this is a demo it is using a self contained mdb
    ''If Repeat = False Then
       ' Me.TimerInterval = 0
        'Call RefreshLinks
       '' Repeat = True
   '' Else
        'Get first character
        ''Dim FChar As String
       '' FChar = Left(Me.LblMarquee.Caption, 1)
        'Remove first character
        ''Me.LblMarquee.Caption = Mid$(Me.LblMarquee.Caption, 2, Len(Me.LblMarquee.Caption) - 1)
        'Put 1st character at the end of the message.
       '' Me.LblMarquee.Caption = Me.LblMarquee.Caption + FChar
    ''End If
    


''End Sub


Private Sub TxtConPWD_AfterUpdate()
    If Trim(Me.TxtNewPWD & "") <> Trim(Me.TxtConPWD & "") Then
        MsgBox "Passwords do not match.", vbExclamation + vbOKOnly, "Invalid Password Confirmation"
        Me.CmdLogin.Enabled = False
        Attempts = Attempts + 1
        '/3 strikes and your out
        If Attempts > 3 Then
            MsgBox "Change password failed. Operation abandoned.", vbExclamation + vbOKOnly, "Access Denied"
            DoCmd.Quit
            Exit Sub
        End If
        Screen.PreviousControl.SetFocus
        'Me.TxtConPWD.SetFocus
        Exit Sub
    Else
        Me.CmdLogin.Enabled = True
        Dim rs As DAO.Recordset
        Set rs = CurrentDb.OpenRecordset("Select * From [Tbl-Permissions] Where FKUserID=" & Me.CboUser.Column(0))
        If Not rs.EOF And Not rs.BOF Then
            rs.Edit
            rs("LoginName") = strUserName
            rs("PWD") = EncryptKey(Me.TxtConPWD)
            rs("fldPWDDate") = Date
            rs.Update
            rs.Close
        End If
        Set rs = Nothing
        bReset = True
        MsgBox "You password has been changed", vbInformation + vbOKOnly, "Change Password"
        
    End If
    

End Sub

Private Sub TxtConPWD_GotFocus()
    If Trim(Me.TxtNewPWD & "") = "" Then
        Me.TxtNewPWD.SetFocus
    End If

End Sub

Private Sub TxtNewPWD_AfterUpdate()
'/If resetting their password does it match their old one? Not Allowed
If bReset = True Then
    If Me.TxtNewPWD = StrPassword Then
        MsgBox "Cannot have the same password. You must create a new one.", vbExclamation + vbOKOnly, "Error"
        Me.TxtNewPWD = ""
        Attempts = Attempts + 1
        If Attempts > 3 Then
            MsgBox "Maximim number of attempts reached. Change password failed.", vbExclamation + vbOKOnly, "System Logging Out"
            DoCmd.Quit
            Exit Sub
        End If
    End If
End If


End Sub

Private Sub TxtNewPWD_GotFocus()
'/Force user back to user name if not selelcted

If Trim(Me.CboUser & "") = "" Then
    Me.CboUser.SetFocus
ElseIf Me.TxtOldPWD = "" Then
    Me.TxtOldPWD.SetFocus
End If

End Sub

Private Sub TxtOldPWD_AfterUpdate()
'/ check if user is resetting their password
If bReset = True Then
    '/Does it match
    If Me.TxtOldPWD <> StrPassword Then
        MsgBox "Invalid Password, please retry.", vbExclamation + vbOKOnly, "Error"
        Me.TxtOldPWD = ""
        
        Attempts = Attempts + 1
        If Attempts > 3 Then
            MsgBox "Maximim number of attempts reached. Change password failed.", vbExclamation + vbOKOnly, "System Logging Out"
            DoCmd.Quit
            Exit Sub
        End If
    End If
End If

        
        
End Sub

Private Sub TxtOldPWD_GotFocus()
'/Force user back to user name if not selelcted
If Trim(Me.CboUser & "") = "" Then
    Me.CboUser.SetFocus
End If

End Sub

mafhobb

 

[boblarson]

Sorry, but we have to dig deep enough to find the problem, so I have to ask you another question or two (and possibly others as we go):

What is the code for DecryptKey and
What is the rowsource query for cboUser?

 

[boblarson]

Also, there is a way to try to troubleshoot this. I had an issue similar to this when I worked at this large healthcare organization about 5 years ago. I had an app that worked fine on my computer and another user's computer but a few others had problems and I couldn't figure out why. So, I ended up having to put code in before each step in my code to see if that was the problem.

I did something like this:

Private Sub Form_Load()
Dim strM As String
 
   On Error GoTo err_handler
 
strM = "Set rst = CurrentDb.OpenRecordset(strSQL)"
 
set rst = CurrentDb.OpenRecordset(strSQL)
 
strM = "Do Until rst.EOF"
 
Do Until rst.EOF
    strM = "If rst!Something = "SomethingElse" Then"
    If rst!Something = "SomethingElse" Then
       strM = "Do Something Here
       DoSomethingHere
    End If
  strM = "rst.MoveNext"
  rst.MoveNext
Loop
 
err_handler:
   Msgbox err.Description, vbExclamation, err.Number
   Msgbox strM, vbInformation, "Line it failed on"
 
End Sub

The other thing that can happen is you add line numbers (using the free MZ-Tools you can do that easily) and then in your error handler you can use

MsgBox "Error " & Err.Number & " - Line # " & Erl & " - " & " (" & Err.Description & ") in procedure Form_Load of VBA Document Form_Form1", , CurrentDb.Properties("AppTitle")

the Erl is the Error Line number and that is built in to Access if you have line numbers on your code.

It is a pain in the butt to have to go through that hassle but it did work and I did find out that I had a couple of ActiveX controls that needed to be installed on the particular machines.

 

[Jeanette Cunningham]

My work was done by moving the database so that the backend was in a different folder from the front end.
I found that the tables relinked fine, but then the error about 'invalid object reference' appeared as soon as the database was required to use info from a linked table.

As Bob suggests, you will need to follow the slow and painstaking process of testing each line of code after the table links code finishes.

 

[mafhobb]

The code for the decrypt and encrypt functions are the following.

Public Function DecryptKey(sStr As String)
If Len(sStr) < 4 Then Exit Function
Dim dKey As String
Dim dWord As String

For i = 1 To Len(Trim(sStr)) Step 4
    Letter = Trim(Mid(sStr, i, 4))
    dKey = Chr(Letter Xor 555)
    dWord = dWord & dKey
Next i
DecryptKey = dWord

End Function

Public Function EncryptKey(sStr As String)
charsInStr = Len(Trim(sStr))
Dim eKey As String

For i = 1 To charsInStr
    Letter = Mid(sStr, i, 1)
    eKey = eKey & CStr(Asc(Letter) Xor 555) & " "
Next i
EncryptKey = eKey
End Function

The rowsource query for cbouser is

SELECT [Tbl-Users].PKEnginnerID, [Tbl-Users].EngineerID, [Tbl-Users].Active, Nz([LoginName],"New User") AS UserName, Nz([PWD],"613 580 607 523 632 590 607 ") AS PWord, [tbl-Permissions].fldChangePWD, [tbl-Permissions].fldExpireDays, [tbl-Permissions].fldAccessLevel FROM [tbl-Permissions] INNER JOIN [Tbl-Users] ON [tbl-Permissions].FKUserId=[Tbl-Users].PKEnginnerID WHERE ((([Tbl-Users].Active)=True)) ORDER BY [Tbl-Users].EngineerID;

mafhobb

 

[Jeanette Cunningham]

You can put a msgbox (msgbox because you are trying to debug the runtime) in the SubExit or FunctionExit for the code that does the relinking.
Once you see that msgbox you know that the relinking code has finished.
Put a msgbox for the first line (after the routine's name) of the very next code that is called.
Test to see if that msgbox appears.
If it does, then move your msgboxes down one line of code and test again.
It is slow work.

If you don't test each line of code, it's very hard to find where the code has an error.

 

[mafhobb]

Yes, I do - What code do you have for your Login Form? Do you have any place where you might declare a recordset object like this:

Dim rs As Recordset

instead of

Dim rs As DAO.Recordset

or

Dim rs As ADODB.Recordset

depending on which you might be using?

I have not found a single line of code where my recordsets are not declared as DAO.Recordset

mafhobb

 

[mafhobb]

I have now added msgboxes on each line of code of the checklinks sub...all 190 some of them!

I want to run it that way to see where it stops. If it does not, then I'll do that to the login form code. However, the login form code only has very few simple lines in the "on Open" event, which are the only ones that would run when the form opens, so if the problem is in the login form, it has to be in this code, right?

Private Sub Form_Open(Cancel As Integer)
    Dim strGroupWithAccess As String
    
    'Here you would set the name of the group with access to this form.

    strGroupWithAccess = "PS-FP-01 Product Support Database Access"
    
    'Test if the user has access. If not, set Cancel to True and the form will not open.
    Cancel = Not IsMemberOfSecurityGroups(strGroupWithAccess)
    
    If Cancel = True Then
        MsgBox "You have no access to this database. You are not a member of the required security group.", vbExclamation
    End If

End Sub

Maybe it should be in the "on Load" event
mafhobb

 

[boblarson]

What is the code for

IsMemberOfSecurityGroups

that is another piece of code which could affect things.

 

[mafhobb]

Well,

I got access to the computer that was giving me trouble and I installed Access 2010 on it. Then I proceeded to copy my FE to it and then delete and relink the BE tables on that computer. That worked. Then I removed access 2010 from that computer and installed Runtime....and it was still working fine...

I am now using that FE on all other computers, including mine, with no troubles...

Odd...but I am glad it is working. Maybe the full version of Acess installed something that was needed?

Anyway, thanks to everyone for their help!

mafhobb