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
Related
I split off a few large tables from my AccessDB to a backend database without issue.
Next, I need to open a recordset to replace various troublesome characters. The following snippet worked fine when the table was local, but Access complains now that the table is LINKED, but provides no detail.
Dim rs3 As DAO.Recordset
'Step thru the Item table fix ' & " characters
Set rs3 = db.OpenRecordset("Item", dbOpenTable)
Do While Not rs3.EOF
strDesc = Replace(Nz(rs3!DESC), Chr(39), Chr(39) & Chr(39))
strDesc = Replace(Nz(rs3!DESC), Chr(34), "")
rs3.MoveNext
Loop
Set rs3 = Nothing
Any suggestions for accomplishing this task with a LINKED table?
dbOpenTable can only be used with a local table; it can not be used with a linked table.
'Set rs3 = db.OpenRecordset("Item", dbOpenTable)
Set rs3 = db.OpenRecordset("Item")
'I allways use this format scheme, and it works perfectly, with local or
'linked tables (In fact, I always use linked tables...):
Dim bd As Database
Dim reg As Recordset
Private Sub Form_Load()
Set bd = CurrentDb
Set reg = bd.OpenRecordset("Select * from Pacientes", dbOpenDynaset)
end sub
' for a new record
reg.AddNew
' for updates
reg.Update
' for delete
reg.Delete
' to fill a table record
reg("Dni") = txtDni
' to read a table record
txtDni = reg("Dni")
' txtDni is the field's name in the form
' Dni is the field's name in the table
' to find a record
Dim Finder As String
Finder = InputBox("Dni: ")
If Finder <> "" Then
reg.FindFirst "Dni=" & Trim(Finder)
Private Sub cmdClose_Click()
reg.Close
bd.Close
DoCmd.Close
End Sub
As an end of some inserts, via VBA script, I have been doing in an ACCESS table. I have as a requirement to order the table by a field. So a third person would open it via the ACCESS Navigation Pane and it would be shown in the specified order.
EDIT: I also need that table to be writable by this third person.
I can think about creating a new table, using an SQL sentence to order it. But it seems like a very ugly option.
Is there any way to archive it using a DAO object or other VBA approach?
A query which sorts the table is the cleanest solution.
If you don't want to create an extra object for that, you can set the table sorting with DAO properties like this:
Sub DoIt()
Call TableSetSort("myTable", "myField")
End Sub
' Set a table to be sorted by <sFieldname>
Public Sub TableSetSort(sTable As String, sFieldname As String)
Dim DB As Database
Dim tdf As TableDef
Dim prop As DAO.Property
Set DB = CurrentDb
Set tdf = DB.TableDefs(sTable)
' Set field to order by
Call TableAddProperty(tdf, "OrderBy", dbText, sFieldname)
' These two may be true by default, but better safe than sorry
Call TableAddProperty(tdf, "OrderByOn", dbBoolean, True)
Call TableAddProperty(tdf, "OrderByOnLoad", dbBoolean, True)
' if you want to debug
For Each prop In tdf.Properties
Debug.Print prop.Name, prop.Value
Next prop
End Sub
' Set or add a property in a TableDef
Public Sub TableAddProperty(tdf As DAO.TableDef, sName As String, iType As DAO.DataTypeEnum, vValue As Variant)
Dim prop As DAO.Property
' Try to set the property value, this will fail with Runtime Error 3270 if the property doesn't exist
On Error Resume Next
tdf.Properties(sName) = vValue
If Err.Number = 3270 Then
' Property doesn't exist yet - create and append it
On Error GoTo 0
Set prop = tdf.CreateProperty(sName, iType, vValue)
tdf.Properties.Append prop
End If
' Note: error handling here is quite minimal!
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 actually have 2 questions:
1. How might I see who is using my Access database?
E.g: There is someone with an Access database opened and it created the .ldb file, I would like to see a list of who opened that database (it could be more than one person).
2. How might I see who is using a linked table?
E.g: I have 10 different Access databases, and all of them are using a same linked table. I would like to see who is using that linked table.
I don't even know if it's really possible, but I really appreciate your help!
For you information: The main problem is that lots of people use the same Access in the same network drive, so when I need to change it I have to kick them all out, but I never know who is actually using it.
Update: Rather than reading and parsing the .ldb/.lacdb file, a better approach would be to use the "User Roster" feature of the Access OLEDB provider as described in the Knowledge Base article
https://support.microsoft.com/en-us/kb/285822
and in the other SO question
Get contents of laccdb file through VBA
Original answer:
I put together the following a while ago. It looked promising but then I discovered that computers are not immediately removed from the lock file when they disconnect. Instead, Jet/ACE seems to (internally) mark them as inactive: If ComputerA disconnects and then ComputerB connects, ComputerB overwrites ComputerA's entry in the lock file.
Still, it does provide a list of sorts. I'm posting it here in case somebody can offer some suggestions for refinement.
I created two tables in my back-end database:
Table: [CurrentConnections]
computerName Text(255), Primary Key
Table: [ConnectionLog]
computerName Text(255), Primary Key
userName Text(255)
A VBA Module in my back-end database contained the following code to read (a copy of) the lock file and update the [CurrentConnections] table:
Public Sub GetCurrentlyConnectedMachines()
Dim cdb As DAO.Database, rst As DAO.Recordset
Dim fso As Object '' FileSystemObject
Dim lck As Object '' ADODB.Stream
Dim lockFileSpec As String, lockFileExt As String, tempFileSpec As String
Dim buffer() As Byte
Set cdb = CurrentDb
cdb.Execute "DELETE FROM CurrentConnections", dbFailOnError
Set rst = cdb.OpenRecordset("SELECT computerName FROM CurrentConnections", dbOpenDynaset)
lockFileSpec = Application.CurrentDb.Name
If Right(lockFileSpec, 6) = ".accdb" Then
lockFileExt = ".laccdb"
Else
lockFileExt = ".ldb"
End If
lockFileSpec = Left(lockFileSpec, InStrRev(lockFileSpec, ".", -1, vbBinaryCompare) - 1) & lockFileExt
'' ADODB.Stream cannot open the lock file in-place, so copy it to %TEMP%
Set fso = CreateObject("Scripting.FileSystemObject") '' New FileSystemObject
tempFileSpec = fso.GetSpecialFolder(2) & "\" & fso.GetTempName
fso.CopyFile lockFileSpec, tempFileSpec, True
Set lck = CreateObject("ADODB.Stream") '' New ADODB.Stream
lck.Type = 1 '' adTypeBinary
lck.Open
lck.LoadFromFile tempFileSpec
Do While Not lck.EOS
buffer = lck.Read(32)
rst.AddNew
rst!computerName = DecodeSZ(buffer)
rst.Update
buffer = lck.Read(32) '' skip accessUserId, (almost) always "Admin"
Loop
lck.Close
Set lck = Nothing
rst.Close
Set rst = Nothing
Set cdb = Nothing
fso.DeleteFile tempFileSpec
Set fso = Nothing
End Sub
Private Function DecodeSZ(buf() As Byte) As String
Dim b As Variant, rt As String
rt = ""
For Each b In buf
If b = 0 Then
Exit For '' null terminates the string
End If
rt = rt & Chr(b)
Next
DecodeSZ = rt
End Function
The following code in the Main_Menu form of the front-end database updated the [ConnectionLog] table
Private Sub Form_Load()
Dim cdb As DAO.Database, rst As DAO.Recordset
Dim wshNet As Object '' WshNetwork
Set wshNet = CreateObject("Wscript.Network")
Set cdb = CurrentDb
Set rst = cdb.OpenRecordset("SELECT * FROM ConnectionLog", dbOpenDynaset)
rst.FindFirst "ComputerName=""" & wshNet.computerName & """"
If rst.NoMatch Then
rst.AddNew
rst!computerName = wshNet.computerName
Else
rst.Edit
End If
rst!userName = wshNet.userName
rst.Update
Set wshNet = Nothing
End Sub
Finally, the following form in the back-end database listed [its best guess at] the current connections
It is a "continuous forms" form whose Record Source is
SELECT CurrentConnections.computerName, ConnectionLog.userName
FROM CurrentConnections LEFT JOIN ConnectionLog
ON CurrentConnections.computerName = ConnectionLog.computerName
ORDER BY ConnectionLog.userName;
and the code-behind is simply
Private Sub Form_Load()
UpdateFormData
End Sub
Private Sub cmdRefresh_Click()
UpdateFormData
End Sub
Private Sub UpdateFormData()
GetCurrentlyConnectedMachines
Me.Requery
End Sub
Easy. Open the .ldb file in notepad (or any text editor) and you can see the machine names.
RE: How might I see who is using my Access database?
•E.g: There is someone with an Access database opened and it created the .ldb file, I would like to see a list of who opened that database (it could be more than one person).
Just happened across this while looking for something else, and I thought I might share what I do for this. Note that this assumes that the host computer (the computer on which the database file resides) uses file sharing to provide access to the file.
You will need to be on the host computer, or have authority to connect to that machine.
click Start
right-click My Computer and select Manage
if you're not on the host computer, right-click 'Computer Management' and enter the host's name
Expand 'Shared Folders' and click on 'Open Files'
At the right is the list of currently open files with the username for each current user
I agree with Gord's Original answer. I used this code on my database, it seems that there is a way around computers not being taken out of CurrentConnections upon exit of the DB.
I placed this on my main menu form because it is always open until the user exits. I used the unload event on my form to get this to work, and it works awesome! Here is my code
p.s. Ignore SetWarnings I just have that on so the user doesn't have to click through prompts.
Private Sub Form_Unload(Cancel As Integer)
Dim wshNet As Object
Dim deleteSQL As String
Set wshNet = CreateObject("WScript.Network")
DoCmd.SetWarnings False
deleteSQL = "DELETE tblCurrentConnections.* " & _
"FROM tblCurrentConnections WHERE[computerName] = '" & wshNet.computerName & "';"
DoCmd.RunSQL deleteSQL
DoCmd.SetWarnings True
End Sub
I have a form which contains a subform which displays editable fields linked to one my tables. For a project I'm currently working on, one of the requirements is that I have to track when the last change was made to a record and who did so.
So what I've done is for each editable textbox or combobox within the form and subform I've made it so they have events on their BeforeUpdate and AfterUpdate events.
For example my BeforeUpdate for a textbox:
Private Sub textbox_BeforeUpdate(Cancel As Integer)
If Not isValidUser Then
Cancel = True
Me.textbox.Undo
End If
End Sub
and my AfterUpdate is:
Private Sub textbox_AfterUpdate()
updateRecord Me.textbox.Value, UserNameWindows
End Sub
and updateRecord is:
Public Sub updateRecord(bucNumber As String, updater As String)
Dim Dbs As Object
Dim rst As Object
Dim fldEnumerator As Object
Dim fldColumns As Object
sqlStatement = "SELECT fName " & _
"FROM t_Staff " & _
"WHERE uName='" & updater & "';"
'Getting fullname of user via username
Set rst = CurrentDb.OpenRecordset(sqlStatement)
'Setting fullname to updater variable
updater = rst(0)
'Clean Up
Set rst = Nothing
'Opening Bucket Contents
Set Dbs = CurrentDb
Set rst = Dbs.OpenRecordset("Bucket Contents")
Set fldColumns = rst.Fields
'Scan the records from beginning to each
While Not rst.EOF
'Check the current column
For Each fldEnumerator In rst.Fields
'If the column is named Bucket No
If fldEnumerator.Name = "Bucket No" Then
'If the Bucket No of the current record is the same as bucketNumber
If fldEnumerator.Value = bucNumber Then
'Then change the updated fields by updater and todays date
rst.Edit
rst("Last Updated By").Value = updater
rst("Last Updated On").Value = Date
rst.Update
End If
End If
Next
'Move to the next record and continue the same approach
rst.MoveNext
Wend
'Clean Up
Set rst = Nothing
Set Dbs = Nothing
End Sub
Okay now is the weird thing, this works totally fine when I make a modification to a control within the Main form, however as soon as a try to alter something in the subform it throws up a write conflict.
If I opt to save record it ignores my code for updating who last modified it and when and if I opt to discard the change it runs my code and updates it that it has been changed!
Anyone know what is wrong or of a better way to do this?