This isnt my code but I need to fix it. I get an error saying 'Cannot Update. Database or object is read-only' and it highlights '.Edit'. From what i understand one of the tables are going to be updated if there were changes made in the other table. It doesn't seem to be doing that though. I tried putting rsCH before the .Edit and rsOO as well to see if it would fix the issue but it doesnt.
Function DefineOrderChanges()
' this function defines the order changes for any order that is in the query OpenOrdersOnOrderImportFile
' it looks at 6 fields and captures the changes in the Changes file
' need to also develop an order change acknowledgement process. Send out an email to each primary engineer and
' secondary engineer that is assigned to a project. Unassigned jobs don't matter???
' there should be an attribute in the Changes table that says each change has been acknowledge done by some new form
' code to follow here.
' Detailer/Engineer
' Name vs CustName
' Description
' Order Qty vs OrderQyt
' Planned Start Date vs PlannedStartDate
' Req'd Release from Engr vs ReqReleaseFromEngr
Dim rsOO As DAO.Recordset ' open orders
Dim rsCH As DAO.Recordset ' order change history
Dim rcOO As Long ' record count in the open order recordset
Set rsOO = CurrentDb.OpenRecordset("OpenOrdersOnOrderImportFile")
Set rsCH = CurrentDb.OpenRecordset("OrderChanges")
If rsOO.RecordCount = 0 Then
Set rsOO = Nothing
Set rsCH = Nothing
Exit Function
End If
With rsOO
.MoveLast
rcOO = .RecordCount
.MoveFirst
For i = 1 To rcOO
If .Fields("OrdersRawData.Detailer/Engineer") <> .Fields("Orders.Detailer/Engineer") Then
' write a record to the change table
rsCH.AddNew
rsCH.Fields("Project") = .Fields("Project")
rsCH.Fields("CustomizedItem") = .Fields("CustomizedItem")
rsCH.Fields("DateAdded") = Now()
rsCH.Fields("Field") = "Detailer/Engineer"
rsCH.Fields("OldValue") = .Fields("Orders.Detailer/Engineer")
rsCH.Fields("NewValue") = .Fields("OrdersRawData.Detailer/Engineer")
rsCH.Fields("RequestedBy") = "BAAN"
If IsNull(.Fields("DateAssigned")) Then rsCH.Fields("ChangeAck") = -1
rsCH.Update
' now make the change to the existing order
.Edit
.Fields("Orders.Detailer/Engineer") = .Fields("OrdersRawData.Detailer/Engineer")
.Update
End If
If .Fields("Name") <> .Fields("CustName") Then
' write a record to the change table
rsCH.AddNew
rsCH.Fields("Project") = .Fields("Project")
rsCH.Fields("CustomizedItem") = .Fields("CustomizedItem")
rsCH.Fields("DateAdded") = Now()
rsCH.Fields("Field") = "CustName"
rsCH.Fields("OldValue") = .Fields("CustName")
rsCH.Fields("NewValue") = .Fields("Name")
rsCH.Fields("RequestedBy") = "BAAN"
If IsNull(.Fields("DateAssigned")) Then rsCH.Fields("ChangeAck") = -1
rsCH.Update
' now make the change to the existing order
.Edit
.Fields("CustName") = .Fields("Name")
.Update
End If
If .Fields("OrdersRawData.Description") <> .Fields("Orders.Description") Then
' write a record to the change table
rsCH.AddNew
rsCH.Fields("Project") = .Fields("Project")
rsCH.Fields("CustomizedItem") = .Fields("CustomizedItem")
rsCH.Fields("DateAdded") = Now()
rsCH.Fields("Field") = "Description"
rsCH.Fields("OldValue") = .Fields("Orders.Description")
rsCH.Fields("NewValue") = .Fields("OrdersRawData.Description")
rsCH.Fields("RequestedBy") = "BAAN"
If IsNull(.Fields("DateAssigned")) Then rsCH.Fields("ChangeAck") = -1
rsCH.Update
' now make the change to the existing order
.Edit
.Fields("Orders.Description") = .Fields("OrdersRawData.Description")
.Update
End If
If .Fields("Order Qty") <> .Fields("OrderQty") Then
' write a record to the change table
rsCH.AddNew
rsCH.Fields("Project") = .Fields("Project")
rsCH.Fields("CustomizedItem") = .Fields("CustomizedItem")
rsCH.Fields("DateAdded") = Now()
rsCH.Fields("Field") = "OrderQty"
rsCH.Fields("OldValue") = .Fields("OrderQty")
rsCH.Fields("NewValue") = .Fields("Order Qty")
rsCH.Fields("RequestedBy") = "BAAN"
If IsNull(.Fields("DateAssigned")) Then rsCH.Fields("ChangeAck") = -1
rsCH.Update
' now make the change to the existing order
.Edit
.Fields("OrderQty") = .Fields("Order Qty")
.Update
End If
If .Fields("Planned Start Date") <> .Fields("PlannedStartDate") Then
' write a record to the change table
rsCH.AddNew
rsCH.Fields("Project") = .Fields("Project")
rsCH.Fields("CustomizedItem") = .Fields("CustomizedItem")
rsCH.Fields("DateAdded") = Now()
rsCH.Fields("Field") = "PlannedStartDate"
rsCH.Fields("OldValue") = .Fields("PlannedStartDate")
rsCH.Fields("NewValue") = .Fields("Planned Start Date")
rsCH.Fields("RequestedBy") = "BAAN"
If IsNull(.Fields("DateAssigned")) Then rsCH.Fields("ChangeAck") = -1
rsCH.Update
' now make the change to the existing order
.Edit
.Fields("PlannedStartDate") = .Fields("Planned Start Date")
.Update
End If
If .Fields("Req'd Release from Engr") <> .Fields("ReqReleaseFromEngr") Then
' write a record to the change table
rsCH.AddNew
rsCH.Fields("Project") = .Fields("Project")
rsCH.Fields("CustomizedItem") = .Fields("CustomizedItem")
rsCH.Fields("DateAdded") = Now()
rsCH.Fields("Field") = "ReqReleaseFromEngr"
rsCH.Fields("OldValue") = .Fields("ReqReleaseFromEngr")
rsCH.Fields("NewValue") = .Fields("Req'd Release from Engr")
rsCH.Fields("RequestedBy") = "BAAN"
If IsNull(.Fields("DateAssigned")) Then rsCH.Fields("ChangeAck") = -1
rsCH.Update
' now make the change to the existing order
.Edit
.Fields("ReqReleaseFromEngr") = .Fields("Req'd Release from Engr")
.Update
End If
.MoveNext
Next
End With
Set rsOO = Nothing
Set rsCH = Nothing
End Function
Related
I am trying to add a record to a record set through a form. one of the fields in the form is an attachment. How can i add the attachment into the record set as I keep receiving errors of "Data Type Mismatch"? I understand the attachment field is basically a record set with "FileData","FileName", "File Type" Fields, but how can i have vba add the attachment from the form I have to the record set??
below is the coding I use:
Private Sub Command31_Click()
Dim Db As Database
Dim rs As DAO.Recordset
Dim rs2 As DAO.Recordset
Set Db = CurrentDb
Dim Message1, Message2, Title1, Default, MyValue1, MyValue2
Dim SN
Dim q As Long
Dim i As Long
Message1 = "ENTER TOTAL QUANTITY RECEIVED OF " & Me.Item ' Set prompt.
Title1 = "Total Quantity Received" ' Set title.
Default = "1" ' Set default.
' Display message, title, and default value.
MyValue1 = InputBox(Message1, Title1, Default)
i = 0
q = MyValue1
Do While (i < q)
Message2 = "ENTER S/N FOR ITEM NUMBER " & i + 1 ' Set prompt.
Title2 = "SERIAL NUMBER ENTRY" ' Set title.
Default = "1" ' Set default.
' Display message, title, and default value.
MyValue2 = InputBox(Message2, Title2, Default)
Set rs = Db.OpenRecordset("Inventory Transactions")
rs.Edit
rs.AddNew
Set rs2 = rs.Fields("Transaction Docs").Value
rs.Fields("Tx Date") = Date
rs.Fields("Project Code") = Me.Project_Code
rs.Fields("Transaction Type") = 1
rs.Fields("Transaction Item") = Me.Item
rs.Fields("Reference Document") = Me.Reference_Document
rs.Fields("Serial Number") = MyValue2
rs.Fields("Quantity") = 1
rs.Fields("Location") = Me.Location
rs.Fields("Entered by") = Me.Entered_by
rs.Fields("Recepient") = Me.Recepient
rs2.AddNew
rs2.Fields("FileData").LoadFromFile (Me.Transaction_Docs)
rs2.Update
'With rsatt1
'Do While Not rsatt1.EOF
'rsatt1.AddNew
'rsatt1.Fields("FileData") = rsatt1.Fields("FileData")
'rsatt1.Fields("FileName") = rsatt1.Fields("FileName")
'rsatt1.Fields("FileType") = rsatt1.Fields("FileType")
'rsatt1.Update
'.MoveNext
'Loop
'End With
'rsatt1.Close
Set rs2 = Nothing
rs.Update
rs.Close
i = i + 1
Loop
Set rs = Nothing
DoCmd.Close
DoCmd.OpenForm "MULTIPLE RECORDS GENERATOR"
DoCmd.Requery
Db.Close
End Sub
I have this function to where it tries to auto sequence a number starting at the number 8000 and the number seeds back to 8000 every day. The function also attempts to ensure that there is no gap so if there is a manual entry and the number creates a gap the field will not sequence from the manual entry. But I cannot seem to get the code to work as it just stays at the same number from the previous entry and does not increase.
Public Function fRetNextInSequence() As Long
Dim MyDB As DAO.Database
Dim rst As DAO.Recordset
Dim rstClone As DAO.Recordset
'If there are no Records in tblData, then have the Function return 8000
If DCount("strSerialNumber", "tblOrderData", "dtmDateOrdered=#" & Date & "#") = 0 Then
fRetNextInSequence = 8000
Exit Function
End If
Set MyDB = CurrentDb
Set rst = MyDB.OpenRecordset("tblOrderData", dbOpenSnapshot)
Set rstClone = rst.Clone
rst.MoveLast 'Move to Last Record [MyNum]
With rstClone 'Move to Next-to-Last Record [MyNum]
.MoveLast
.Move -1 'Clone now at Next-to-Last Record [MyNum]
End With
With rst
Do While Not rstClone.BOF
If Abs(![strSerialNumber] - rstClone![strSerialNumber]) > 1 Then
fRetNextInSequence = (rstClone![strSerialNumber] + 1) 'Found the Gap!
Exit Function
End If
.MovePrevious 'Move in sync, 1 Record apart
rstClone.MovePrevious
Loop
End With
rst.MoveLast
fRetNextInSequence = (rst![strSerialNumber] + 1) 'No Gap found, return next number in sequence!
rstClone.Close
rst.Close
Set rstClone = Nothing
Set rst = Nothing
End Function
If SOS = "ES-S" Then
SerialNbrValue = fRetNextInSequence
'SerialNbrValue = Val(Nz(DMax("strSerialNumber", "tblOrderData", "dtmDateOrdered=#" & Date & "#"), 7999)) + 1
Else
SerialNbrValue = ""
End If
Exiting the function from the loop bypasses the lines to close and clear the recordset objects. That isn't causing the issue but why have them if they aren't used everytime the recordsets are opened?
The following revised procedure worked for me to return appropriate sequence when I call the function from the VBA Immediate Window:
Public Function fRetNextInSequence() As Long
Dim MyDB As DAO.Database
Dim rst As DAO.Recordset
Dim rstClone As DAO.Recordset
If Nz(DMin("strSerialNumber", "tblOrderData", "dtmDateOrdered=Date()"), 0) <> 8000 Then
'If there are no Records or the gap is 8000 for current date, Function returns 8000
fRetNextInSequence = 8000
Else
Set MyDB = CurrentDb
Set rst = MyDB.OpenRecordset("SELECT strSerialNumber FROM tblOrderData WHERE dtmDateOrdered=Date() ORDER BY strSerialNumber", dbOpenSnapshot)
Set rstClone = rst.Clone
rst.MoveLast 'Move to Last Record [MyNum]
With rstClone 'Move to Next-to-Last Record [MyNum]
.MoveLast
.Move -1 'Clone now at Next-to-Last Record [MyNum]
End With
With rst
Do While Not rstClone.BOF
If Abs(![strSerialNumber] - rstClone![strSerialNumber]) > 1 Then
'Found the Gap!
fRetNextInSequence = (rstClone![strSerialNumber] + 1)
Exit Do
End If
.MovePrevious 'Move in sync, 1 Record apart
rstClone.MovePrevious
Loop
End With
If fRetNextInSequence = 0 Then
'No Gap found, return next number in sequence!
rst.MoveLast
fRetNextInSequence = (rst![strSerialNumber] + 1)
End If
rstClone.Close
rst.Close
Set rstClone = Nothing
Set rst = Nothing
End If
End Function
I've created a form where I can use a subform to load data from a query into textboxes so I can edit the data one at a time and update the database. This usually works fine except I have a run time error that randomly appears now and then - '-2147352567 (80020009)': The value you entered isn't valid for this field.'
If I stop running it and try running it again it usually works fine until the same run-time error appears. It's very inconsistent.
Private Sub btn_SelectAgency_Click()
If Not (Me.qryAgencyWithoutMileagesub.Form.Recordset.EOF And Me.qryAgencyWithoutMileagesub.Form.Recordset.BOF) Then
'get data to textbox control
With Me.qryAgencyWithoutMileagesub.Form.Recordset
Me.txt_AgencyID = .Fields("Agency ID")
Me.txt_AgencyName = .Fields("Agency Name")
Me.txt_Address1 = .Fields("Address 1")
Me.txt_Address2 = .Fields("Address 2")
Me.txt_City = .Fields("City")
Me.txt_Postcode = .Fields("Postcode")
Me.txt_AgencyMileage = .Fields("Mileage")
Me.txt_AgencyID.Tag = .Fields("Agency ID")
End With
End If
Me.txt_AgencyMileage = ""
End Sub
Private Sub btn_Update_Click()
If Me.txt_AgencyMileage = "" Then
MsgBox "No mileage added, add now"
Cancel = True
Else
CurrentDb.Execute "UPDATE EstateAgent_tbl SET EstateAgent_AgentMileage = '" & Me.txt_AgencyMileage & "' where EstateAgent_AgentID=" & Me.txt_AgencyID.Tag
Me.txt_AgencyID = ""
Me.txt_AgencyName = ""
Me.txt_Address1 = ""
Me.txt_Address2 = ""
Me.txt_City = ""
Me.txt_Postcode = ""
Me.txt_AgencyMileage = ""
End If
qryAgencyWithoutMileagesub.Form.Requery
If Me.qryAgencyWithoutMileagesub.Form.Recordset.RecordCount = 0 Then
MsgBox "No agencies without mileage"
DoCmd.Close
End If
End Sub
The error is on this line
Me.txt_AgencyID = .Fields("Agency ID")
I would appreciate any help with this, thank you :)
Dim rs As DAO.Recordset
Set rs = Me.qryAgencyWithoutMileagesub.Form.RecordsetClone
'get data to textbox control
With rs
If .RecordCount > 0 Then
Me.txt_AgencyID = .Fields("Agency ID")
Me.txt_AgencyName = .Fields("Agency Name")
Me.txt_Address1 = .Fields("Address 1")
Me.txt_Address2 = .Fields("Address 2")
Me.txt_City = .Fields("City")
Me.txt_Postcode = .Fields("Postcode")
Me.txt_AgencyMileage = .Fields("Mileage")
Me.txt_AgencyID.Tag = .Fields("Agency ID")
End If
End With
Set rs = Nothing
DoCmd.RefreshRecord
DoCmd.RunCommand acCmdUndo
'You can it try. That worked for me!
Try to exclude Null values:
If Not IsNull(.Fields("Agency ID").Value) Then
Me.txt_AgencyID.Value = .Fields("Agency ID").Value
End If
You may also try using the RecordsetClone:
Dim rs As DAO.Recordset
Set rs = Me.qryAgencyWithoutMileagesub.Form.RecordsetClone
'get data to textbox control
With rs
If .RecordCount > 0 Then
Me.txt_AgencyID = .Fields("Agency ID")
Me.txt_AgencyName = .Fields("Agency Name")
Me.txt_Address1 = .Fields("Address 1")
Me.txt_Address2 = .Fields("Address 2")
Me.txt_City = .Fields("City")
Me.txt_Postcode = .Fields("Postcode")
Me.txt_AgencyMileage = .Fields("Mileage")
Me.txt_AgencyID.Tag = .Fields("Agency ID")
End If
End With
Set rs = Nothing
I am trying to do a query of a linked table. After I get the results, I need to do 1 of 2 things. Either say it passed or failed. Here is the code I have written. It doesn't give me any errors, nor does it run correctly. When I input a SN I know doesn't have any entries it doesn't run the second part (the fail part).
Private Sub SQL_Check()
Dim rs As DAO.Recordset
Dim sqlMax As String
Dim result As String
sqlMax = "Select count(1) FROM dbo_Event WHERE [AssemblyNo] = 'SYSCHATESTE' and [SerialNo] = '" & Me.txtUnitNo & "' and [ProcessTyp] = 'SF1';"
Set rs = CurrentDb.OpenRecordset(sqlMax)
If rs.Fields.Count = 1 Then
txtECCT.BackColor = vbGreen
txtECCT.ForeColor = vbBlack
txtECCT.Value = "Passed"
GoTo la
End If
If rs.Fields.Count = 0 Then
Set rs = Nothing
Set db = CurrentDb
Set rec = db.OpenRecordset("Select * from tblScannedParts")
rec.AddNew
rec("Inspector") = Me.txtUserId
rec("PO Number") = Me.txtWorkOrderNo
rec("Assembly") = Me.txtAssem
rec("SERIAL Number") = Me.txtUnitNo
rec("DateScanned") = CStr(Now())
rec("Result") = "Failed"
rec("Defect Type") = "Missing ECCT"
rec("Comments") = strFileContent
rec("Qty") = "1"
rec.Update
txtStatus.BackColor = vbRed
txtStatus.ForeColor = vbBlack
txtStatus.Value = "Failed"
MsgBox "Please take unit to NCM Cart for review.", vbCritical, "Unit Not Ready for DOF QA"
txtAssem.SetFocus
End If
la:
Set rs = Nothing
End Sub
The issue is that the recordset rs is based on a SELECT which returns one field, so your If condition, rs.Fields.Count = 1, will always be True.
Conversely, the code within the If rs.Fields.Count = 0 Then block could never run because Fields.Count would never be zero. And actually, Access does not even evaluate that condition because you included GoTo la in the previous If block ... which quickly exits the procedure. Be wary of GoTo
If you want to base the action on a count of matching records, I think the logic should be simpler with DCount().
Dim strCriteria As String
Dim lngMatchCount As Long
strCriteria = "[AssemblyNo] = 'SYSCHATESTE' AND [SerialNo] = '" & Me!txtUnitNo.Value & "' AND [ProcessTyp] = 'SF1'"
Debug.Print strCriteria '<- inspect this in Immediate window; Ctrl+g will take you there
lngMatchCount = DCount("*", "dbo_Event", strCriteria)
If lngMatchCount > 0 Then
' do the 'Passed' thing
Else
' do the 'Failed' thing
End If
I'm trying to modify a parsing script to exclude a record in the first field that does not have a value but I want the script to finish the file.
lastRO = ""
FirstLine = True
FacilityCode = Left(InputFile, InStr(InputFile,"_")-1)
Do Until EOF
a = CSVParser(ExtractLine(0))
If a(1) <> lastRO Then
If FirstLine Then
FirstLine = False
Else
WriteFields()
End If
lastRO = a(1)
Field("Department") = ""
Field("RepairOrder") = FacilityCode & a(1)
End If
Dim xReg
Set xReg = new RegExp
For i = 0 to Ubound(RepairOrderDepartmentExpressions)
xReg.Pattern = RepairOrderDepartmentExpressions(i)
If xReg.Test(a(RepairOrderDepartmentField(i))) Then
If Field("Department") = "" Or Field("Department") = RepairOrderDepartmentKey(i) Then
Field("Department") = RepairOrderDepartmentKey(i)
Else
Field("Department") = RepairOrderSharedDepartment
End if
Exit For
End if
Next
Skip
Loop