I am writing a function that checks if the amount paid is equal or more to a number of items selected if they are checked. For this example there are 10 items with 10 check boxes. I could check one or more boxes in any order.If an item or more meets the condition it is cleared otherwise it remains.
Public Sub processItem1()
Dim db As DAO.Database
Dim pr As DAO.Recordset, so As DAO.Recordset
Dim strSQL1 As String
Dim strSQL2 As String
Set db = CurrentDb
strSQL1 = "SELECT * FROM PharmSales WHERE PharmSalesID= (SELECT MAX(PharmSalesID) FROM PharmSales WHERE HospitalNo='" & Me.txtRegNo & "' And TDate = #" & Format(Me.txtTDate, "M\/dd\/yyyy") & "# AND SalesItem1 = '" & Me.txtSalesItem1 & "')"
strSQL2 = "SELECT * FROM tblItem WHERE ItemName = '" & Me.txtSalesItem1 & "'"
Set pr = db.OpenRecordset(strSQL1)
Set so = db.OpenRecordset(strSQL2)
With pr
If Not .BOF And Not .EOF Then 'Ensure that the recordset contains records
.MoveLast
.MoveFirst
If .Updatable Then 'To ensure record is not locked by another user
.Edit 'Must start an update with the edit statement
![DispQty1] = Nz(![DispQty1] + Me.txtSalesQty1.Value, 0)
.Update
End If
End If
pr.Close 'Make sure you close the recordset..
Set pr = Nothing '...and set it to nothing
Set db = Nothing
End With
With so
If Not .BOF And Not .EOF Then 'Ensure that the recordset contains records
.MoveLast
.MoveFirst
If .Updatable Then 'To ensure record is not locked by another user
.Edit 'Must start an update with the edit statement
![Stock_Out] = Nz(![Stock_Out] + Me.txtSalesQty1.Value, Me.txtSalesQty1.Value)
![SO_Date] = Me.txtTDate
![Stock_In] = Nz(![Stock_In] + 0, 0)
.Update 'And finally we will need to confirm the update
End If
End If
so.Close 'Make sure you close the recordset..
ExitSub:
Set so = Nothing '...and set it to nothing
Set db = Nothing
End With
End Sub
For processItem2:
Public Sub processItem2()
Dim db As DAO.Database
Dim pr As DAO.Recordset, so As DAO.Recordset
Dim strSQL1 As String
Dim strSQL2 As String
Set db = CurrentDb
strSQL1 = "SELECT * FROM PharmSales WHERE PharmSalesID= (SELECT MAX(PharmSalesID) FROM PharmSales WHERE HospitalNo='" & Me.txtRegNo & "' And TDate = #" & Format(Me.txtTDate, "M\/dd\/yyyy") & "# AND SalesItem2 = '" & Me.txtSalesItem2 & "')"
strSQL2 = "SELECT * FROM tblItem WHERE ItemName = '" & Me.txtSalesItem2 & "'"
Set pr = db.OpenRecordset(strSQL1)
Set so = db.OpenRecordset(strSQL2)
With pr
If Not .BOF And Not .EOF Then 'Ensure that the recordset contains records
.MoveLast
.MoveFirst
If .Updatable Then 'To ensure record is not locked by another user
.Edit 'Must start an update with the edit statement
![DispQty2] = Nz(![DispQty2] + Me.txtSalesQty2.Value, 0)
.Update
End If
End If
pr.Close 'Make sure you close the recordset..
Set pr = Nothing '...and set it to nothing
Set db = Nothing
End With
With so
If Not .BOF And Not .EOF Then 'Ensure that the recordset contains records
.MoveLast
.MoveFirst
If .Updatable Then 'To ensure record is not locked by another user
.Edit 'Must start an update with the edit statement
![Stock_Out] = Nz(![Stock_Out] + Me.txtSalesQty2.Value, Me.txtSalesQty2.Value)
![SO_Date] = Me.txtTDate
![Stock_In] = Nz(![Stock_In] + 0, 0)
.Update 'And finally we will need to confirm the update
End If
End If
so.Close 'Make sure you close the recordset..
ExitSub:
Set so = Nothing '...and set it to nothing
Set db = Nothing
End With
End Sub
Don't ever copy&paste code like this. It is a maintenance nightmare.
You can loop over objects by concatenating their name at runtime:
Me("txtSalesItem" & i) ' form control
pr("DispQty" & i).Value ' recordset field
etc.
Side note:
With recordset
.MoveLast
.MoveFirst
These MoveLast/MoveFirst commands are unnecessary. You only need them if you want to get the correct .RecordCount of a recordset.
Related
I am trying to duplicate a form from a button using vba. This has worked for years using Allen Browne's "Duplicate the record in form and subform." http://allenbrowne.com/ser-57.html
Now I want to change one of the fields to multivalue. I understand the difficulties with multivalued fields, but this is a 10 year old database and all I need to do is make this field be able to store multiple values, so think this will be easier than creating a new join table and updating everything related.
I am currently getting Invalid use of Property at the rstmv = rstmv.Value line.
I have tried numerous versions and get different errors. I think I should be opening the values of the multi-value field as a separate recordset, updating it then looping through the values but I am getting confused as I am not really sure what I am doing.
Here is the code I I have been using:
'On Error GoTo Err_Handler
'Purpose: Duplicate the main form record and related records in the subform.
Dim strSql As String 'SQL statement.
Dim lngID As Long 'Primary key value of the new record.
Dim rst As Recordset
Dim rstmv As Recordset2
'Save and edits first
If Me.Dirty Then
Me.Dirty = False
End If
'Make sure there is a record to duplicate.
If Me.NewRecord Then
MsgBox "Select the record to duplicate."
Else
'Duplicate the main record: add to form's clone.
With Me.RecordsetClone
.AddNew
!Site_Name = Me.Site_Name
!Date_of_Dive = Me.Date_of_Dive
!Time_of_Dive = Me.Time
Set rst = Me.RecordsetClone
Set rstmv = rst!Staff.Value
Do While Not rstmv.EOF
rsp.Edit
rstmv.Edit
rstmv.AddNew ' Add a new record to the asp Recordset
rstmv = rstmv.Value
rstmv.Update ' Commit the changes to the asp Recordset
imt.MoveNext
Loop
.Update
!O2 = Me.O2
!First_Aid = Me.First_Aid
!Spares = Me.Spares
'etc for other fields.
.Update
'Save the primary key value, to use as the foreign key for the related records.
.Bookmark = .LastModified
lngID = !Dive_Number
'Duplicate the related records: append query.
If Me.[DiveDetailssubform].Form.RecordsetClone.RecordCount > 0 Then
strSql = "INSERT INTO [DiveDetails] (Dive_Number, CustDateID, Type, Price) " & _
"SELECT " & lngID & " As NewID, CustDateID, Type, Price " & _
"FROM [DiveDetails] WHERE Dive_Number = " & Me.Dive_Number & ";"
DBEngine(0)(0).Execute strSql, dbFailOnError
Else
MsgBox "Main record duplicated, but there were no related records."
End If
'Display the new duplicate.
Me.Bookmark = .LastModified
MsgBox "Dive Sucessfully Duplicated. DONT FORGET TO CHANGE THE SITE NAME."
End With
End If
Exit_Handler:
Exit Sub
Err_Handler:
MsgBox "Error " & Err.Number & " - " & Err.Description, , "Duplicate_Click"
Resume Exit_Handler
End Sub
Private Sub Form_Load()
Dim varID As Variant
Dim strDelim As String
'Note: If CustomerID field is a Text field (not a Number field), remove single quote at start of next line.
'strDelim = """"
varID = DLookup("Value", "tblSys", "[Variable] = 'DiveIDLast'")
If IsNumeric(varID) Then
With Me.RecordsetClone
.FindFirst "[dive_number] = " & strDelim & varID & strDelim
If Not .NoMatch Then
Me.Bookmark = .Bookmark
End If
End With
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
Dim rs As DAO.Recordset
If Not IsNull(Me.Dive_Number) Then
Set rs = CurrentDb().OpenRecordset("tblSys", dbOpenDynaset)
With rs
.FindFirst "[Variable] = 'DiveIDLast'"
If .NoMatch Then
.AddNew 'Create the entry if not found.
![Variable] = "DiveIDLast"
![Value] = Me.Dive_Number
![Description] = "Last DiveID, for form Dive Planner" & Me.Name
.Update
Else
.Edit 'Save the current record's primary key.
![Value] = Me.Dive_Number
.Update
End If
End With
rs.Close
End If
Set rs = Nothing
End Sub
Need recordsets of source data and recordsets for destination. Also should explicitly declare the recordset type as DAO. Consider:
Dim strSql As String 'SQL statement.
Dim lngID As Long 'Primary key value of the new record.
Dim rstF As DAO.Recordset
Dim rstT As DAO.Recordset
Dim rstmvF As DAO.Recordset2
Dim rstmvT As DAO.Recordset2
'Save any edits first
If Me.Dirty Then
Me.Dirty = False
End If
'Make sure there is a record to duplicate.
If Me.NewRecord Then
MsgBox "Select the record to duplicate."
Else
Set rstF = CurrentDb.OpenRecordset("SELECT * FROM Dives WHERE Dive_Number = " & Me.Dive_number)
Set rstmvF = rstF!Staff.Value
'Duplicate the main record: add to form's clone.
With Me.RecordsetClone
.AddNew
!Site_Name = Me.Site_Name
!Date_of_Dive = Me.Date_of_Dive
!Time_of_Dive = Me.Time
!O2 = Me.O2
!First_Aid = Me.First_Aid
!Spares = Me.Spares
.Update
'Save the primary key value of new record.
.Bookmark = .LastModified
lngID = !Dive_number
Set rstT = CurrentDb.OpenRecordset("SELECT * FROM Dives WHERE Dive_Number = " & lngID)
Set rstmvT = rstT!Staff.Value
rstT.Edit
Do While Not rstmvF.EOF
rstmvT.AddNew ' Add a new record to the asp Recordset
rstmvT!Value = rstmvF!Value
rstmvT.Update ' Commit the changes to the asp Recordset
rstmvF.MoveNext
Loop
rstT.Update
I am trying to go through my forms checkboxes and If True, I need to check to see if the record exists and then, If it exists and True - Do Nothing. If True and Doesn't exist - Add the record.
If False - I also need to check if it exists and If it exists - Delete it, and If it doesn't - Do nothing.
I have tried using just recordset and looping through the table.
I also tried using DLookup and just got lost with needing three criteria values to find the record.
Now I am trying to use both recordset and SQL and keep getting the error "too few parameters".
RT = "Rise Time"
If Me.RiseTime.Value = True Then
strSQL = "SELECT * FROM Weekly_StartTime_Challenges WHERE UserID = '" &
Me.UserID.Value & "' AND WeekNumber = '" & Me.WeekNumber.Value
& "' AND StartTimeAction =" & RT
Set sast = db.OpenRecordset(strSQL, dbOpenDynaset)
If Not sast.EOF And sast.BOF Then
' It Does Exist and Do Nothing
Else
sast.AddNew
sast!WeekNumber = Me.WeekNumber.Value
sast!StartDate = Me.StartDate.Value
sast!UserID = Me.UserID.Value
sast!FullName = Me.FullName.Value
sast!Index = 1
sast!Tab1 = 8
sast!StartTimeAction = RT
sast.Update
End If
Else
strSQL = "SELECT * FROM Weekly_StartTime_Challenges WHERE UserID = '" &
Me.UserID.Value & "' AND WeekNumber = '" & Me.WeekNumber.Value & "' AND
StartTimeAction = RT"
Set sast = db.OpenRecordset(strSQL, dbOpenDynaset)
If Not sast.EOF And sast.BOF Then
' It Does Exist and needs deleted
sast.Delete
Else
End If
End If
Do it step by step. For example if you want to check if a record exists:
If DCount("ColumnName", "TableName", "ID = 4") = 0 Then
MsgBox "No Record Found"
'Do stuf
Else
MsgBox "Record/Records found"
'Do other stuf
End If
If you find a record/s you can loop through it with a recordset:
Dim rs As RecordSet
Set rs = CurrentDb.OpenRecordset("Select * From Table", dbOpenDynaset)
rs.MoveFirst
Do Until rs.EOF
If "You want to Update the record" = True Then 'Apply your update condition
rs.Edit
rs.ID = 4 'Change ID
rs.Name = "New Name" 'Change Name
rs.Update
Else
'Do other stuf
End If
rs.MoveNext
Loop
rs.close
Set rs = Nothing
For changing a datarow you need always recordset rs.Edit and in the end rs.Update.
I have a first table called "BreedingTable" with primary key "ID" and "TransactionStatus" = "Active".
I have "Kidding form" data populated from the combo box to Text fields
Text2.value = "ID" from BreedingTable.
When I am done with all the process, I want to change TransactionStatus of Breeding table = Closed.
I am using the below code but it never works.
Note" if I give exact transaction id number it works fine,
but if I ask to find based on text2 it doesn't work.
My code is as follows:
Private Sub exitprograme3()
Me.Text2.SetFocus
Dim i As Integer
Dim db As Database
Dim rs As Recordset
Dim Trn As Integer
Set db = CurrentDb
Set rs = db.OpenRecordset("BreedingTable")
For i = 0 To rs.RecordCount - 1
Me.Text2.SetFocus
If rs.Fields("ID") = Me.Text2.Value Then
rs.Edit
rs.Fields("BreedingStatus") = "Closed"
rs.Update
End If
rs.MoveNext
Next i
rs.Close
Set rs = Nothing
db.Close
DoCmd.Close
End Sub
Please assist ...
If I type exact transaction id number in below if statement it works
If rs.Fields("ID") = "323" Then
this works fine.
But if I type like below it doesn't work
If rs.Fields("ID") = Me.Text2.Value Then
No loop is needed:
Private Sub exitprograme3()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Set db = CurrentDb
Set rs = db.OpenRecordset("Select * From BreedingTable")
rs.FindFirst "[ID] = " & Me!Text2.Value & ""
' If ID is text, then quotes:
' rs.FindFirst "[ID] = '" & Me!Text2.Value & "'"
If Not rs.NoMatch Then
rs.Edit
rs.Fields("BreedingStatus").Value = "Closed"
rs.Update
End If
rs.Close
Set rs = Nothing
Set db = Nothing
DoCmd.Close
End Sub
Within the following code
Dim sqlStr As String
Dim OrgID As Long
Dim wrk As DAO.Workspace
Dim db As DAO.Database
Dim orgRS As DAO.Recordset
Dim staffRS As DAO.Recordset
Set wrk = DBEngine.Workspaces(0)
Set db = CurrentDb
On Error GoTo trans_Err
InsertOrganizationIntoTemp
'if staff fields are not blank Insert Staff into Temp
If (addStaffClickCheck = True) Then
staffNumber = staffNumber + 1
InsertStaffIntoTemp staffNumber
End If
wrk.BeginTrans
sqlStr = "INSERT INTO tblOrganization(OrganizationName, Affiliate, " _
& " UnionCouncil, DateJoined, OrganizationPhoneNumber, OrganizationFaxNumber, " _
& " MembershipGroup, TradeGroup, URL) " _
& " SELECT OrganizationName, Affiliate, CouncilUnion, DateJoined, OrganizationPhone, " _
& " OrganizationFax, MemberGroup, Trade, OrganizationWebsite " _
& " FROM tblTempOrganization;"
db.Execute sqlStr
OrgID = db.OpenRecordset("SELECT ##IDENTITY")(0)
sqlStr = "INSERT INTO tblAddresses(StreetName, CityName, StateName, " _
& " ZipCode, LocationID, OrganizationID) " _
& " SELECT OrganizationAddress, OrganizationCity, OrganizationState, " _
& " OrganizationZIP, OrganizationLocationType, '" & OrgID & "' " _
& " FROM tblTempOrganization;"
db.Execute sqlStr
'pull all staff and phones into two recordsets
'loop through staff and for each staff member add associated phone information
'Recordsets for temporary staff tables
Dim staffTempInfoRS As DAO.Recordset
Dim phoneTempInfoRS As DAO.Recordset
Set staffTempInfoRS = db.OpenRecordset("SELECT * FROM tblTempStaff", dbOpenDynaset)
'Recordsets for permanant staff tables
Dim StaffAddressID As Long
Dim StaffID As Long
'Check to see if the recordset actually contains rows
If Not (staffTempInfoRS.EOF And staffTempInfoRS.BOF) Then
staffTempInfoRS.MoveFirst 'Unnecessary in this case, but still a good habit
Do Until staffTempInfoRS.EOF = True
'address information
Dim staffAddressDBRS As DAO.Recordset
Set staffAddressDBRS = db.OpenRecordset("tblStaffAddresses", dbOpenDynaset)
With staffAddressDBRS
.AddNew
.Fields("StaffStreet") = staffTempInfoRS.Fields("StaffStreet")
.Fields("StaffCity") = staffTempInfoRS.Fields("StaffCity")
.Fields("StaffState") = staffTempInfoRS.Fields("StaffState")
.Fields("StaffZip") = staffTempInfoRS.Fields("StaffZip")
.Update
End With
StaffAddressID = staffAddressDBRS.LastModified
staffAddressDBRS.Close
Set staffAddressDBRS = Nothing
'staff information
Dim staffInfoDBRS As DAO.Recordset
Set staffInfoDBRS = db.OpenRecordset("tblStaff", dbOpenDynaset)
With staffInfoDBRS
.AddNew
.Fields("StaffFirstName") = staffTempInfoRS.Fields("StaffFirstName")
.Fields("StaffLastName") = staffTempInfoRS.Fields("StaffLastName")
.Fields("Email") = staffTempInfoRS.Fields("Email")
.Fields("StaffAddressID") = StaffAddressID
.Fields("OrganizationID") = OrgID
.Fields("Position") = staffTempInfoRS.Fields("StaffPosition")
.Update
End With
Dim currPos As Long
currPos = staffTempInfoRS.Fields("StaffNumber")
StaffID = staffInfoDBRS.LastModified
staffInfoDBRS.Close
Set staffInfoDBRS = Nothing
'staff phone information
Set phoneTempInfoRS = db.OpenRecordset("SELECT * FROM tblTempPhones WHERE StaffNumber = " & currPos & ";")
If Not (phoneTempInfoRS.EOF And phoneTempInfoRS.BOF) Then
phoneTempInfoRS.MoveFirst 'Unnecessary in this case, but still a good habit
Do Until phoneTempInfoRS.EOF = True
Dim phoneInfoDBRS As DAO.Recordset
Set phoneInfoDBRS = db.OpenRecordset("tblStaffPhoneNumbers", dbOpenDynaset)
With phoneInfoDBRS
.AddNew
.Fields("PhoneNumber") = phoneTempInfoRS.Fields("StaffPhoneNumber")
.Fields("PhoneTypeID") = phoneTempInfoRS.Fields("PhoneType")
.Fields("StaffID") = StaffID
.Update
End With
phoneTempInfoRS.MoveNext
Loop
Else
Resume Next
End If
MsgBox "Finished looping through phone records."
phoneTempInfoRS.Close
Set phoneTempInfoRS = Nothing
'Move to the next record. Don't ever forget to do this.
staffTempInfoRS.MoveNext
Loop
Else
MsgBox "There are no records in the staff recordset."
End If
MsgBox "Finished looping through staff records."
staffTempInfoRS.Close 'Close the recordset
Set staffTempInfoRS = Nothing 'Clean up
wrk.CommitTrans
trans_Exit:
'Clean up
wrk.Close
Set db = Nothing
Set wrk = Nothing
Exit Function
trans_Err:
'Roll back the transaction
MsgBox "Whoops! We got errors"
wrk.Rollback
Resume trans_Exit
When I step through this I get an error in this line:
.Fields("StaffStreet") = staffTempInfoRS.Fields("StaffStreet")
That says:
Item not found in collection.
However, this is the exact field name that is in the table that the recordset is set to open.
30 hours later it seems I suffered a rookie mistake and in-spite of repeated checking missed that the field names were indeed misspelled.
I also set the recordsets outside of the loops and I unset them all in the exit snippet...
I hope you can assist. For some reason I can not think of what I am doing wrong. Maybe a fresh pair of eyes would help.
pulling GL's and their currency value from a query.
each GL needs to populate text boxes in a report with have sequential names. Ex: GL1, GL2, GL3, etc.
Each GL Value (currency) needs to populate other text boxes named uniquely. Ex: GLV1, GLV2, GLV3, GLV4, etc.
Here is my script - any help would be appreciated.
Dim rs As DAO.Recordset
Set rs = CurrentDb.OpenRecordset("SELECT * FROM qry_GL_totals")
Dim GLField As Variant
If Not (rs.EOF And rs.BOF) Then
rs.MoveFirst 'Unnecessary in this case, but still a good habit
RecordCount = 0
Do Until rs.EOF = True
RecordCount = RecordCount + 1
MsgBox (rs!GL & " " & rs!Expr1) 'MsgBox is just for testing
"[" & GLField & "]" =rs!GL
"[" & GLField & "T]" =rs!Expr1
rs.MoveNext
Loop
Else
End If
rs.Close
Set rs = Nothing
GLField = Null
End Sub
Update: This is what I have now and its failing still.
Private Sub Report_Load()
Dim rs As DAO.Recordset
Set rs = CurrentDb.OpenRecordset("SELECT * FROM qry_GL_totals")
If Not (rs.EOF And rs.BOF) Then
rs.MoveFirst
i = 0
Do Until rs.EOF = True
i = i + 1
Me.Controls(GLField) = rs!GL
Me.Controls(GLField & "T") = rs!Expr1
rs.MoveNext
Loop
Else
End If
rs.Close
Set rs = Nothing
End Sub
Run-time error "438" Object doesn't support this property or method.
Maybe try:
Me.Controls(GLField) = rs!GL
Me.Controls(GLField & "T") = rs!Expr1
For your updated code:
Me.Controls("GL" & i) = rs!GL
Me.Controls("GLV" & i) = rs!Expr1
assuming your controls are named "GL1", "GL2", "GLV1", "GLV2" etc