Private Sub Command15_Click()
On Error Resume Next
Dim db As Database
Dim RST As Variant
Set db = CurrentDb
Set RST = db.OpenRecordset("SSPTab")
With RST
.Edit
.Fields(6) = Me.Reviewersname
.Fields(9) = Me.Assessments
.Fields(11) = Me.Review_Comments
.Fields(7) = Me.Reviewstatus
.Update
End With
I would like to open the existing row details and make changes to it and update. The above code is working fine for me except .Fields(7) , showing data conversion error.
Use proper declarations:
Private Sub Command15_Click()
Dim db As DAO.Database
Dim rst As DAO.Recordset
Set db = CurrentDb
Set rst = db.OpenRecordset("SSPTab")
With rst
.Edit
.Fields(6).Value = Me!Reviewersname.Value
.Fields(9).Value = Me!Assessments.Value
.Fields(11).Value = Me!Review_Comments.Value
' Field 7 must be Short Text or Long Text.
' .Fields(7).Value = Me!Reviewstatus.Value
.Fields(7).Value = Me!Revstats.Value
.Update
.Close
End With
End Sub
Related
I have a code that creates new MS Access Databases. I'd like to add reference libraries to these newly created MS Access Databases.
Here is the code that I wrote but is not working:
Sub makeDb(fl As String)
Dim fs
Set fs = CreateObject("Scripting.FileSystemObject")
'check if the file already exists
If fs.FileExists(fl) = False Then
'create new ms access database
Dim accessApp As Access.Application
Set accessApp = New Access.Application
accessApp.DBEngine.CreateDatabase fl, dbLangGeneral
'loop through all references in current database and add them to the newly created dbs
Dim cur_vbProj As VBIDE.VBProject: Set cur_vbProj = Application.VBE.VBProjects(1)
Dim cur_vbRefs As VBIDE.References: Set cur_vbRefs = cur_vbProj.References
Dim cur_vbRef As VBIDE.Reference
For Each cur_vbRef In cur_vbRefs
Dim cur_guid As String: cur_guid = cur_vbRef.Guid
Dim cur_major As Long: cur_major = cur_vbRef.Major
Dim cur_minor As Long: cur_minor = cur_vbRef.Minor
'here is the code that doesn't work
Dim vbProj As VBIDE.VBProject: Set vbProj = accessApp.Application.VBE.VBProjects(1)
Dim vbRefs As VBIDE.References: Set vbRefs = vbProj.References
vbRefs.AddFromGuid Guid:=cur_guid, Major:=cur_major, Minor:=cur_minor
Next
accessApp.Quit
Set accessApp = Nothing
End If
End Sub
The line Set vbProj = accessApp.Application.VBE.VBProjects(1) throws Run-Time error '9' Subscript out of range. How should I modify the code? Is it even possible to add references to an outside database?
Following works for me:
Sub makeDb(f1 As String)
Dim accApp As Access.Application
Dim cur_vbRefs As References
Dim cur_vbRef As Reference
If Dir(f1) = "" Then
Access.DBEngine.CreateDatabase f1, dbLangGeneral
Set accApp = New Access.Application
accApp.OpenCurrentDatabase f1
'loop through all references in current database and add them to the newly created dbs
Set cur_vbRefs = Application.References
For Each cur_vbRef In cur_vbRefs
On Error Resume Next
accApp.References.AddFromGuid cur_vbRef.Guid, cur_vbRef.Major, cur_vbRef.Minor
Next
End If
End Sub
I have included an audit trail code to be called to 2 different forms in my access database. The code works fine for one of the forms but in the other form it produces a 438 error.
-The same parameter is used to call the code in both forms
-The debugger highlights this line : 'If Nz(ctl.Value) <> Nz(ctl.OldValue) Then
-I have attempted to comment out the code which calls the procedure and the problem appears to be with the parameter "SingleName"
-I have checked both the Control Source and Name for the textbox and both appear correct.
Sub AuditChanges(IDField As String, UserAction As String)
On Error GoTo AuditChanges_Err
Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim ctl As Control
Dim datTimeCheck As Date
Dim strUserID As String
Set cnn = CurrentProject.Connection
Set rst = New ADODB.Recordset
rst.Open "SELECT * FROM TBL_AuditTrail", cnn, adOpenDynamic,
adLockOptimistic
datTimeCheck = Now()
strUserID = Environ("USERNAME")
Select Case UserAction
Case "EDIT"
For Each ctl In Screen.ActiveForm.Controls
If ctl.Tag = "Audit" Then
If Nz(ctl.Value) <> Nz(ctl.OldValue) Then
With rst
.AddNew
![DateTime] = datTimeCheck
![UserName] = strUserID
![FormName] = Screen.ActiveForm.Name
![Action] = UserAction
![RecordID] =
Screen.ActiveForm.Controls(IDField).Value
![FieldName] = ctl.ControlSource
![OldValue] = ctl.OldValue
![NewValue] = ctl.Value
.Update
End With
End If
End If
Next ctl
Case Else
With rst
.AddNew
![DateTime] = datTimeCheck
![UserName] = strUserID
![FormName] = Screen.ActiveForm.Name
![Action] = UserAction
![RecordID] = Screen.ActiveForm.Controls(IDField).Value
.Update
End With
End Select
AuditChanges_Exit:
On Error Resume Next
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing
Exit Sub
AuditChanges_Err:
MsgBox Err.Number & Err.Description
Resume AuditChanges_Exit
End Sub
Private Sub Form_BeforeUpdate(Cancel As Integer)
If Me.NewRecord Then
Call AuditChanges("SingleName", "NEW")
Else
Call AuditChanges("SingleName", "EDIT")
End If
End Sub
The BeforeUpdate event of the form is supposed to call the procedure and send any changes, deletions or additions to TBL_AuditTrail.
After the data is inputted and I attempt to save, the 438 error occurs.
The information is still sent to the table (TBL_AuditTrail)
An unbound control doesn't have an OldValue property. You could check for that:
If ctl.ControlSource <> "" Then
![OldValue].Value = ctl.OldValue
Else
' Skip unbound control.
End If
Without seeing the three forms in question, I can only say that something is different on Screen.ActiveForm.Controls(IDField) field. I would compare the properties of all three fields to see how the one that is failing is different.
I have looked at this post: Saving changes to a multivalued ComboBox via AuditTrail
And tried to take tidbits and put it into my code, but it just didn't work! I am not really great at SQL but I need to get this done. Here is my code and it works for textboxes, but can someone tell me exactly where and exactly what to put what I need for my combobox dropdown list changes?
Thanks in advance!!
Function LogChanges(lngID As Long, Optional strField As String = "")
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim varOld As Variant
Dim varNew As Variant
Dim strFormName As String
Dim strControlName As String
varOld = Screen.ActiveControl.OldValue
varNew = Screen.ActiveControl.Value
strFormName = Screen.ActiveForm.NAME
strControlName = Screen.ActiveControl.NAME
Set dbs = CurrentDb()
Set rst = dbs.TableDefs("ztblDataChanges").OpenRecordset
With rst
.AddNew
!FormName = strFormName
!ControlName = strControlName
If strField = "" Then
!FieldName = strControlName
Else
!FieldName = strField
End If
!RecordID = lngID
!UserName = Environ("username")
If Not IsNull(varOld) Then
!OldValue = CStr(varOld)
End If
!NewValue = CStr(varNew)
.Update
End With
'clean up
rst.Close
Set rst = Nothing
dbs.Close
Set dbs = Nothing
End Function
You can't get the values of multi-valued fields using .Value and .OldValue. These properties always return Null. As far as I know, there's no reliable way to get the old value (also, a proper audit trail doesn't need an old value, since the old value is the previously added new value if everything gets audited properly).
When only saving the new values, and if you're saving them into a text field and not a multivalued field, you could use the following:
Use this function to get a string value for all selected items:
Public Function JoinMVF(MVFControl As Control, Optional Delimiter As String) As String
Dim i As Variant
For Each i In MVFControl.ItemsSelected
JoinMVF = JoinMVF & MVFControl.ItemData(i) & Delimiter
Next i
End Function
And then, adjust your recordset piece to the following:
With rst
.AddNew
!FormName = strFormName
!ControlName = strControlName
If strField = "" Then
!FieldName = strControlName
Else
!FieldName = strField
End If
!RecordID = lngID
!UserName = Environ("username")
If Not IsNull(varOld) Then 'varOld will always be Null for a multi-valued field
!OldValue = CStr(varOld) 'Thus this will never get called
End If
'Add some If multivalued field then
!NewValue = JoinMVF(Screen.ActiveControl, "; ")
.Update
End With
All,
I'm trying to save a record for 1 record to a drive. I've spent about a day searching for a solution so this is a last ditch effort for some help. I am not a developer by any stretch of the imagination so please, go easy.
Code is below.
Table where record is located: tracker.
Field I am searching based on: ReqID - where ReqID = the record I am entering, find the attachment and move it to a location.
Dim db As DAO.Database
Dim rsChild As DAO.Recordset2
Dim ReqID As String
ReqID = Me.Form![Text145]
Debug.Print ReqID
Set db = CurrentDb
Set rsChild = db.OpenRecordset("Select * from tracker Where " & ReqID & " = [tracker].[ID]", dbOpenDynaset)
Debug.Print rsChild.RecordCount
If (rsChild.EOF = False) Or (rsChild.BOF = False) Then
While Not rsChild.EOF
rsChild("FileData").SaveToFile "C:\Users\<folder>\"
rsChild.Delete
Wend
End If
You actually need to use two Recordset objects: one for the main record and another for the attachment(s) associated with that record. This is the sample code that works for me, where [tblTest] is the name of the table and [Attachments] is the name of the Attachment field:
Option Compare Database
Option Explicit
Sub SaveAllAttachments()
Dim cdb As DAO.Database
Set cdb = CurrentDb
Dim rstMain As DAO.Recordset
Set rstMain = cdb.OpenRecordset("SELECT Attachments FROM tblTest WHERE ID=1", dbOpenDynaset)
rstMain.Edit
Dim rstChild As DAO.Recordset2
Set rstChild = rstMain.Fields("Attachments").Value
Do Until rstChild.EOF
Dim fileName As String
fileName = rstChild.Fields("FileName").Value
Debug.Print fileName
Dim fld As DAO.Field2
Set fld = rstChild.Fields("FileData")
fld.SaveToFile "C:\Users\Gord\Desktop\" & fileName
rstChild.Delete ' remove the attachment
rstChild.MoveNext
Loop
rstChild.Close
rstMain.Update
rstMain.Close
End Sub
I need help with some VBA code in Microsoft Access that will produce the maximum/minimum values for each of the fields below and return with their corresponding case attached
Force Table
case Flxmax Flxmin Frxmax Frxmin
hs00p16010od 582.24 666.81 796.44 -451.15
hs00p16015od 878.7 878.7 1096.3 -500.36
hs00p16020od 1071.95 1071.9 1281.2 -743.05
hs00p16025od 1186.65 1186.6 1397.8 -959.36
Desired Output
Field Force Case
Flxmax 1186.65 hs00p16025od
Flxmin 666.81 hs00p16010od
Frxmax 1397.8 hs00p16025od
Frxmin -959.36 hs00p16025od
In addition, if there are identical max/min values in the table I need to pick just one in the results.
There are 30 additional fields to the ones shown above. I believe that I have to loop through each field till I reach the end and record the max/min row, but I'm unsure how to write this code. Any help would be great.
Current Code
Public Sub Max()
Dim sqlStatement As String
Dim rs1 As Object
Dim rs2 As Object
Dim fld As Field
Dim strName As String
Dim maximum As Long
Dim minimum As Long
sqlStatement = "SELECT * FROM Force;"
Set rs1 = CurrentDb().OpenRecordset(sqlStatement)
sqlStatement = "SELECT * FROM Results;"
Set rs2 = CurrentDb().OpenRecordset(sqlStatement)
rs2.AddNew 'Add new record to result table
'Field order to loop though: max, min, skip, max, min, skip...where skip implies a skipped field
For Each fld In rs1.Fields
With rs1
maximum = DMax(fld, Force)
'Write onto results tables
End With
Next fld
rs2.Update 'Update results table
Set rs1 = Nothing
Set rs2 = Nothing
End Sub
You are quite close. What basically is missing is that every min/max field value must be added/updated separately to the target table.
Revised Code
Public Sub Max()
Dim db As DAO.Database
Dim rs1 As DAO.Recordset
Dim rs2 As DAO.Recordset
Dim fld As DAO.Field
Dim newvalue As Long
Dim newfield As String
Dim newcase As String
Dim sqlStatement As String
Set db = CurrentDb
sqlStatement = "SELECT * FROM Force;"
Set rs1 = db.OpenRecordset(sqlStatement)
sqlStatement = "SELECT * FROM Results;"
Set rs2 = db.OpenRecordset(sqlStatement)
For Each fld In rs1.Fields
rs1.MoveFirst
newfield = fld.Name
If newfield <> "case" Then
newvalue = rs1(newfield).Value
While Not rs1.EOF
If Right(newfield, 3) = "min" Then
If newvalue > rs1(newfield).Value Then
newvalue = rs1(newfield).Value
newcase = rs1("Case").Value
End If
ElseIf Right(newfield, 3) = "max" Then
If newvalue < rs1(newfield).Value Then
newvalue = rs1(newfield).Value
newcase = rs1("Case").Value
End If
End If
rs1.MoveNext
Wend
rs2.AddNew
rs2!Field.Value = newfield
rs2!Force.Value = newvalue
rs2!Case.Value = newcase
rs2.Update
End If
Next fld
Set fld = Nothing
Set rs1 = Nothing
Set rs2 = Nothing
Set db = Nothing
End Sub
This is air code and I don't have test data. You may need to add some error handling.