I have code which takes a table, and rearranges the table to form a new table. It worked with a small amount of data, but now that I tried to run the same code with over 1,000 records, it is getting Error 28 which is "Out of stack space". I will not copy all of my code here because it would be way too much and I think unnecessary, unless you think otherwise. I think it is a problem with my recursion of the sub. I need this because a DONOR_CONTACT_ID can only have 4 recipients, if it has more, then it must create a new record with the same DONOR_CONTACT_ID and populate the recipients.
Here is the sub routine which is getting the error:
Sub NextDonor()
With rstOutput
.FindNext "[DONOR_CONTACT_ID] = " & strDonor2
'Find the next record in T_OUTPUT with that DONOR_CONTACT_ID
If .NoMatch Then
'If there are no more records with that DONOR_CONTACT_ID, add a new one
.AddNew
!DONOR_CONTACT_ID = strDonor1
!RECIPIENT_1 = strRecip1
!ORDER_NUMBER = strOrderNum1
.Update
Else
'A second DONOR_CONTACT_ID in T_OUTPUT exists. Check to see if all fields are filled.
If !DONOR_CONTACT_ID = strDonor2 Then
If IsNull(!RECIPIENT_2) And Not (IsNull(!RECIPIENT_1)) Then
'RECIPIENT_2 is empty, so populate it
.Edit
!RECIPIENT_2 = strRecip1
.Update
ElseIf IsNull(!RECIPIENT_3) And Not (IsNull(!RECIPIENT_2)) Then
'RECIPIENT_3 is empty, so populate it
.Edit
!RECIPIENT_3 = strRecip1
.Update
ElseIf IsNull(!RECIPIENT_4) And Not (IsNull(!RECIPIENT_3)) Then
'RECIPIENT_4 is empty, so populate it
.Edit
!RECIPIENT_4 = strRecip1
.Update
ElseIf Not IsNull(!RECIPIENT_4) Then
'RECIPIENT_4 is filled, so run this function again
Call NextDonor
End If
End If
End If
End With
End Sub
The error is in the line where it says "Call NextDonor", probably because of the recursion. If you need me to clarify what my code is trying to do, or if you want me to copy other parts of my code, just let me know.
Try this to avoid recursion ...
Sub NextDonor(byref Again as Boolean)
With rstOutput
DoItAgain :
.FindNext "[DONOR_CONTACT_ID] = " & strDonor2
If ....
....
ElseIf Not IsNull(!RECIPIENT_4) Then
'RECIPIENT_4 is filled, so run this function again
Goto DoItAgain
End If
End Sub
Actually your recursive code and 1st answer both skip past the recipient if the 4th slot is full, you iterate with another Find and you lose the current recipient! This also eliminates the recursion.
instead:
If .NoMatch or (not isnull(!recipient_4)Then
'If there are no more records with that DONOR_CONTACT_ID, add a new one
' or current record is full
.AddNew
!DONOR_CONTACT_ID = strDonor1
!RECIPIENT_1 = strRecip1
!ORDER_NUMBER = strOrderNum1
.Update
Else
Related
I have an On_Load() sub which checks the records present on a subform, record by record. For example, if the subform loads with 12 records on it, I need the sub to start with the first record, run a DCount (it checks if the job number appears on a different table), then move to the next record, and check that one, etc until it reaches the last record. Here's my code at the moment:
Set rst = Me.RecordsetClone
On Error Resume Next
rst.MoveFirst
'Put code to check keyword schedule here. First get job no
Do Until Me.Specific_Job_No.Value = "00"
strSpec = Format(Me.Specific_Job_No.Value, "00")
strJob = Left(Me.Parent.JobRef.Value, 18) + strSpec
'Then check if that job no is in slot 1, then 2, etc
If DCount("*", "tblKeywordsSchedule", "[Slot1] Like ""*" & strJob & "*""") > 0 Then
Me![Added to Schedule] = True
Me![Added to Schedule].Locked = True
Else
Me![Added to Schedule] = False
Me![Added to Schedule].Locked = False
End If
'Then go to next record
rst.MoveNext
Loop
My problem is, it gets stuck on rst.MoveNext and just keeps checking the first record over and over again. What am I doing wrong?
Your problem is that you cannot lock a field individually for each record.
So the [Added to Schedule] may change its locking during the loop but will keep the setting of the last record in the loop.
I have now sorted it out myself. Found TheSmileyCoder's answer on this page:
https://bytes.com/topic/access/answers/942501-looping-through-subform-records
I was referring to a form control (Me!) rather than the recordset clone to update the strSpec and strJob strings - that was all I needed to know.
If rst.RecordCount > 0 Then
With rst
rst.MoveFirst
Do While Not .EOF
strSpec = Format(rst![Specific Job No], "00")
strJob = Left(Me.Parent.JobRef.Value, 18) + strSpec
'Then check if that job no is in slot 1, then 2, etc
If DCount("*", "tblKeywordsSchedule", "[Slot1] Like ""*" & strJob & "*""") > 0 Then
.Edit
rst![Added to Schedule] = True
.Update
Else
.Edit
rst![Added to Schedule] = False
.Update
End If
.MoveNext
Loop
End With
End If
I am trying to use the .FindNext (and .FindPrevious) function on an update form "next button" to find the record that meets certain criteria.
Private Sub NextRecord_Click()
Dim foundmatch As Boolean
For x = 0 To 3 Step 1
With Me.RecordsetClone
.FindNext "[Sensitivity] = " & [TempVars]![AccessLevel] + x
If .NoMatch Then
foundmatch = False
Else
Me.Bookmark = .Bookmark
foundmatch = True
Exit For
End If
End With
Next
If foundmatch = False Then
MsgBox "No More Records"
End If
End Sub
Upon a user entering the database the users accesslevel is assigned to a temp variable (1 to 4), and each project has a sensitivity rating of 1 to 4. The code below was used and worked for both next and previous only in finding records when the sensitivity and accesslevel were equal but not for sensitivities below the users access level which they are qualified to see.
Private Sub PrevRecord_Click()
Dim Stringy As String
Stringy = "[Sensitivity] = " & [txtaccess]
With Me.RecordsetClone
.FindPrevious Stringy
If .NoMatch Then
MsgBox "No More Records"
Else
Me.Bookmark = .Bookmark
End If
End With
End Sub
Note: The form is pulled from a query with Sensitivity one of the fields, and [txtaccess] is a text box on the field with the default value set at [TempVars]![AccessLevel]. I've also tried changing it to:
Stringy = "[Sensitivity] >= " & [txtaccess]
but that doesn't work either
I was able to fix the problem by setting applying a filter for sensitivity on the actual forms On_Load event rather than the command button. It now works using a next record command button added with the default code/settings!
The 1st record in the open order table matches a record in the Bookings table but the NO MATCH = True is happening and therefore it goes down thru the code anf tries to insert a new record. This is true for several records in the file and it tries to add the record even though there is a match. If I set the NO MATCH = False then it does the else. I imported these table from Access 97 to 2010 where it is working correctly. Any help would be appreciated.
Additional note: While in Debug, If I hover the mouse over the .Seek "=", TempCust, TempPart fields, it shows the 1st record in the table and that data is in the Bookings table. Not understanding why it is not matching?
Sub Get_Current_Info()
DoCmd.SetWarnings False
Dim rstOpenOrd, rstBookings As Recordset
Dim TempCust, TempPart, TempQty, TempDollars As Variant
Set rstOpenOrd = CurrentDb.OpenRecordset("Open Orders", dbOpenTable)
Set rstBookings = CurrentDb.OpenRecordset("Bookings", dbOpenTable)
'Get the open orders
Do While Not rstOpenOrd.EOF
With rstOpenOrd
TempCust = !ODCSNO
TempPart = !ODITNO
TempQty = !ODQTOR
TempDollars = !OrdDollars
End With
With rstBookings
.Index = "PrimaryKey"
.Seek "=", TempCust, TempPart
If rstBookings.NoMatch = True Then
With rstBookings
.AddNew
!cusno = TempCust
!PrdNo = TempPart
!Qty_booked = TempQty
!Dol_booked = TempDollars
!Yest_qty_booked = 0
!Yest_dol_booked = 0
!Shipped_qty = 0
!Shipped_dol = 0
.Update
End With
Else
With rstBookings
.Edit
!Qty_booked = !Qty_booked + TempQty
!Dol_booked = !Dol_booked + TempDollars
.Update
End With
End If
End With
rstOpenOrd.MoveNext
Loop
End Sub
This line suppresses information, including many types of error information ...
DoCmd.SetWarnings False
I don't see why you would want it at all in this procedure. But, at least during troubleshooting, make sure SetWarnings is on ...
'DoCmd.SetWarnings False
DoCmd.SetWarnings True
The point is that you need every possible tidbit of information you can get while troubleshooting. Don't suppress any of it.
The code would not do what you expect if the Bookings table does not include an index named PrimaryKey, or if that index does not include cusno and PrdNo (in that order) as its first 2 keys.
But that is just speculation. You need to test with SetWarnings on and see whether Access gives you useful details.
You must dim your variables or they are just Variant/Object:
Dim rstOpenOrd As DAO.Recordset
Dim rstBookings As DAO.Recordset
I'm in the process of converting an Access Data Project (ADP) into a standard ACCDB format with ODBC linked tables. In the ADP, I had overridden the Refresh button to return the user to the current record by using the following code:
Public Sub RibbonCmd_RefreshScreen(ctl As IRibbonControl, ByRef cancelDefault)
On Error GoTo ErrHandler
cancelDefault = False
DoCmd.Echo False
Dim saveBookmark
With Screen.ActiveForm
saveBookmark = .Bookmark
.Requery
.Bookmark = saveBookmark
End With
'Success - cancel the default behavior
cancelDefault = True
ExitHandler:
DoCmd.Echo True
Exit Sub
ErrHandler:
cancelDefault = False
Resume ExitHandler
End Sub
My understanding is that this should work just fine with DAO, but I get error 3159, Not a valid bookmark. I've also tried replacing .Bookmark with .Recordset.Bookmark, but that gave me the same result. Is there something I'm doing wrong here?
Actually, a requery of a form or a requery of a recordset will re-set and invalidate book marks.
So such book marks are no longer valid after a requery.
So the best approach here will depend on either
a) I simply want to re-display any changed records (and not move off current record).
b) I simply want to re-display any changed records AND ALSO display new records (the new records is the critical part).
If you just need a refresh, then you can use the appropriately called command refresh.
Eg:
Me.Refresh
Or in your case
Screen.ActiveForm.Refresh
So the above is ONE line of code and is ALL you need. The current record pointer for the form does NOT change when you use this command. All and any record changed will re-display for you.
Note that since you can behind the form button use:
Me.Refresh
Then LITTLE need is required to call a general routine as you have written.
However, if you need the form to "load" or display any new records added, then you DO have to use requery. In this case as noted book marks in this case all become invalid.
So, for code to requery, then we use the PK value (and hopefully you used the default pk of ID that been the default for 20 years). The code would then become:
Dim lngID As Long
If IsNull(Me!ID) Then Exit Sub
lngID = Me!ID
Me.Requery
Me.Recordset.FindFirst "id = " & lngID
Now of course if the PK id is not the same for each form, then you most certainly could pass the NAME of the PK value to your "general" refresh routine. It would look like:
Public Sub MyRefresh(strPK As String)
Dim lngID As Long
If IsNull(Me(strPK)) Then Exit Sub
lngID = Me(strPK)
Me.Requery
Me.Recordset.FindFirst strPK & " = " & lngID
End Sub
The "hope" here is you actually really JUST need refresh, since as noted this is only one line of code, and better yet it does NOT move the record pointer.
I use VB6 and Visual Data Manager in development. I have had the same problem. Most probably it arose when 2 users tried to update the same record in the same time. So some fields in the table are corrupted.
Here are the steps I used to solve the problem:
1- Copy the structure of the table (lets call it table1)to another table (lets call it table2).
2- Find the correpted record(s) in table1.
3- Transfer the data from table1 to table2 except the corrupted record(s)
4- Reenter the excluded record(s) to table2 again.
5- Rename table1 table3
6- Rename table2 table1
That's all folk
abdobox#yahoo.com
I have used the forms Recordset.AbsolutePosition, and this works fine e.g. in the OnKeyDown exit of a field
Dim PrefilterPosition As Long
Private Sub ValnSubject_KeyDown(KeyCode As Integer, Shift As Integer)
' Not F2 - exit
If KeyCode <> vbKeyF2 Then Exit Sub
' Get the active control
Dim ActiveCtl As Control
Set ActiveCtl = Me.ActiveControl
ActiveControlName = ActiveCtl.Name
' Is the form's filter set?
If Me.Filter = "" Then
' NO: Apply the new filter
' Note the current position in the recordset
PrefilterPosition = Me.Recordset.AbsolutePosition
' Set the filter to the Active control's value
Me.Filter = "[" & ActiveCtl.ControlSource & "]='" & ActiveCtl.Value & "'"
Me.FilterOn = Me.Filter <> ""
Me.Requery
Else
' YES: Clear the filter
Me.Filter = ""
Me.FilterOn = Me.Filter <> ""
Me.Requery
' Align the recordset on the previously stored position
Me.Recordset.AbsolutePosition = PrefilterPosition
End If
' Restore the cursor to where it came from
Me.Controls(ActiveControlName).SetFocus
Ex_it:
End Sub
For context: this code was from an idea for an 'Instant Filter', where you position the cursor on a field in a tab form, press F2, and then a filter is applied so you see only records with the selected field's value. Press F2 again and the filter is removed and the cursor goes back into the place it was when you hit F2 the first time. Bookmarks do not work here, as Albert says above.
I am creating a bill of materials program.
There are two main tables named Products and Sub_Products.
In the Products table, the fields are (Product_Name, Code).
In the Sub_Products table, the fields are (Code, Sub_Name).
The tables are linked with code, i.e.: one product is made up of many sub_products, each sub_product is a product as well, making it have many sub_products.
I have created a query that reads a product and gets its sub_products. I need a query to compare Sub_Name with Product_Name and then check more sub_products,
continuing until no more sub_products are found.
Any ideas?
I guess you will have to use a script rather than SQL query to loop through them. Assuming that the products can be nested more than 3 levels.
I've been working on this exact problem in an ASP.NET MVC application. A function that gathered all the subproducts for each product and recursed on each subproduct worked well. We have some BOMs that are 15 levels deep.
I realize this question was asked a long time ago, but I had a very similar question and finally figured out a good answer. So I am posting it here in case anyone needs to know how to create a Bill of Materials.
In my example there is a table called "Part_Item_Table" which lists parent items and all of their childeren. Those childeren can also be parents to other childeren. The difficulty was that the BOM could be 3 levels deep all the way up to 30 levels deep or more. My "Part_Item_Table" also lists whether items are "Make" items or not. Only "Make" items will have childeren. The table you are querying may not have that feature, but the code below will probably still be helpful to get the idea.
This set of code uses several things that were new to me such as recursive code, calling a query I had already created and passing in a variable using the querydef methods, and using recordsets to get large information sets in and out of functions. I also used a sequence field in my BOM Table so I could sort by it and view the BOM in the order it is meant to be (Showing visually which level 3 items roll up into which level 2 items). If there is something that can be improved I am open to suggestions. This does work for my needs right now and hopefully it is helpful to someone else.
Option Compare Database
Public stFirstPart As String
Private Const BOMTable As String = "BOM_Table" 'Set this variable to the name of the table
Private Const ComponentQ As String = "GetComponentsQ" 'Set to the name of the query in the database
Function BOM()
Dim stQuery As String 'Used to make a query
Dim i As Integer 'Used to create the sequence number
Dim iLevel As Integer 'Used to show BOM level
Dim rsParent, rsBOMTable As DAO.Recordset 'Used to hold query results
'Make sure there is a part number in the form
If IsNull(Forms![Entry Form]![Part_Number]) Then
Debug.Print "There is no part number entered in the form"
MsgBox "There is no part number in the form.", vbOKOnly, "Can't fool me."
Exit Function
End If
stFirstPart = Forms![Entry Form]![Part_Number] 'Get the top part number from the form
'Make sure this is a Make item. Only make items will have childeren
stQuery = "SELECT ITEM.ITEM_NO, ITEM.MAKE_BUY_FLAG, ITEM.CURRENT_FLAG " & _
" FROM PART_ITEM_TABLE AS ITEM " & _
" WHERE (((ITEM.ITEM_NO)='" & stFirstPart & "') AND ((ITEM.MAKE_BUY_FLAG)='M') AND ((ITEM.CURRENT_FLAG)='Y'));"
Set rsParent = CurrentDb.OpenRecordset(stQuery)
If rsParent.EOF And rsParent.BOF Then
Debug.Print "This is not a make item"
MsgBox "This is not a Make item.", vbOKOnly, "I tried."
Exit Function
End If
'Clear the BOM table and load this first part number
DoCmd.SetWarnings False
DoCmd.RunSQL "Delete from " & BOMTable & ""
Set rsBOMTable = CurrentDb.OpenRecordset(BOMTable, dbOpenDynaset)
i = 1
iLevel = 1
rsParent.MoveFirst
With rsBOMTable
.AddNew
!Sequence = i
!Level = iLevel
!Item_Number = stFirstPart
!Make_Buy = "M"
.Update
End With
rsParent.Close
Set rsParent = Nothing
rsBOMTable.Close
Set rsBOMTable = Nothing
'-----------------------------------------------------------------------------------------------------------------------------------
'Start going down levels
'-----------------------------------------------------------------------------------------------------------------------------------
iLevel = 2
Call RecursiveLevels(stFirstPart, iLevel, i)
DoCmd.SetWarnings True
End Function
Function RecursiveLevels(PartNumber As String, iLevel As Integer, i As Integer)
Dim rsLevels As DAO.Recordset
Dim stPart As String
Set rsLevels = GetComponents(PartNumber)
If rsLevels.BOF And rsLevels.EOF Then
Debug.Print "This was a Make item with no children. That shouldn't happen. "; PartNumber
GoTo ExitPoint
End If
rsLevels.MoveFirst
Do While Not rsLevels.EOF
If rsLevels!Make_Buy <> "M" Then ' Anything that is not a Make item is written to the BOM table one line at a time.
i = i + 1
Call WriteToBOMTable(iLevel, i, rsLevels!Parent_Number, rsLevels!Component_Number, rsLevels!Make_Buy)
Else 'The Make item is written to the table, then we query for all of its children
stPart = rsLevels!Component_Number
i = i + 1
Call WriteToBOMTable(iLevel, i, rsLevels!Parent_Number, rsLevels!Component_Number, rsLevels!Make_Buy)
If stPart = stFirstPart Then 'Check to make sure this recursive thing doesn't go on forever.
Debug.Print "This part number is the same as the first part number. Circ Reference. "; stPart
GoTo ExitPoint
End If
iLevel = iLevel + 1 ' get ready to go one level deeper
Call RecursiveLevels(stPart, iLevel, i)
End If
rsLevels.MoveNext
Loop
ExitPoint:
iLevel = iLevel - 1 'Done with this level. Come back up a level.
rsLevels.Close
Set rsLevels = Nothing
End Function
Function WriteToBOMTable(Level As Integer, i As Integer, ParentNumber As String, ComponentNumber As String, MakeBuy As String)
Dim rsBOMTable As DAO.Recordset
Set rsBOMTable = CurrentDb.OpenRecordset(BOMTable, dbOpenDynaset)
With rsBOMTable
.AddNew
!Parent_Number = ParentNumber
!Item_Number = ComponentNumber
!Level = Level
!Make_Buy = MakeBuy
!Sequence = i
.Update
End With
Debug.Print "Level: "; Level; "Component: "; ComponentNumber
rsBOMTable.Close
Set rsBOMTable = Nothing
End Function
Function GetComponents(PartNumber As String) As DAO.Recordset
Dim qdf As QueryDef
Set qdf = CurrentDb.QueryDefs(ComponentQ)
qdf.Parameters("PartNumber") = PartNumber
Set GetComponents = qdf.OpenRecordset
End Function