I just starting with access and cant make things work...
trying to make simple sub that opens excell sheet and compares some values with table in access.
I am using this link as a reference:
http://www.utteraccess.com/wiki/index.php/Recordsets_for_Beginners
Private Sub Command2_Click()
Dim wb As Workbook
Set wb = openXLS
If Not wb Is Nothing Then
Dim rcs As DAO.Recordset
Dim db As Database
Set db = CurrentDb
Set rcs = db.OpenRecordset(TABLE_PRODUCTS)
Dim itemNo As String
For i = 1 To tools.LRow(wb.Sheets("Sheet1"), "A")
itemNo = wb.Sheets("Sheet1").Cells(i, "A").Value
rcs.FindFirst "ItemNo = " & itemNo 'error here, runtime error 3251
'operation is not supported for this type of object
If rcs.NoMatch = True Then
MsgBox "nomatch"
Else
MsgBox "OK"
End If
Next i
wb.Close
rcs.Close
Set wb = Nothing
Set rcs = Nothing
End If
End Sub
openXLS is a function that opens and returns workbook.
LRow returns last row in the column
i get runtime error 3251 operation is not supported for this type of object (marked in the coments)
You can't use FindFirst with table type recordsets. You will need to explicitly specify a dynaset recordset:-
Set rcs = db.OpenRecordset(TABLE_PRODUCTS, dbOpenDynaset)
You should do like this because i think you are not getting any records in recordset
if not rcs.EOF then
rcs.FindFirst "ItemNo = " & itemNo 'error here, runtime error 3251
'operation is not supported for this type of object
If rcs.NoMatch = True Then
MsgBox "nomatch"
Else
MsgBox "OK"
End If
end if
Update
Can you try using seek method instead of findfirst
rcs.Seek "=", itemNo
Update 2
First set index of your primary id like
rcs.index= "Id" -- do this after you create DAO recordset
Then try this
rcs.Seek Comparison:="=", itemNo:=itemNo
Related
I am trying to write some code to audit changes made via a form. I have a function that works to do this:
Function WriteChanges()
Dim f As Form
Dim c As Control
Dim user As String
Dim db As DAO.Database
Dim cnn As ADODB.Connection
Dim MySet As ADODB.Recordset
Dim tbld As TableDef
Dim recsource As String
Set f = Screen.ActiveForm
Set db = CurrentDb
Set cnn = CurrentProject.Connection
Set MySet = New ADODB.Recordset
recsource = f.RecordSource
Set tbld = db.TableDefs(recsource)
pri_key = fFindPrimaryKeyFields(tbld)
Debug.Print "pri_key: "; pri_key
user = Environ("username")
MySet.Open "Audit", cnn, adOpenDynamic, adLockOptimistic, adCmdTable
For Each c In f.Controls
Select Case c.ControlType
Case acTextBox, acComboBox, acListBox, acOptionGroup
If c.Value <> c.OldValue Then
With MySet
.AddNew
![EditDate] = Now
![user] = user
![SourceTable] = f.RecordSource
![SourceField] = c.ControlSource
![BeforeValue] = c.OldValue
![AfterValue] = c.Value
.update
End With
End If
End Select
Next c
MySet.Close
Set MySet = Nothing
Set f = Nothing
Set db = Nothing
End Function
I use this function on the before update property of various forms and it populates the Audit table with the details of the changes to values in each of the controls. I need to also get the value from the primary key field to add to the Audit table. I can use the following code to identify the name of the primary key within the form's record source:
Function fFindPrimaryKeyFields(tdf As TableDef) As String
Dim idx As Index
On Error GoTo HandleIt
For Each idx In tdf.Indexes
If idx.Primary Then
fFindPrimaryKeyFields = Replace(idx.Fields, "+", "")
GoTo OutHere
End If
Next idx
OutHere:
Set idx = Nothing
Exit Function
HandleIt:
Select Case Err
Case 0
Resume Next
Case Else
Beep
MsgBox Err & " " & Err.Description, vbCritical + vbOKOnly, "Error"
fFindPrimaryKeyFields = vbNullString
Resume OutHere
End Select
End Function
How can I use this to get the value from the control (text box) that has the identified primary key as its control source.
Please forgive any silly errors in my code as I'm a relative novice. Thanks in advance for any help.
I'm not 100% sure what you want exactly, but if you have the name of the field, you can use the following:
Dim primaryKeyValue As Variant
Dim primaryKeyColumnName As String
primaryKeyColumnName = fFindPrimaryKeyFields(TableDefs!MyTable)
Dim f as Form
'Get the form somehow
Dim c As Control
On Error GoTo NextC 'Escape errors because lots of controls don't have a control source
For Each c In f.Controls
If c.ControlSource = primaryKeyColumnName Then
primaryKeyValue = c.Value
End If
NextC:
Next c
On Error GoTo 0
If the primary key column is part of the form record source, you can simply read it by:
Debug.Print "PK value: " & f(pri_key)
Every column of the record source is a form property at runtime, independent of whether there is a control with the same name.
Note: your whole construct will stop working if you have a form that is based on a query that joins multiple tables.
I made a MS Access DB (old XP version) which used to work seamlessy.
I had to add a routine to "move" some data from a table to another, and wrote a function to do this.
The method I always used was to use dynamic recordsets (or dynasets), but this time it doesn't work.
The flow correctly opens dynasets, find and copy data from one recordset to the other, but when .update is done nothing appears in the original table.
I use DAO 3.60.
Here's the (summarized) code:
On Error Resume Next
Dim rstDoc As Recordset
Dim rstAdd As Recordset
Dim rstDocEmessi As Recordset
Dim rstAddDocEmessi As Recordset
Dim Incassato As Integer
Set rstDoc = CurrentDb.OpenRecordset("Documenti", dbOpenSnapshot)
Set rstDocEmessi = CurrentDb.OpenRecordset("TS_DocumentiEmessi", dbOpenDynaset)
Set rstAdd = CurrentDb.OpenRecordset("Addebiti", dbOpenDynaset)
Set rstAddDocEmessi = CurrentDb.OpenRecordset("TS_Addebiti_DocumentiEmessi", dbOpenDynaset)
numDoc = Forms!TS_SceltaStampa!IdDocumento
With rstDocEmessi
rstDocEmessi.AddNew
rstDocEmessi!IdDocOriginale = rstDoc!IdDocumento
rstDocEmessi!Data = rstDoc!Data
rstDocEmessi![#Fattura] = rstDoc![#Fattura]
...
rstDocEmessi!TS_Opposizione = rstDoc!TS_Opposizione
rstDocEmessi!TS_DataPagamento = rstDoc!TS_DataPagamento
rstDocEmessi!IsIncassato = (IIf(Incassato = vbYes, True, False))
rstDocEmessi!IsImportatoInSospesi = False
rstDocEmessi.Update
rstDocEmessi.Close
' Copia Addebiti
If Not (rstAdd.EOF And rstAdd.BOF) Then
rstAdd.MoveFirst
Do Until rstAdd.EOF = True
If rstAdd!Documento = numDoc Then
rstAddDocEmessi.AddNew
rstAddDocEmessi!IdAddebito = rstAdd!IdAddebito
rstAddDocEmessi!Documento = rstAdd!Documento
...
rstAdd!TS_TipoSpesa
rstAddDocEmessi!Calcola = rstAdd!Calcola
rstAddDocEmessi!Totale = rstAdd!Totale
rstAddDocEmessi.Update
End If
rstAdd.MoveNext
Loop
End If
rstAddDocEmessi.Close
rstAdd.Close
TS_Registra = True`
I have a few suggestions.
Firstly don't use On Error Resume Next unless you are expecting a particular error in a line of code that you are going to explicitly test for and handle in the very next line of code (by testing If Err.Number = ...). You should have an error handling code block and use On Error GoTo ERROR_CODE_BLOCK. If you are going to turn off the error handler for one particular command then you should turn it back on again straight after you've handled the expected error.
Because you've turned off error handling, it could be that your insert statements are failing due to some constraint violation but you're just not seeing this. For error handling I would recommend structuring your code like this:
On Error GoTo PROC_ERR
Dim rstDoc As Recordset
'...
'insert the body of your Procedure here
'...
PROC_EXIT:
'Add any tidying up code that always needs to run. For example, release all your Object variables
Set rstDoc = Nothing
Set rstAdd = Nothing
Set rstDocEmessi = Nothing
Set rstAddDocEmessi = Nothing
Exit Sub
PROC_ERR:
MsgBox "Error " & Err.Number & " - " & Err.Description
Resume PROC_EXIT
End Sub
General code tidying suggestions.
The With rstDocEmessi construct is used to save you a bit of typing. There should be an associated End With somewhere in your code, but I don't see this. I would change this bit of code as follows:
With rstDocEmessi
.AddNew
!IdDocOriginale = rstDoc!IdDocumento
!Data = rstDoc!Data
![#Fattura] = rstDoc![#Fattura]
...
!TS_Opposizione = rstDoc!TS_Opposizione
!TS_DataPagamento = rstDoc!TS_DataPagamento
!IsIncassato = (IIf(Incassato = vbYes, True, False))
!IsImportatoInSospesi = False
.Update
.Close
End With
Finally, the inserts into rstAddDocEmessi could be cleaned up a bit. Rather than opening the whole table of records for rstAdd and then checking each record in turn to see if you need to add a rstAddDocEmessi record, why not just get the relevant records in your rstAdd recordset?
Set rstAdd = CurrentDb.OpenRecordset("Select * From Addebiti " & _
"Where Documento = " & Forms!TS_SceltaStampa!IdDocumento, dbOpenDynaset)
'No need to test for (rstAdd.BOF And rstAdd.EOF), and no need for rstAdd.MoveFirst
'Just go straight into...
Do Until rstAdd.EOF = True
rstAddDocEmessi.AddNew
rstAddDocEmessi!IdAddebito = rstAdd!IdAddebito
rstAddDocEmessi!Documento = rstAdd!Documento
...
rstAddDocEmessi!Calcola = rstAdd!Calcola
rstAddDocEmessi!Totale = rstAdd!Totale
rstAddDocEmessi.Update
rstAdd.MoveNext
Loop
I'm trying to search for currently selected item in my listbox control on my table.
In my listbox control after update event, I have this code
Private Sub lst_MainList_AfterUpdate()
Dim theDB As DAO.Database
Dim theProposalsTable As DAO.Recordset
Set theDB = CurrentDb
Set theProposalsTable = theDB.OpenRecordset("tbl_PROPOSAL", dbOpenDynaset)
theSeeker theProposalsTable, Me.lst_PPpg_MainList.Value
End Sub
Then I have a sub on my Module1 with this code. I got this from an example code # https://msdn.microsoft.com/en-us/library/office/ff836416.aspx
Sub theSeeker(ByRef rstTemp As Recordset, intSeek As Integer)
Dim theBookmark As Variant
Dim theMessage As String
With rstTemp
' Store current record location.
theBookmark = .Bookmark
.Seek "=", intSeek
' If Seek method fails, notify user and return to the
' last current record.
If .NoMatch Then
theMessage = "Not found! Returning to current record." & vbCr & vbCr & "NoMatch = " & .NoMatch
MsgBox theMessage
.Bookmark = theBookmark
End If
End With
End Sub
I am getting Runtime Error 3251 Operation is not supported for this type of object.
When I hit Debug, it highlights .Seek "=", intSeek
In this point from the linked page ...
Locates the record in an indexed table-type Recordset object
... "table-type Recordset" means you must use dbOpenTable instead of dbOpenDynaset with OpenRecordset()
That point is critical. If you can't open the table with dbOpenTable, you can't use Seek. And dbOpenTable can only be used with native Access tables contained in the current database. It can not be used with any kind of linked table.
So if dbOpenTable is compatible with tbl_PROPOSAL, this change will eliminate the first error ...
'Set theProposalsTable = theDB.OpenRecordset("tbl_PROPOSAL", dbOpenDynaset)
Set theProposalsTable = theDB.OpenRecordset("tbl_PROPOSAL", dbOpenTable)
If that does work, the next error will be #3019, "Operation invalid without a current index." That happens because you must set the controlling index before calling Seek ...
With rstTemp
' Store current record location.
theBookmark = .Bookmark
' Set the index.
.Index = "PrimaryKey" '<- use your index name here
.Seek "=", intSeek
If you need to list the names of your table's indexes, you can examine its TableDef.Indexes collection. Here is an Immediate window example with a table in my database ...
set db = CurrentDb
for each idx in db.TableDefs("tblFoo").Indexes : ? idx.name : next
id
PrimaryKey
You can't use the Seek method on a linked table because you can't open linked tables as table-type Recordset objects...
However, you can use the Seek method if you use the OpenDatabase method to open the backend database.
So instead of:
Set theDB = CurrentDb()
Do this:
Set theDB = OpenDatabase("full path to backend database")
Set theProposalsTable = theDB.OpenRecordset("tbl_PROPOSAL", dbOpenTable)
Allow me to combine these two old answers. Yes, you get an error when opening a linked table as dbOpenTable because that is only supported on tables local to the DB object you are working on. Like David pointed out, you can open the linked backend as a DB object and use that.
I'm using a reliable table in my back-end called "Settings". If you don't have a reliable table you can use to pull the back end you can pass in the table name as an argument.
I'm storing the backend object once I have a handle on it so we can call against it rapidly throughout our code without recreating the object.
Private thisBEDB As Database
'#Description("This allows us to call directly against linked tables.")
Public Function thisBackend() As Database
' For MS-ACCESS table
If (thisBEDB Is Nothing) Then
With DBEngine
Set thisBEDB = .OpenDatabase(Mid(CurrentDB.TableDefs("Settings").Connect, 11), False, False, "")
End With
End If
Set thisBackend = thisBEDB
End Function
Now we can use the backend handle to make the code in your example work as expected.
Private Sub lst_MainList_AfterUpdate()
Dim theDB As DAO.Database
Dim theProposalsTable As DAO.Recordset
Set theDB = CurrentDb
Set theProposalsTable = thisBackend.OpenRecordset("tbl_PROPOSAL", dbOpenTable)
theSeeker theProposalsTable, Me.lst_PPpg_MainList.Value
End Sub
Sub theSeeker(ByRef rstTemp As Recordset, intSeek As Integer)
Dim theBookmark As Variant
Dim theMessage As String
With rstTemp
.Index = "PrimaryKey"
' Store current record location.
theBookmark = .Bookmark
.Seek "=", intSeek
' If Seek method fails, notify user and return to the
' last current record.
If .NoMatch Then
theMessage = "Not found! Returning to current record." & vbCr & vbCr & "NoMatch = " & .NoMatch
MsgBox theMessage
.Bookmark = theBookmark
End If
End With
End Sub
I have a crosstab query that is being loaded into a recordset. I'm then writing the query fields to an Excel spreadsheet. The problem is that a field may not exist based on the query results.
For example, I have the following line:
oSheet5.Range("F1").Value = rsB2("AK")
...which would write the value of the recordset item named "AK" to the spreadsheet. But if "AK" doesn't exist, I get an error Item not found in this collection.
How I can I test to see if there's an item named "AK"?
I tried...
If rsB2("AK") Then
oSheet5.Range("F" & Count).Value = rsB2("AK")
End If
...but that didn't work.
I also tried...
If rsB2("AK") Is Nothing Then
oSheet5.Range("F" & Count).Value = ""
Else
oSheet5.Range("F" & Count).Value = rsB2("AK")
End If
...and still the same error.
There are 50+ items/fields to check .. all states in USA plus a few extras.
Thanks!
You can use Recordset.FindFirst Method (DAO) take a look here or here
Small example:
Sub FindOrgName()
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
'Get the database and Recordset
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("tblCustomers")
'Search for the first matching record
rst.FindFirst "[OrgName] LIKE '*parts*'"
'Check the result
If rst.NoMatch Then
MsgBox "Record not found."
GotTo Cleanup
Else
Do While Not rst.NoMatch
MsgBox "Customer name: " & rst!CustName
rst.FindNext "[OrgName] LIKE '*parts*'"
Loop
'Search for the next matching record
rst.FindNext "[OrgName] LIKE '*parts*'"
End If
Cleanup:
rst.Close
Set rst = Nothing
Set dbs = Nothing
End Sub
You could add an error handler to catch the item not found error ... ignore it and/or do something else instead.
Or if the first recordset field always maps to the first sheet column regardless of the field's name, you can reference it by its ordinal position: rsB2(0)
Or you could examine the recordset's Fields collection to confirm the field name is present before attempting to retrieve its value.
After you open the recordset, load a dictionary with its field names. This code sample uses late binding. I included comment hints in case you want early binding. Early binding requires you to set a reference for Microsoft Scripting Runtime.
Dim objDict As Object 'Scripting.Dictionary
'Set objDict = New Scripting.Dictionary
Set objDict = CreateObject("Scripting.Dictionary")
Dim fld As DAO.Field
For Each fld In rsB2.Fields
objDict.Add fld.Name, vbNullString
Next
Then later you can use the dictionary's Exists method to your advantage.
If objdict.Exists("AK") = True Then
oSheet5.Range("F1").Value = rsB2("AK")
End If
I have a simple query tied to a command button that shows a summary of the values in a particular field. It's running on a table that changes with each use of the database, so sometimes the table will contain this field and sometimes it won't. When the field (called Language) is not in the file, the user clicks the command button and gets the "Enter Parameter Value" message box. If they hit cancel they then get my message box explaining the field is not present in the file. I would like to bypass the "Enter Parameter Value" and go straight to the message if the field is not found. Here is my code:
Private Sub LangCount_Click()
DoCmd.SetWarnings False
On Error GoTo Err_LangCount_Click
Dim stDocName As String
stDocName = "LanguageCount"
DoCmd.OpenQuery stDocName, acNormal, acEdit
Err_LangCount_Click:
MsgBox "No Language field found in Scrubbed file"
Exit_LangCount_Click:
Exit Sub
DoCmd.SetWarnings True
End Sub
You can attempt to open a recordset based on the query before you run the query:
Set rs = CurrentDb.QueryDefs("query1").OpenRecordset
This will go straight to the error coding if anything is wrong with the query.
Alternatively, if it is always the language field and always in the same table, you can:
sSQL = "select language from table1 where 1=2"
CurrentDb.OpenRecordset sSQL
This will also fail and go to your error coding, but if it does not fail, you will have a much smaller recordset, one with zero records.
You can easily enough get a list of fields in a table with ADO Schemas:
Dim cn As Object ''ADODB.Connection
Dim i As Integer, msg As String
Set cn = CurrentProject.Connection
Set rs = cn.OpenSchema(adSchemaColumns, Array(Null, Null, "Scrubbed"))
While Not rs.EOF
i = i + 1
msg = msg & rs!COLUMN_NAME & vbCrLf
rs.MoveNext
Wend
msg = "Fields: " & i & vbCrLf & msg
MsgBox msg
More info: http://support.microsoft.com/kb/186246
You have a command button named LangCount. It's click event has to deal with the possibility that a field named Language is not present in your Scrubbed table.
So then consider why a user should be able to click that command button when the Language field is not present. When the field is not present, you know the OpenQuery won't work (right?) ... so just disable the command button.
See if the following approach points you to something useful.
Private Sub Form_Load()
Me.LangCount.Enabled = FieldExists("Language", "Scrubbed")
End Sub
That could work if the structure of Scrubbed doesn't change after your form is opened. If the form also includes an option to revise Scrubbed structure, update LangCount.Enabled from that operation.
Here is a quick & dirty (minimally tested, no error handling) FieldExists() function to get you started.
Public Function FieldExists(ByVal pField As String, _
ByVal pTable As String) As Boolean
Dim blnReturn As Boolean
Dim db As DAO.Database
Dim fld As DAO.Field
Dim tdf As DAO.TableDef
Set db = CurrentDb
' next line will throw error #3265 (Item not found in this collection) '
' if table named by pTable does not exist in current database '
Set tdf = db.TableDefs(pTable)
'next line is not actually needed '
blnReturn = False
For Each fld In tdf.Fields
If fld.Name = pField Then
blnReturn = True
Exit For
End If
Next fld
Set fld = Nothing
Set tdf = Nothing
Set db = Nothing
FieldExists = blnReturn
End Function