i have the code below, it sets a bunch of properties based on various tables
startup form, toolbars, shift bypass, etc
it worked fine for months, now, all of a sudden, all my dbs are opening with errors (so, corruption can't be the cause)
what's weird is that it works fine on a different computer
what can be wrong with the one that errors? i restarted
it errors at
s = CurrentDb.Properties(sPropName).Name
here's all 3 functions
Sub sbSetStartupOptions()
Dim bOn As Boolean
SetOption "Auto Compact", True
SetOption "Show Hidden Objects", False
SetOption "Show System Objects", False
SetOption "Confirm Record Changes", True
SetOption "Confirm Document Deletions", True
SetOption "Confirm Action Queries", True
SetOption "Default Open Mode for Databases", 0 'shared
SetOption "ShowWindowsInTaskbar", False
sbAppIcon
Dim vrAppName As String
Dim vrStartupForm As String
vrStartupForm = DLookup("StartupForm", "zAppSettings", "AppSettingsID=1")
fnSetDatabaseProperty "StartupForm", 1, vrStartupForm
vrAppName = DLookup("AppName", "zAppSettings", "AppSettingsID=1")
fnChangeAppNameCurrentDB (vrAppName)
fnSetDatabaseProperty "StartupShowStatusBar", 1, True '1=dbBoolean
bOn = fnIsDev
fnSetDatabaseProperty "AllowShortcutMenus", 1, bOn
fnSetDatabaseProperty "StartupShowDBWindow", 1, bOn
fnSetDatabaseProperty "AllowToolbarChanges", 1, bOn
fnSetDatabaseProperty "AllowBreakIntoCode", 1, bOn
fnSetDatabaseProperty "AllowSpecialKeys", 1, bOn
fnSetDatabaseProperty "AllowBypassKey", 1, bOn
fnSetDatabaseProperty "AllowFullMenus", 1, bOn
fnSetDatabaseProperty "AllowBuiltinToolbars", 1, bOn
Application.SetHiddenAttribute acTable, "zLockReleaseDatabase", Not bOn
End Sub
Function fnSetDatabaseProperty(ByVal sPropName As String, Optional ByVal lngPropType As Long, Optional vPropValue As Variant) As Boolean
Dim s As String, bCreate As Boolean
On Error Resume Next
If CurrentProject.ProjectType = acADP Then
s = CurrentProject.Properties(sPropName).Name
Else
s = CurrentDb.Properties(sPropName).Name
End If
If Err.Number > 0 Then bCreate = True
On Error GoTo P_Error
If bCreate Then
If Not IsMissing(vPropValue) Then
If CurrentProject.ProjectType = acADP Then
CurrentProject.Properties.Add sPropName, vPropValue
Else
If lngPropType = 0 Then lngPropType = varType(vPropValue)
CurrentDb.Properties.Append CurrentDb.CreateProperty(sPropName, lngPropType, vPropValue)
End If
End If
Else
If IsMissing(vPropValue) Then
If CurrentProject.ProjectType = acADP Then
CurrentProject.Properties.Remove sPropName
Else
CurrentDb.Properties.Delete sPropName
End If
Else
If CurrentProject.ProjectType = acADP Then
CurrentProject.Properties(sPropName).Value = vPropValue
Else
CurrentDb.Properties(sPropName).Value = vPropValue
End If
End If
End If
If Not CurrentProject.ProjectType = acADP Then
CurrentDb.Properties.Refresh
End If
fnSetDatabaseProperty = True
P_Exit:
Exit Function
P_Error:
'GetError Err.Number, Err.description, Erl, CurrentObjectName, "SetDatabaseProperty"
Resume P_Exit
End Function
Function fnSetProperties(strPropName As String, varPropType As Variant, varPropValue As Variant) As Integer
On Error GoTo Err_SetProperties
Dim db As DAO.database, prp As DAO.Property
Set db = CurrentDb
db.Properties(strPropName) = varPropValue
fnSetProperties = True
Set db = Nothing
Exit_SetProperties:
Exit Function
Err_SetProperties:
If Err = 3270 Then 'Property not found
Set prp = db.CreateProperty(strPropName, varPropType, varPropValue)
db.Properties.Append prp
Resume Next
Else
fnSetProperties = False
MsgBox "SetProperties", Err.Number, Err.Description
Resume Exit_SetProperties
End If
End Function
You understand that attempting to reference a property which does not exist triggers error #3270, "Property not found." And you expect to suppress the display of that error message when you include On Error Resume Next before referencing the property.
However, although your code includes On Error Resume Next before s = CurrentDb.Properties(sPropName).Name, Access still displayed the error message whenever property sPropName did not exist.
The only way I could find to replicate that behavior is by setting Access' Error Trapping option to "Break on All Errors" With that setting, the following simple procedure displays the "Property not found" error message despite On Error Resume Next --- the same situation you're dealing with. It appears "Break on All Errors" trumps On Error Resume Next.
Public Sub test_04()
Dim s As String
Dim sPropName As String
sPropName = "BOGUS" ' no such property exists in my database
On Error Resume Next
s = CurrentDb.Properties(sPropName).Name
End Sub
If I change my Error Trapping option to either "Break in Class Module" or "Break on Unhandled Errors", that procedure does not display the error message. With those options, the behavior is determined by On Error Resume Next --- the code continues on without displaying an error message.
Related
Option Compare Database
Function ap_DisableShift()
'This function disable the shift at startup. This action causes
'the Autoexec macro and Startup properties to always be executed.
On Error GoTo errDisableShift
Dim db As DAO.Database
Dim prop As DAO.Property
Const conPropNotFound = 3270
Set db = CurrentDb()
'This next line disables the shift key on startup.
db.Properties("AllowByPassKey") = FALSE
'The function is successful.
Exit Function
errDisableShift:
'The first part of this error routine creates the "AllowByPassKey
'property if it does not exist.
If Err = conPropNotFound Then
Set prop = db.CreateProperty("AllowByPassKey", _
dbBoolean, False)
db.Properties.Append prop
Resume Next
Else
MsgBox "Function 'ap_DisableShift' did not complete successfully."
Exit Function
End If
End Function
Function ap_EnableShift()
'This function enables the SHIFT key at startup. This action causes
'the Autoexec macro and the Startup properties to be bypassed
'if the user holds down the SHIFT key when the user opens the database.
On Error GoTo errEnableShift
Dim db As DAO.Database
Dim prop As DAO.Property
Const conPropNotFound = 3270
Set db = CurrentDb()
'This next line of code disables the SHIFT key on startup.
db.Properties("AllowByPassKey") = TRUE
'function successful
Exit Function
errEnableShift:
'The first part of this error routine creates the "AllowByPassKey
'property if it does not exist.
If Err = conPropNotFound Then
Set prop = db.CreateProperty("AllowByPassKey", _
dbBoolean, True)
db.Properties.Append prop
Resume Next
Else
MsgBox "Function 'ap_DisableShift' did not complete successfully."
Exit Function
End If
End Function
Use the following:
Function DatabaseDisableShift()
On Error GoTo FunctionError
Dim CurrentDatabase As DAO.Database, DatabaseProperty As DAO.Property
Const PropertyNotFound = 3270
Set CurrentDatabase = CurrentDb()
CurrentDatabase.Properties("AllowByPassKey") = False
Exit Function
FunctionError:
If Err = PropertyNotFound Then
Set DatabaseProperty = _
CurrentDatabase.CreateProperty("AllowByPassKey", dbBoolean, False)
'Change to True, to enable shift.
CurrentDatabase.Properties.Append DatabaseProperty
Resume Next
Else
MsgBox Err.Description
Exit Function
End If
End Function
This is a project I inherited. I noticed that sometimes it doesn't log errors.
This routine raises an error so that it can log it along with the rest of the message.
But it never returns to the error point and actually logs the error.
I can see what it is supposed to do, but I can't see how to get it to work.
Public Sub PostErrorToLog(lngErrID As Long, strContext As String, Optional strEvent As String)
On Error GoTo ErrHandler:
Dim strErrEvent As String
Dim rst As New ADODB.Recordset
Dim pass As Integer
pass = 0
'Capture event description by triggering the error.
Err.Raise lngErrID ' It gets to here, then jumps
'Use AddNew because SQL may be added into strEvent, causing objSQL.RunADO() to fail.
Set rst = objSQL.GetRST("PostErrorToLog()", "[System Log]", , , adCmdTable)
rst.AddNew ' Never gets here.
rst![UID] = strCurrUID
rst![ErrorID] = lngErrID
rst![Source] = strContext
rst![Event] = ConcatenateStrings(strErrEvent, strEvent, " ")
rst.Update
rst.Close
FlushLog "Error"
Exit Sub
ErrHandler:
strErrEvent = Err.Description
pass = pass + 1
If pass > 2 Then ' Seems like pass is always going to be 1
Resume Next
End If ' It gets to here and exits the routine.
End Sub
I need to write code that goes to a specific path and imports data from it,
then goes to another path and do the same.
I need that if path num 1 does not exist, it will jump direct to path num 2.
I wrote a sub for each path. there is a way to do something like:
if error goto sub ___ ?
Thanks in advance
Not directly, but you can do something like
On Error Goto error_sub1
and at the bottom of your function, write
error_sub1:
'ToDo - put your calling code here.
Elsewhere in you function you can switch the error handler to a different label:
On Error Goto error_sub2
and so on.
Try this:
Sub testSO()
On Error GoTo err
I=5/0
Exit Sub
err:
<your sub procedure here>
End Sub
Remember to include Exit Sub or else it will still run even without error!
Would it not be better to avoid the error in the first place and check whether the file exists before attempting to open it?
Sub Test()
Dim sFile1 As String
Dim sFile2 As String
Dim wrkBk As Workbook
On Error GoTo Error_Handler
sFile1 = "C:\Users\Desktop\MyFile1.xls"
sFile2 = "C:\Users\Desktop\MyFile2.xls"
If FileExists(sFile1) Then
Set wrkBk = Workbooks.Open(sFile1)
ElseIf FileExists(sFile2) Then
Set wrkBk = Workbooks.Open(sFile2)
Else
Err.Raise 513, , "File Not Found."
End If
wrkBk.Worksheets(1).Range("A1") = "Opened this file."
On Error GoTo 0
Fast_Exit:
'Any tidying up that needs doing.
Exit Sub
Error_Handler:
MsgBox Err.Description, vbExclamation + vbOKCancel, _
"Error: " & CStr(Err.Number)
Err.Clear
Resume Fast_Exit
End Sub
Public Function FileExists(ByVal FileName As String) As Boolean
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
FileExists = oFSO.FileExists(FileName)
End Function
I am using below code, When user click on cancel button in the input box, the error is being handled by the error handler.
But if there is error again in the error handler then that error is not getting handled by the error handler.
Sub calculateroot()
Dim msg As String, t as Integer
On Error GoTo myhandle
Dim inp As Integer, sql As Single
inp = InputBox("Enter the number to find the square root")
sql = Sqr(inp)
Exit Sub
myhandle:
t = InputBox("Is this recursive ?")
End Sub
What changes should I make in the code to handle the error generated in error handler ?
You have to reset the error handler and then set a new one:
Sub calculateroot()
Dim msg As String, t As Integer
On Error GoTo myhandle
Dim inp As Integer, sql As Single
inp = inputbox("Enter the number to find the square root")
sql = Sqr(inp)
Exit Sub
myhandle:
On Error GoTo -1
On Error GoTo myhandle2
t = inputbox("Is this recursive ?")
MsgBox t
Exit Sub
myhandle2:
MsgBox "myhandle2"
End Sub
If you need to resume, this disgusting code works:
On Error Resume Next
parm = "bla"
DoSomething(parm)
If Err.Number > 0 Then
Err.Clear
parm = "oldbla"
DoSomething(parm)
End If
If Err.Number > 0 Then
Err.Clear
parm = "evenolderbla"
DoSomething(parm)
End If
I am trying to add a field using VBA to a table in a mdb file if the field does not exist. If I open the mdb file in Access, and run the VBA code, it works fine. However, if I clode Access, I will encounter 'Error 3265 : Item not found in this collection.' at 'With Access.Application.DBEngine(0)(0).TableDefs("Contract")' stage.
Thanks!
Here is my code:
Sub ResetDB()
Dim nlen As Long
MsgBox ("Select the Access Database using this browse button")
NewFN = Application.GetOpenFilename(FileFilter:="mdb.Files (*.mdb), *.mdb", Title:="Please select a file")
If NewFN = False Then
' They pressed Cancel
MsgBox "Try Again if database needs to be reset"
Application.DisplayAlerts = False
'ActiveWorkbook.Close
Application.DisplayAlerts = True
Exit Sub
Else
ActiveWorkbook.Unprotect ("12345")
Sheets("Version").Visible = True
Worksheets("Version").Unprotect (strPW)
Range("Database").Value = NewFN
'On Error GoTo Failed ' I comment this line just to see where the error is
' following line is when the error occurs
With Access.Application.DBEngine(0)(0).TableDefs("Contract")
.Fields.Refresh
nlen = Len(.Fields("Industry_Type").Name)
If nlen > 0 Then Sheets("Instructions").Range("a1") = 1 ' do nothing
End
End With
Failed:
If Err.Number = 3265 Then Err.Clear ' Error 3265 : Item not found in this collection.
With Access.Application.DBEngine(0)(0).TableDefs("Contract")
.Fields.Append .CreateField("Industry_Type", dbLong)
End With
End
End If
End Sub
If the Access is closed, you will not be able to work on it.
You must open the MDB file:
Dim db As New Access.Application
db.OpenAccessProject filepath
The use db to retrieve the tables:
db.TableDefs....