I'm executing a query like this
select field from table;
In that query, there is a loop running on many tables. So, if the field is not present in a table I get a
Runtime Error 3061
How can I by pass this error such as that on this error flow should go to another point?
This is the code I have recently after going through this forum.
Option Explicit
Private Sub UpdateNulls()
Dim rs2 As DAO.Recordset
Dim tdf As DAO.TableDef
Dim db As Database
Dim varii As Variant, strField As String
Dim strsql As String, strsql2 As String, strsql3 As String
Dim astrFields As Variant
Dim intIx As Integer
Dim field As Variant
Dim astrvalidcodes As Variant
Dim found As Boolean
Dim v As Variant
Open "C:\Documents and Settings\Desktop\testfile.txt" For Input As #1
varii = ""
Do While Not EOF(1)
Line Input #1, strField
varii = varii & "," & strField
Loop
Close #1
astrFields = Split(varii, ",") 'Element 0 empty
For intIx = 1 To UBound(astrFields)
'Function ListFieldDescriptions()
Dim cn As New ADODB.Connection, cn2 As New ADODB.Connection
Dim rs As ADODB.Recordset, rs3 As ADODB.Recordset
Dim connString As String
Dim SelectFieldName
Set cn = CurrentProject.Connection
SelectFieldName = astrFields(intIx)
Set rs = cn.OpenSchema(adSchemaColumns, Array(Empty, Empty, Empty, SelectFieldName))
'Show the tables that have been selected '
While Not rs.EOF
'Exclude MS system tables '
If Left(rs!Table_Name, 4) <> "MSys" Then
strsql = "Select t.* From [" & rs!Table_Name & "] t Inner Join 01UMWELT On t.fall = [01UMWELT].fall Where [01UMWELT].Status = 4"
End If
Set rs3 = CurrentDb.OpenRecordset(strsql)
'End Function
strsql2 = "SELECT label.validcode FROM variablen s INNER JOIN label ON s.id=label.variablenid WHERE varname='" & astrFields(intIx) & "'"
Set db = OpenDatabase("C:\Documents and Settings\Desktop\Codebook.mdb")
Set rs2 = db.OpenRecordset(strsql2)
With rs2
.MoveLast
.MoveFirst
astrvalidcodes = rs2.GetRows(.RecordCount)
.Close '
End With
With rs3
.MoveFirst
While Not rs3.EOF
found = False
For Each v In astrvalidcodes
If v = .Fields(0) Then
found = True
Debug.Print .Fields(0)
Debug.Print .Fields(1)
Exit For
End If
Next
If Not found Then
msgbox "xxxxxxxxxxxxxxxx"
End If
End If
.MoveNext
Wend
End With
On Error GoTo 0 'End of special handling
Wend
Next intIx
End Sub
I'm getting a
Type Mismatch Runtime Error
in Set rs3 = CurrentDb.OpenRecordset(strsql)
I guess I'm mixing up ado and dao but I'm not certainly sure where it is.
Use the On Error statement that VBA supplies:
Sub TableTest
On Error Goto TableTest_Error
' ...code that can fail... '
Exit Sub
:TableTest_Error
If Err.Number = 3061 Then
Err.Clear()
DoSomething()
Else
MsgBox Err.Description ' or whatever you find appropriate '
End If
End Sub
Alternatively, you can switch off automatic error handling (e.g. breaking execution and displaying an error message) on a line-by-line basis:
Sub TableTest
' ... fail-safe code ... '
On Error Resume Next
' ...code that can fail... '
If Err.Number = 3061 Then
Err.Clear()
DoSomething()
Else
MsgBox Err.Description
End If
On Error Goto 0
' ...mode fail-safe code... '
End Sub
There are these statements available:
On Error Resume Next switches off VBA-integrated error handling (message box etc.) completely, execution simply resumes on the next line. Be sure to check for an error very early after you've used that, as a dangling error can disrupt the normal execution flow. Clear the error as soon as you caught it to prevent that.
On Error Goto <Jump Label> resumes execution at a given label, primarily used for per-function error handlers that catch all sorts of errors.
On Error Goto <Line Number> resumes at a given line number. Stay away from that, it's not useful, even dangerous.
On Error Goto 0 it's close cousin. Reinstates the VBA integrated error management (message box etc.)
EDIT
From the edited qestion, this is my proposal to solve your problem.
For Each FieldName In FieldNames ' assuming you have some looping construct here '
strsql3 = "SELECT " & FieldName & " FROM table"
On Error Resume Next
Set rs3 = CurrentDb.OpenRecordset(strsql3)
If Err.Number = 3061 Then
' Do nothing. We dont care about this error '
Err.Clear
Else
MsgBox "Uncaught error number " & Err.Number & " (" & Err.Description & ")"
Err.Clear
End If
On Error GoTo 0
Next FieldName
Be sure to clear the error in any case before you go on with a loop in the same Sub or Function. As I said, a dangling error causes code flow to become unexpected!
Rather than trapping the error, why not use the TableDefs to check for the field or use a mixture of ADO and DAO? ADO Schemas can provide a list of tables that contain the required field:
Function ListTablesContainingField()
Dim cn As New ADODB.Connection, cn2 As New ADODB.Connection
Dim rs As ADODB.Recordset, rs2 As ADODB.Recordset
Dim connString As String
Dim SelectFieldName
Set cn = CurrentProject.Connection
SelectFieldName = "Fall" 'For tksy '
'Get names of all tables that have a column called 'ID' '
Set rs = cn.OpenSchema(adSchemaColumns, _
Array(Empty, Empty, Empty, SelectFieldName))
'Show the tables that have been selected '
While Not rs.EOF
'Exclude MS system tables '
If Left(rs!Table_Name, 4) <> "MSys" Then
' Edit for tksy, who is using more than one forum '
If tdf.Name = "01UMWELT" Then
strSQL = "Select * From 01UMWELT Where Status = 5"
Else
strSQL = "Select a.* From [" & rs!Table_Name _
& "] a Inner Join 01UMWELT On a.fall = 01UMWELT.fall " _
& "Where 01UMWELT.Status = 5"
End If
Set rs2 = CurrentDb.OpenRecordset(strSQL)
Do While Not rs2.EOF
For i = 0 To rs2.Fields.Count - 1
If IsNull(rs2.Fields(i)) Then
rs2.Edit
rs2.Fields(i) = 111111
rs2.Update
End If
Next
rs2.MoveNext
Loop
End If
rs.MoveNext
Wend
rs.Close
Set cn = Nothing
End Function
Try this:
On Error Resume Next ' If an error occurs, move to next statement.
...statement that tries the select...
If (Err <> 0) Then
...act on error, or simply ignore if necessary...
End If
On Error Goto 0 ' Reset error handling to previous state.
Related
I need only empty tables in access database. Additionally, it would be great if I can get empty tables from list of tables that I have (part of all tables). But listing all empty tables would work also.
You can use a small VBA function that checks this. Something like:
Function fIsTableEmpty(strTableName As String) As Boolean
On Error GoTo E_Handle
Dim db As DAO.Database
Dim rsData As DAO.Recordset
Dim strSQL As String
Set db = CurrentDb
strSQL = "SELECT COUNT(*) FROM [" & strTableName & "];"
Set rsData = db.OpenRecordset(strSQL)
fIsTableEmpty = True ' start by assuming that there are records
If Not (rsData.BOF And rsData.EOF) Then
If rsData(0) > 0 Then fIsTableEmpty = False
End If
fExit:
On Error Resume Next
rsData.Close
Set rsData = Nothing
Set db = Nothing
Exit Function
E_Handle:
MsgBox Err.Description & vbCrLf & vbCrLf & "fIsTableEmpty", vbOKOnly + vbCritical, "Error: " & Err.Number
Resume fExit
End Function
You can use DCount:
Public Function ListEmptyTables()
Dim Table As DAO.TableDef
For Each Table In CurrentDb.TableDefs
If Table.SourceTableName = "" Then
If DCount("*", Table.Name) = 0 Then
Debug.Print Table.Name
End If
End If
Next
End Function
I've got a small Access program that looks up files names from a query ("qryImagesToRename"), goes through a loop and renames them. However, if an image already exists with the same name Access wants to rename it to, I receive
error 58 - File Already Exists
How do I ignore this error and continue with the loop? This my code:
Private Sub Command10_Click()
On Error GoTo Command10_Click_Error
Dim rs As DAO.Recordset
Dim db As DAO.Database
Dim strSQL As String
DoCmd.Hourglass True
Set db = CurrentDb
strSQL = "select * from qryImagesToRename"
Set rs = db.OpenRecordset(strSQL)
Do While Not rs.EOF
Name rs.Fields("From").Value As rs.Fields("To").Value
rs.MoveNext
Loop
DoCmd.Hourglass False
MsgBox "All matching files renamed"
On Error GoTo 0
Exit Sub
Command10_Click_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Command10_Click of VBA Document Form_frmRename - Please take a screenshot and email xxxxxx#xxxxxxx.com"
End Sub
If you are certain that you can ignore the error then you could use On Error Resume Next to ignore it and continue processing. Ensure that you add On Error Goto 0 as soon as you can, to reinstate the normal error processing.
On Error Resume Next
Do While Not rs.EOF
Name rs.Fields("From").Value As rs.Fields("To").Value
rs.MoveNext
Loop
On Error GoTo 0
This is most often a poor practice, but can be used if there is certainty about behaviour.
A better practice would be to check if the file already exists using Dir (or FileSystemObject) and skip it. Discussed here
Two particular solutions come to mind. The first, is in-line logic to check for the existing file, and skip that item, and the second is to put a case statement in the error handler. I have outlined the code below to have both options. I hope it helps.
Private Sub Command10_Click()
On Error GoTo Command10_Click_Error
Dim rs As DAO.Recordset
Dim db As DAO.Database
Dim strSQL As String
Dim fso as New FileSystemObject
DoCmd.Hourglass True
Set db = CurrentDb
strSQL = "select * from qryImagesToRename"
Set rs = db.OpenRecordset(strSQL)
Do While Not rs.EOF 'if you want to use the logic inline, use the check below
If fso.fileexists(rs.Fields("To").value) = false Then
Name rs.Fields("From").Value As rs.Fields("To").Value
End If
NextRecord: 'if you want to use the goto statement, use this
rs.MoveNext
Loop
DoCmd.Hourglass False
MsgBox "All matching files renamed"
On Error GoTo 0
Exit Sub
Command10_Click_Error:
Select case Err.number
Case 58
GoTo NextRecord
Case Else
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Command10_Click of VBA Document Form_frmRename - Please take a screenshot and email xxxxxx#xxxxxxx.com"
End select
End Sub
I have a bound form with several subforms. some of these subforms can 0 or more records, others have 1 or more.
The form is always open in read-only and on it there are an "edit" and a "close" button.
When the user clicks on the edit button I save the content of the current record togehter with all records of the subforms so that when he/she clicks on the close button I can ask wether to save or not and, if not, discard the changes restoring from saved records.
So far this is the code of the edit button (where GclnAllCnts is a global variable of type Dictionary):
Private Sub EditLibroBtn_Click()
On Error GoTo Err_EditLibroBtn_Click
Dim lngID As Long
Dim ctlCnt As Control
Dim rs As Recordset
lngID = Me.ID
Set GclnAllCnts = New Dictionary
GclnAllCnts.Add Me.Name, Me.RecordsetClone
For Each ctlCnt In Me.Controls
If (ctlCnt.ControlType = acSubform) Then
Set rs = ctlCnt.Form.RecordsetClone
If rs.RecordCount > 0 Then
GclnAllCnts.Add ctlCnt.Name, ctlCnt.Form.RecordsetClone
Else
GclnAllCnts.Add ctlCnt.Name, Null
End If
End If
Next
DoCmd.Close acForm, Me.Name
DoCmd.OpenForm GCstMainFrmName, , , "ID = " & lngID, acFormEdit, acDialog
Exit_EditLibroBtn_Click:
Set ctlCnt = Nothing
Set rs = Nothing
Exit Sub
Err_EditLibroBtn_Click:
MsgBox err.Description & vbNewLine & "Error number: " & err.Number, vbCritical, "Errore"
Resume Exit_EditLibroBtn_Click
End Sub
And this is the code of the close button:
Private Sub ChiudiBtn_Click()
On Error GoTo Err_ChiudiBtn_Click
Dim intBoxAwr As Integer
Dim stSQL As String
Dim vKey As Variant
Dim ctlCnt As Control
Dim clnAllCnts As Dictionary
Dim bSaveNeeded As Boolean
bSaveNeeded = False
If (Me.AllowEdits And Me.ID <> "" And Not IsNull(Me.ID)) Then
Set clnAllCnts = New Dictionary
clnAllCnts.Add Me.Name, Me.RecordsetClone
For Each ctlCnt In Me.Controls
If (ctlCnt.ControlType = acSubform) Then
Set rs = ctlCnt.Form.RecordsetClone
If rs.RecordCount > 0 Then
clnAllCnts.Add ctlCnt.Name, ctlCnt.Form.RecordsetClone
Else
clnAllCnts.Add ctlCnt.Name, Null
End If
End If
Next
If clnAllCnts.Count <> GclnAllCnts.Count Then
bSaveNeeded = True
Else
For Each vKey In clnAllCnts.keys()
If Not GclnAllCnts.Exists(vKey) Then
bSaveNeeded = True
Exit For
Else
'*********** Next Gives error **********
If clnAllCnts.Item(vKey) <> GclnAllCnts.Item(vKey) Then
bSaveNeeded = True
Exit For
End If
End If
Next
End If
If bSaveNeeded Then
intBoxAwr = MsgBox("Salvare le modifiche al libro?", vbYesNo + vbQuestion, "Salvare")
If intBoxAwr = vbYes Then
'etc., omitting code
End Sub
The error I get is Type mismatch (nr. 13) and it is given by the <> comparison (I can Debug.print IsNull(clnAllCnts.Item(vKey)) and IsNull(GclnAllCnts.Item(vKey)).
How can I compare the two recordset variables?
Comparing two Recordset objects by simply saying If rst1 <> rst2 could be dicey anyway, because what does that really mean? Such an expression could very well return True every time, if rst1 and rst2 really are different objects (even if they are of the same object Type).
It appears that you are interested in whether the contents of the two Recordsets is the same. In that case, I would be inclined to serialize the recordset data and store the resulting String instead of storing the Recordset object itself.
The following VBA Function may prove helpful in that case. It loops through a recordset object and produces a JSON-like string containing the current recordset data.
(Note that the function may NOT necessarily produce valid JSON. It doesn't escape non-printing characters like vbCr and vbLf. It doesn't escape backslashes (\). It stores all values as either "string" or null. In other words, in its current form it is not designed to produce a string that could later be deserialized.)
Private Function rstSerialize(ByVal rst As DAO.Recordset)
' loop through the recordset and generate a JSON-like string
' NB: This code will NOT necessarily produce valid JSON!
'
Dim s As String, fld As DAO.Field, rowCount As Long, fldCount As Long
s = "{"
If Not (rst.BOF And rst.EOF) Then
rst.MoveFirst
rowCount = 0
Do Until rst.EOF
If rowCount > 0 Then
s = s & ", "
End If
s = s & """row"": {"
fldCount = 0
For Each fld In rst.Fields
If fldCount > 0 Then
s = s & ", "
End If
s = s & """" & fld.Name & """: " & IIf(IsNull(fld.Value), "null", """" & fld.Value & """")
fldCount = fldCount + 1
Next
s = s & "}"
rowCount = rowCount + 1
rst.MoveNext
Loop
End If
s = s & "}"
rstSerialize = s
End Function
Data Example: If the Recordset contained
DonorID Amount
------- ------
1 10
2 20
the function would return the string
{"row": {"DonorID": "1", "Amount": "10"}, "row": {"DonorID": "2", "Amount": "20"}}
Usage Example: On a form that contains a subform, a button on the main form could do the following
Private Sub Command3_Click()
Dim rst As DAO.Recordset, originalState As String
Set rst = Me.MemberDonationsSubform.Form.RecordsetClone
originalState = rstSerialize(rst)
rst.MoveFirst
rst.Edit
rst!Amount = rst!Amount + 1
rst.Update
Debug.Print "(Recordset updated.)"
If rstSerialize(rst) = originalState Then
Debug.Print "Recordset does not appear to have changed."
Else
Debug.Print "Recordset appears to have changed."
End If
End Sub
which would print the following in the VBA Immediate Window
(Recordset updated.)
Recordset appears to have changed.
I want to extract all the fields associated to my tables in my access database, to get an inventory of all the data objects. This has to populate a form I've created. I've copied an extract of code to determine whether an object in the database is a query or a table and I would like to alter this, if possible.
Any help will be appreciated
Option Compare Database
Option Explicit
Private Sub AddInventory(strContainer As String)
Dim con As DAO.Container
Dim db As DAO.Database
Dim doc As DAO.Document
Dim rst As DAO.Recordset
Dim intI As Integer
Dim strType As String
Dim varRetval As Variant
On Error GoTo HandleErr
' You could easily modify this, using the
' OpenDatabase() function, to work on any database,
' not just the current one.
varRetval = SysCmd(acSysCmdSetStatus, _
"Retrieving " & strContainer & " container information...")
Set db = CurrentDb
Set con = db.Containers(strContainer)
Set rst = db.OpenRecordset("zstblInventory")
For Each doc In con.Documents
If Not IsTemp(doc.Name) Then
' Handle the special queries case.
' Tables and queries are lumped together
' in the Tables container.
If strContainer = "Tables" Then
If IsTable(doc.Name) Then
strType = "Tables"
Else
strType = "Queries"
End If
Else
strType = strContainer
End If
rst.AddNew
rst("Container") = strType
rst("Owner") = doc.Owner
rst("Name") = doc.Name
rst("DateCreated") = doc.DateCreated
rst("LastUpdated") = doc.LastUpdated
rst.Update
End If
Next doc
ExitHere:
If Not rst Is Nothing Then
rst.Close
Set rst = Nothing
End If
Exit Sub
HandleErr:
MsgBox Err.Number & ": " & Err.Description, , _
"AddInventory"
Resume ExitHere
End Sub
Private Sub RebuildInventory()
On Error GoTo HandleErr
DoCmd.Hourglass True
Me.lstInventory.RowSource = ""
Call CreateInventory
Me.lstInventory.RowSource = "SELECT ID, Container, Name, " & _
"Format([DateCreated],'mm/dd/yy (h:nn am/pm)') AS [Creation Date], " & _
"Format([lastUpdated],'mm/dd/yy (h:nn am/pm)') AS [Last Updated], " & _
"Owner FROM zstblInventory ORDER BY Container, Name;"
ExitHere:
DoCmd.Hourglass False
Exit Sub
HandleErr:
Resume ExitHere
End Sub
Private Sub CreateInventory()
If (CreateTable()) Then
' These routines use the status line,
' so clear it once everyone's done.
Call AddInventory("Tables")
Call AddInventory("Forms")
Call AddInventory("Reports")
Call AddInventory("Scripts")
Call AddInventory("Modules")
Call AddInventory("Relationships")
' Clear out the status bar.
Call SysCmd(acSysCmdClearStatus)
Else
MsgBox "Unable to create zstblInventory."
End If
End Sub
Private Function CreateTable() As Boolean
' Return True on success, False otherwise
Dim qdf As DAO.QueryDef
Dim db As DAO.Database
Dim strSQL As String
On Error GoTo HandleErr
Set db = CurrentDb()
db.Execute "DROP TABLE zstblInventory"
' Create zstblInventory
strSQL = "CREATE TABLE zstblInventory (Name Text (255), " & _
"Container Text (50), DateCreated DateTime, " & _
"LastUpdated DateTime, Owner Text (50), " & _
"ID AutoIncrement Constraint PrimaryKey PRIMARY KEY)"
db.Execute strSQL
' If you got here, you succeeded!
db.TableDefs.Refresh
CreateTable = True
ExitHere:
Exit Function
HandleErr:
Select Case Err
Case 3376, 3011 ' Table or Object not found
Resume Next
Case Else
CreateTable = False
End Select
Resume ExitHere
End Function
Private Function IsTable(ByVal strName As String)
Dim tdf As DAO.TableDef
Dim db As DAO.Database
On Error Resume Next
' Normally, in a function like this,
' you would need to refresh the tabledefs
' collection for each call to the function.
' Since this slows down the function
' by a very large measure, this time,
' just Refresh the collection the first
' time, before you call this function.
Set db = CurrentDb()
' See CreateTable().
'db.Tabledefs.Refresh
Set tdf = db.TableDefs(strName)
IsTable = (Err.Number = 0)
Err.Clear
End Function
Private Function IsTemp(ByVal strName As String)
IsTemp = Left(strName, 7) = "~TMPCLP"
End Function
Private Sub cmdCreateInventory_Click()
Call RebuildInventory
End Sub
Private Sub Detail0_Click()
End Sub
Private Sub Form_Open(Cancel As Integer)
Call RebuildInventory
End Sub
Check out the source code in this answer. You should be able to modify it to do what you need. Unless, as Remou pointed out in his comment, you are working with a pre-2000 version of Access.
I'm performing a data cleansing operation on an access database. I have several duplicate records in a table that I want to consolidate down into one single record. In doing this I will need to update all references to the records that I will be consolidating.
If I know the column name that holds the record id is there a way to find all of the tables in access that contain this column?
You can examine the TableDefs collection and determine which tables contain a field with a given name.
Public Sub TablesWithField(ByVal pName As String)
Dim db As DAO.Database
Dim tdf As DAO.TableDef
Dim strMsg As String
Dim strName As String
On Error GoTo ErrorHandler
Set db = CurrentDb
For Each tdf In db.TableDefs
strName = vbNullString
'ignore system and temporary tables '
If Not (tdf.name Like "MSys*" Or tdf.name Like "~*") Then
strName = tdf.Fields(pName).name
If Len(strName) > 0 Then
Debug.Print tdf.name & ": " & pName
End If
End If
Next tdf
ExitHere:
On Error GoTo 0
Set tdf = Nothing
Set db = Nothing
Exit Sub
ErrorHandler:
Select Case Err.Number
Case 3265 'Item not found in this collection. '
Resume Next
Case Else
strMsg = "Error " & Err.Number & " (" & Err.description _
& ") in procedure TablesWithField"
MsgBox strMsg
GoTo ExitHere
End Select
End Sub
Short answer: Yes. And there are many ways to skin that cat. Two ideas:
(1) Via VBA, make use of: Application.CurrentDb.TableDefs(i).Fields(j).Name
(2) Via Tools==>Analyze==>Documenter, make a report and then search its output (Publish it with MS Word).
Sorry, but Access isn't built like MS SQL Server or DB2 - the MSys* tables really aren't set up for querying table schemas like that. However, others have VBA based solutions that look useful.
You can use Schemas, not exactly a query, but similar:
Function ListTablesContainingField(SelectFieldName) As String
'Tables returned will include linked tables
'I have added a little error coding. I don't normally do that
'for examples, so don't read anything into it :)
Dim cn As New ADODB.Connection
Dim rs As ADODB.Recordset
Dim strTempList As String
On Error GoTo Error_Trap
Set cn = CurrentProject.Connection
'Get names of all tables that have a column called <SelectFieldName>
Set rs = cn.OpenSchema(adSchemaColumns, _
Array(Empty, Empty, Empty, SelectFieldName))
'List the tables that have been selected
While Not rs.EOF
'Exclude MS system tables
If Left(rs!Table_Name, 4) <> "MSys" Then
strTempList = strTempList & "," & rs!Table_Name
End If
rs.MoveNext
Wend
ListTablesContainingField = Mid(strTempList, 2)
Exit_Here:
rs.Close
Set cn = Nothing
Exit Function
Error_Trap:
MsgBox Err.Description
Resume Exit_Here
End Function