I have the same copy of a function in many forms that does exactly the same job. What changes in them is a field name. So the reason I keep it local is I don't know how I would refer to a particular field by name in a referenced form. This is the function:
Private Function getNewXNo(ByRef theForm As Form, ByVal strCode As String) As String
Dim rs As DAO.Recordset
Dim maxNo As Long
Dim aNo As Long
Set rs = theForm.RecordsetClone
maxNo = 0
If rs.RecordCount <> 0 Then
rs.MoveFirst
Do While Not rs.EOF
aNo = CLng(Right(Nz(rs!applicationNo, strCode & "0000"), 4))
If aNo > maxNo Then
maxNo = aNo
End If
rs.MoveNext
Loop
End If
getNewXNo = strCode & Format(maxNo + 1, "
Set rs = Nothing
End Function
There are a lot of instances when I have to generate new codes, such as BB001, BB002, APP001, APP002, etc. The function reads all existing codes from a field in the referenced form and based on that creates a new one. Is there any way I can send a field name to a global function, such as
aNo = CLng(Right(Nz(rs!varThatContainsAFieldName, strCode & "0000"), 4))
Thanks
You can access a field in a recordset like this:
rs("fieldname")
So you could make the field name a parameter for your function.
Related
I have a form that has a multi-selection listbox based on a query of items that have a specific field that is blank (UserID). I would like to select a UserID from a combobox and click a button to have all selected records modified to have that UserID. (I would also like to update the DateAssigned field to whatever the current date is). CaseID is the unique value in the table.
Sample Form Picture
(The combo box has two columns, the second one has the actual ID I'd want to use).
I've looked at multiple different posts on here like this but I haven't been able to get it to work. Here's an example of a code I found and tried, altered slightly.
Private Sub AssignButton_Click()
Dim lCnt As Long
Dim lID As Long
Dim sSQL_Update As String
Dim sText_1 As String
Dim bSuccess As Boolean
sText_1 = Me.ComboBox
With Me.ToAssignList
For lCnt = 1 To .ListCount
If .Selected(lCnt) Then
lID = .Column(4, lCnt - 1)
'Example update for 1 column
sSQL_Update = "UPDATE MainData SET UserID = '" & sText_1 & "' WHERE CaseID = " & lID & ";"
bSuccess = Update_Statement(sSQL_Update)
End If
Next
End With
End Sub
Public Function Update_Statement(sUpdate_Stmt) As Boolean
Dim db As Database
Set db = CurrentDb
db.Execute (sUpdate_Stmt)
End Function
When I try running this nothing happens.
Thank you!
Hy, Some remarks and tweaks to your code :
First enable the direct screen :
This will enable you to use the debug function.
Is the field : UserID in the table Maindata a text field ? If so, fine, otherwise you should alter the string to :
"UPDATE MainData SET UserID = " & Cint(sText_1) & " WHERE CaseID = " & lID & ";"
Then it would be better to create different functions in a module for what you are trying to do. But ok, this is not your main concern right now...
Try :
Private Sub AssignButton_Click()
Dim lCnt As Long
Dim lID As Long
Dim sSQL_Update As String
Dim sText_1 As String
Dim bSuccess As Boolean
sText_1 = Me.ComboBox
With Me.ToAssignList
For lCnt = 1 To .ListCount
If .Selected(lCnt) Then
lID = .Column(4, lCnt - 1)
'Example update for 1 column
sSQL_Update = "UPDATE MainData SET UserID = '" & sText_1 & "' WHERE CaseID = " & lID & ";"
'
'Check your sql statement and add it to stack overflow if it still is not working
'
Debug.Print sSQL_Update
'
bSuccess = Update_Statement(sSQL_Update)
End If
Next
End With
End Sub
There is should be a logical check in the code bellow to see if the update is done, anyhow, the code bellow should work and return a true value if the update doesn't produce an error... it's not good code but ok.
Public Function Update_Statement(sUpdate_Stmt) As Boolean
Dim Currentdb As Database
Set Currentdb = Currentdb
Call Currentdb.Execute(sUpdate_Stmt, dbSeeChanges)
Update_Statement = True
End Function
Good luck !
Private Sub Command5_Click()
Dim li As ListItem
Dim lngRunningTotal As Long
For Each li In ListView1.ListItems
lngRunningTotal = lngRunningTotal + CLng(li.SubItems(6)) 'calculate all the in Total min column
Next
sumText.Text = CStr(lngRunningTotal) 'display total
End Sub
I want to filter data using 2 DTpicker for the sum rate.
Here's how you can do it with the code you posted:
Private Sub Command5_Click()
Dim li As ListItem
Dim lngRunningTotal As Long
Dim iLogDateIndex As Integer
Dim iMinutesIndex As Integer
iLogDateIndex = 5
iMinutesIndex = 6
For Each li In ListView1.ListItems
If CDate(li.SubItems(iLogDateIndex)) >= DTPickerStart And CDate(li.SubItems(iLogDateIndex)) <= DTPickerEnd Then
lngRunningTotal = lngRunningTotal + CInt(li.SubItems(iMinutesIndex)) ' calculate all the in Total min column
End If
Next
' Display total
sumText.Text = CStr(lngRunningTotal)
End Sub
The following demonstrates how to filter your data using an SQL Statement:
Private Sub cmdQuery_Click()
Dim objAdoConnection As New ADODB.Connection
Dim objRecordset As ADODB.Recordset
Dim sConnectionString As String
Dim sSQLStatement As String
Dim sDatabaseFile As String
Dim itm As ListItem
' Path to Access database
sDatabaseFile = "C:\Temp\Stack\ADO\Database.accdb"
' Connection string
sConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & sDatabaseFile
' Open Connection
objAdoConnection.Open sConnectionString
' Open recordset with SQL query
sSQLStatement = "SELECT * FROM TimeCards WHERE WorkDate BETWEEN #" & DTPickerStart & "# AND #" & DTPickerEnd & "#"
Set objRecordset = objAdoConnection.Execute(sSQLStatement)
' Clear ListView
ListView1.ListItems.Clear
' Move Recordset to first record
objRecordset.MoveFirst
' Display record data
Do While Not objRecordset.EOF
' Add record to ListView
Set itm = ListView1.ListItems.Add(, , objRecordset.Fields("ID"))
itm.SubItems(1) = objRecordset.Fields("EmployeeID")
itm.SubItems(2) = objRecordset.Fields("WorkDate")
itm.SubItems(3) = objRecordset.Fields("WorkHours")
' Move to next record
objRecordset.MoveNext
Loop
' Close connection and release objects
objAdoConnection.Close
Set objRecordset = Nothing
Set objAdoConnection = Nothing
End Sub
I made a quick UI with two DTPicker controls and a Query button. The results get shown into a ListView control:
I also created a simple TimeCards table with the following data for testing:
You can research SQL Statements on the internet and find many ways you can filter your data.
I have a sub which creates a recordset. A function is called with values from the recordset. The goal is to use multiple values from the recordset, however, there is a possibility that a recordset value is null, then the function call will result in an error: "Invalid use of Null". To handle this error, each time the recordset value is checked for null values, if it is null, it will be replaced with an empty string. However, the way I have programmed this feels very inefficient, even more when later on more than ten parameters should be checked. Is there a way to do this more efficiently?
I have skipped the last part off the code as this is not necessary to understand my question. I've replaced it with ......... If needed, I will edit and provide full code.
Sub CallFunctionWithArray()
Dim conn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim arrValues(1 To 3) As Variant
Set conn = New ADODB.Connection
conn.Open "provider=Microsoft.JET.OLEDB.4.0;Data Source=" & CurrentProject.Path & "\Northwind.mdb"
Set rst = New ADODB.Recordset
rst.Open "SELECT * FROM CustomersCopy", conn, adOpenForwardOnly, adLockReadOnly, adCmdText
If Not (rst.EOF And rst.BOF) Then
rst.MoveFirst
Do Until rst.EOF = True
If IsNull(rst![CompanyName]) Then
arrValues(1) = ""
Else
arrValues(1) = rst![CompanyName]
End If
If IsNull(rst![DateTest]) Then
arrValues(2) = ""
Else
arrValues(2) = rst![DateTest]
End If
If IsNull(rst![INTTest]) Then
arrValues(3) = ""
Else
arrValues(3) = rst![INTTest]
End If
Call ReturnValuesOfArray(arrValues(1), arrValues(2), arrValues(3))
.........
End Sub
Function ReturnValuesOfArray(ByVal ValueOne As String, ByVal ValueTwo As String, ByVal ValueThree As String)
Debug.Print "Waarde variabele 1: " & ValueOne
Debug.Print "Waarde variabele 2: " & ValueTwo
Debug.Print "Waarde variabele 3: " & ValueThree
End Function
There is no problem with the code, it does what it's supposed to do. However, I will be passing many more parameters to the function when this is going to be really used.
You could loop through the fields of your Recordset instead of hard coding for every field. Using your code as a starting point, it could look something like this:
Private Sub Test()
Dim rst As ADODB.Recordset
Dim i As Integer
If Not (rst.EOF And rst.BOF) Then
rst.MoveFirst
Do Until rst.EOF = True
For i = 0 To rst.Fields.Count - 1
If IsNull(rst.Fields(i).Value) Then
arrValues(i) = ""
Else
arrValues(i) = rst.Fields(i).Value
End If
Next
Loop
End If
End Sub
Incorporating the ideas presented by #HansUp and #Mathieu Guindon, the code is even shorter:
Private Sub Test()
Dim rst As ADODB.Recordset
Dim i As Integer
Do Until rst.EOF
For i = 0 To rst.Fields.Count - 1
arrValues(i + 1) = Nz(rst.Fields(i).Value, "")
Next
Loop
End Sub
The rest of your code can be simplified, too, while allowing for any number of parameters:
Function ReturnValuesOfArray(ByVal Values As Variant)
Dim i As Integer
For i = LBound(Values) To UBound(Values)
Debug.Print "Waarde variabele " & i & ": " & Values(i)
Next
End Function
The Nz Function does what I think you want.
arrValues(1) = Nz(rst![CompanyName], "")
arrValues(2) = Nz(rst![DateTest], "")
arrValues(3) = Nz(rst![INTTest], "")
I have a long text field (called "reporttext") that someone is importing a bunch of text that needs to be separated and appended into another table. For each case, there's a "[]" character that is supposed to separate each case. I want my code to look for the first [] and second [], append the text to another table and then loop. So the next case would be the text between the second [] and third [].
Here's my string
Reporttext: [] ksfjjls [] 42244 [] ####
I would want this to append to a new table called "notes" where it would be like this:
Reporttext
ksfjjls
42244
####
I used a macro to count the number of [] in the text file to know how many times to run the loop, but this, along with the rest of my code just isn't happening. I know my code is wrong, but I know with a few tweaks it'll get there. Any help is appreciated.
lengthofnote = Len([reporttext])
start = InStr([reporttext], "[]")
startplus3 = [start] + 3
'find number of cases
firstcase = 1
numcases = StringCountOccurrences([reporttext], "[]")
Dim LCounter As Integer
For LCounter = [firstcase] To [numcases]
revisedreporttext = Mid([reporttext], [startplus3], [lengthofnote])
secondposition = InStr([revisedreporttext], "[]")
nextreporttext = Mid([reporttext], [startplus3], [secondposition])
Add_reporttext = "INSERT INTO notes(reporttext) values ('" & nextreporttext & "');"
DoCmd.RunSQL Add_reporttext
firstcase = firstcase + 1
startplus3 = secondposition
secondposition = secondposition + 4
Next LCounter
#Zev Spitz is correct in that you could use Split() to accomplish this. You could use something like this
Option Compare Database
Option Explicit
Sub SplitLongTextField()
Dim rs As Recordset
Dim reportTextArr
Dim qString As String
Dim i As Long
qString = "SELECT [reporttext] FROM [Table1]" '<- replace [Table1] with the name of your table with the Long Text field
Set rs = CurrentDb.OpenRecordset(qString)
If Not rs.EOF Then
reportTextArr = Split(rs.Fields("reporttext"), "[]")
End If
For i = LBound(reportTextArr) To UBound(reportTextArr)
If Not reportTextArr(i) = "" Then
DoCmd.RunSQL "INSERT INTO notes(reporttext) VALUES('" & reportTextArr(i) & "');"
End If
Next i
rs.Close
End Sub
If you needed to do this for multiple records from your initial table then you could loop through the entire table and loop the operation like
Option Compare Database
Option Explicit
Sub SplitLongTextField()
Dim rs As Recordset
Dim reportTextArr
Dim qString As String
Dim i As Long
qString = "SELECT [reporttext] FROM [Table1]" '<- replace [Table1] with the name of your table with the Long Text field
Set rs = CurrentDb.OpenRecordset(qString)
Do Until rs.EOF
reportTextArr = Split(rs.Fields("reporttext"), "[]")
For i = LBound(reportTextArr) To UBound(reportTextArr)
If Not reportTextArr(i) = "" Then
DoCmd.RunSQL "INSERT INTO notes(reporttext) VALUES('" & reportTextArr(i) & "');"
End If
Next i
rs.MoveNext
Loop
rs.Close
End Sub
Assuming the string always starts with [] and preference is to return a single string, consider:
Replace(Mid(reporttext, 4), "[] ", vbCrLf)
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