I have a textbox that dynamically filters a listbox on the same form as you type. The listbox filters perfectly, but the selected value is not saving correctly. For example, if you click on the fourth value after filtering the listbox and then close the form, it actually saves what would have been the fourth value had the list not been filtered.
Here is the code:
Private Sub txtSearch_Change()
'CODE THAT HANDLES WHAT HAPPENS WHEN THE USER TYPES IN THE SEARCH BOX
Dim strFullList As String
Dim strFilteredList As String
If blnSpace = False Then
Me.Refresh 'refresh to make sure the text box changes are actually available to use
'specify the default/full rowsource for the control
strFullList = "SELECT [Project ID], [Project Name] FROM [Admin: Projects] ORDER BY [Project Name];"
'specify the way you want the rowsource to be filtered based on the user's entry
strFilteredList = "SELECT [Project ID], [Project Name] FROM [Admin: Projects] WHERE [Project Name] LIKE ""*" & Me.txtSearch.Value & "*"" ORDER BY [Project Name]"
'run the search
fLiveSearch Me.txtSearch, Me.lstItems, strFullList, strFilteredList, Me.txtCount
End If
End Sub
Private Sub txtSearch_KeyPress(KeyAscii As Integer)
'NECESSARY TO IDENTIFY IF THE USER IS HITTING THE SPACEBAR
'IN WHICH CASE WE WANT TO IGNORE THE INPUT
On Error GoTo err_handle
If KeyAscii = 32 Then
blnSpace = True
Else
blnSpace = False
End If
Exit Sub
err_handle:
Select Case Err.Number
Case Else
MsgBox "An unexpected error has occurred: " & vbCrLf & Err.Description & _
vbCrLf & "Error " & Err.Number & "(" & Erl & ")"
End Select
End Sub
Private Sub txtSearch_GotFocus()
' USED TO REMOVE THE PROMPT IF THE CONTROL GETS FOCUS
On Error Resume Next
If Me.txtSearch.Value = "(type to search)" Then
Me.txtSearch.Value = ""
End If
End Sub
Private Sub txtSearch_LostFocus()
' USED TO ADD THE PROMPT BACK IN IF THE CONTROL LOSES FOCUS
On Error Resume Next
If Me.txtSearch.Value = "" Then
Me.txtSearch.Value = "(type to search)"
End If
End Sub
Private Sub Form_Close()
DoCmd.SetWarnings False
End Sub
I've inherited this database and am trying to fix up areas that are not working. I'm definitely a novice and I can't seem to figure out where the error might be in the code that is causing the wrong value to save to the record. Any guidance would be appreciated.
Replace:
'run the search
fLiveSearch Me.txtSearch, Me.lstItems, strFullList, strFilteredList, Me.txtCount
With
me.lstitems.rowsourcetype = "Table/Query"
me.lstitems.rowsource = strfilteredlist
Related
I'm currently building a form where a user can look up a tool based on the description or part number.
I want user to be able to type any letters into the combobox that I have tied to a query listing all my tools and the combobox will repopulate itself with the tools most similar to what is present in their combobox. For example, if they start typing wre, then tools that have similar characters will start appearing in the combobox such as wrench, torque wrench, power wrench, etc.
I've tried looking around for other people's solutions to this but either I didn't fully comprehend the existing solution (I'm fairly new to Access) or it wasn't what I was looking for. I've seen that people suggested using a listbox instead but I really don't want to go down that route.
I was thinking about using what the user types in the combobox and my VBA code will pick up the "change event" and requery the combobox on the fly by using their input as the like criteria for the new query.
Is this a possible route? Will it be slower? Is there a better route?
I'm hoping someone can show some examples on how to achieve what I'm looking for.
The search as you type feature is very useful! With a textbox and a listbox, you can setup a dynamic search tool that will filter a list for approximate matches as you type. The textbox has four events associated with it, as seen here.
The code behind the form looks like this. Pay attention to the part in bold. This is where we create a string of SQL commands, and utilize the SQL Like operator, to get dynamic matches as we type. Pay attention to the text in bold below.
Option Compare Database
Option Explicit On
Private blnSpace As Boolean 'INCLUDE THIS LINE ON YOUR FORM
Private Sub btnClearFilter_Click()
'CODE FOR THE RED "X" BUTTON TO CLEAR THE FILTER AND SHOW ALL
On Error Resume Next
Me.txtSearch.Value = ""
txtSearch_Change()
End Sub
Private Sub txtSearch_Change()
'CODE THAT HANDLES WHAT HAPPENS WHEN THE USER TYPES IN THE SEARCH BOX
Dim strFullList As String
Dim strFilteredList As String
If blnSpace = False Then
Me.Refresh 'refresh to make sure the text box changes are actually available to use
'specify the default/full rowsource for the control
strFullList = "SELECT RecordID, First, Last FROM tblNames ORDER BY First;"
'specify the way you want the rowsource to be filtered based on the user's entry
strFilteredList = "SELECT RecordID, First, Last FROM tblNames WHERE [First] LIKE ""*" & Me.txtSearch.Value &
"*"" OR [Last] LIKE ""*" & Me.txtSearch.Value & "*"" ORDER BY [First]"
'run the search
fLiveSearch Me.txtSearch, Me.lstItems, strFullList, strFilteredList, Me.txtCount
End If
End Sub
Private Sub txtSearch_KeyPress(KeyAscii As Integer)
'NECESSARY TO IDENTIFY IF THE USER IS HITTING THE SPACEBAR
'IN WHICH CASE WE WANT TO IGNORE THE INPUT
On Error GoTo err_handle
If KeyAscii = 32 Then
blnSpace = True
Else
blnSpace = False
End If
Exit Sub
err_handle:
Select Case Err.Number
Case Else
MsgBox "An unexpected error has occurred: " & vbCrLf & Err.Description &
vbCrLf & "Error " & Err.Number & "(" & Erl() & ")"
End Select
End Sub
Private Sub txtSearch_GotFocus()
' USED TO REMOVE THE PROMPT IF THE CONTROL GETS FOCUS
On Error Resume Next
If Me.txtSearch.Value = "(type to search)" Then
Me.txtSearch.Value = ""
End If
End Sub
Private Sub txtSearch_LostFocus()
' USED TO ADD THE PROMPT BACK IN IF THE CONTROL LOSES FOCUS
On Error Resume Next
If Me.txtSearch.Value = "" Then
Me.txtSearch.Value = "(type to search)"
End If
End Sub
Finally, in a regular module, you will need this script.
Option Compare Database
Option Explicit On
'************* Code Start **************
' This code was originally written by OpenGate Software
' It is not to be altered or distributed,
' except as part of an application.
' You are free to use it in any application,
' provided the copyright notice is left unchanged.
' OpenGate Software http://www.opengatesw.net
Function fLiveSearch(ctlSearchBox As TextBox, ctlFilter As Control,
strFullSQL As String, strFilteredSQL As String, Optional ctlCountLabel As Control)
Const iSensitivity = 1 'Set to the number of characters the user must enter before the search starts
Const blnEmptyOnNoMatch = True 'Set to true if you want nothing to appear if nothing matches their search
On Error GoTo err_handle
'restore the cursor to where they left off
ctlSearchBox.SetFocus
ctlSearchBox.SelStart = Len(ctlSearchBox.Value) + 1
If ctlSearchBox.Value <> "" Then
'Only fire if they've input more than two characters (otherwise it's wasteful)
If Len(ctlSearchBox.Value) > iSensitivity Then
ctlFilter.RowSource = strFilteredSQL
If ctlFilter.ListCount > 0 Then
ctlSearchBox.SetFocus
ctlSearchBox.SelStart = Len(ctlSearchBox.Value) + 1
Else
If blnEmptyOnNoMatch = True Then
ctlFilter.RowSource = ""
Else
ctlFilter.RowSource = strFullSQL
End If
End If
Else
ctlFilter.RowSource = strFullSQL
End If
Else
ctlFilter.RowSource = strFullSQL
End If
'if there is a count label, then update it
If IsMissing(ctlCountLabel) = False Then
ctlCountLabel.Caption = "Displaying " & Format(ctlFilter.ListCount - 1, "#,##0") & " records"
End If
Exit Function
err_handle:
Select Case Err.Number
Case 91 'no ctlCountLabel
'exit
Case 94 'null string
'exit
Case Else
MsgBox "An unexpected error has occurred: " & vbCrLf & Err.Description &
vbCrLf & "Error " & Err.Number & vbCrLf & "Line: " & Erl()
End Select
End Function
The code comes from this link:
http://www.opengatesw.net/ms-access-tutorials/Access-Articles/Search-As-You-Type-Access.html
I have an Access continuous form. I would like to change the forecolor of a specific record's field.
I have the field to highlight from the FieldModified field. So for example FieldModified = "Converted". Converted being a field on my form.
I would like to change the color of the "Converted" field, and do this for each record in the form.
I thought this code would work, but I get an error on Me.[FieldModified].ForeColor. And I need to do this for each record in the form.
Code:
Private Sub Form_Load()
Dim fldName As String
fldName = Me.FieldModified.value
If (Not IsNull(fldName)) Then
Me.[fldName].ForeColor = vbRed '<--doesn't recognize fldName value
End If
End Sub
Updated code but it gives me an error 438 saying object doesn't support this property or method. But the form does highlight fields on the form but it highlights more then the one field "fldName"
Private Sub Form_Load()
Dim rstForm As String
Dim fldName As String
Set rstForm = Me.ChangedData.Form.Recordset
Do While Not rstForm.EOF
fldName = Me.FieldModified.value
If (Not IsNull(fldName)) Then
Me.Controls(fldName).ForeColor = vbRed '<--doesn't recognize fldName value
End If
rstForm.MoveNext
Loop
End Sub
You set the default format for the control. Every copy of the control in the continuous form uses this format. To format by a condition (fldName = Me.FieldModified.value) you need Condtional Formatting as Andre told you or use the detail-sections paint event (see update on bottom)
In conditional format wizard, you can create a condtion withExpression Isand[Converted].Name = [FieldModified]for each control of the form that should be highlighted, if its name matchesFiledModified. In Ms Access expressions you can't useMe, just omit it .
You can use VBA to format all controls with FormatConditions by code. If you want to modify an existing condition use.Modifyinstead of.Add
Private Sub Form_Load()
Dim ctl As Access.Control
For Each ctl In Me.Controls ' loop through all controls of form
On Error Resume Next ' Not all controls can have conditional format (e.g. labels). To save the check of control type, we ignore errors here
ctl.FormatConditions.Add(acExpression, , ctl.Name & ".Name=[FieldModified]").BackColor = vbRed 'add o format condition to control if possible, else an error is raised but ignored
If Err.Number Then 'show errors
Debug.Print "Error: " & Err.Number & " - " & Err.description & " in Control: " & ctl.Name & " Type is " & TypeName(ctl)
Err.Clear 'reset error to catch next
Else
Debug.Print "FormatCondition added to Control: " & ctl.Name & " Type is " & TypeName(ctl)
End If
Next ctl
On Error GoTo 0 ' turn on errors again, maybe add an error handler (On Error Goto MyErrHandler)
End Sub
Update:
You can use theDetails_Paintevent of the form to format same control different per record. This enables conditional format for controls withoutFormatConditionsproperty like labels, buttons.
Private Sub Detail_Paint()
Dim c As Access.Control
For Each c In Me.Detail.Controls
If c.Name = Me.FieldModified.Value Then
c.ForeColor = vbRed
Else
c.ForeColor = vbBlack
End If
Next
End Sub
You can't use a String variable like this, fldName is an identifier holding a String value.. not an identifier - in Me.ControlName, both Me and ControlName are identifiers.
But not all hope is lost! You can use a String to pull a Control object from a form!
All form controls should exist in the form's Controls collection, keyed by name:
Me.Controls(fldName).ForeColor = vbRed
I have use "E "0000000000a;0;# in input mask and included this code to check if the employeeCode already exists in the Before Update.
But when i am trying to input a duplicate employee code. It's allowing it.
Any idea?
Private Sub Empl_Code_BeforeUpdate(Cancel As Integer)
If IsNull(DLookup("[EmplCode]", _
"FORM EMPLOYEE", _
"[EmplCode] = """ & Me.Empl_Code.Text & """")) = False Then
Cancel = True
MsgBox "Record already exists", vbOKOnly, "Warning"
Me![Empl Code].Undo
End If
End Sub
Your code looks legit.
Test your IsNull(DLookup... expression in Immediate window (View - Immediate window in VBA Editor) when you are trying to input a duplicate code.
Also you can shorten a bit your expression with DCount like that:
Private Sub Empl_Code_BeforeUpdate(Cancel As Integer)
If DCount("*", _
"FORM EMPLOYEE", _
"[EmplCode] = """ & Me.Empl_Code.Text & """") > 0 Then
Cancel = True
MsgBox "Record already exists", vbOKOnly, "Warning"
Me![Empl Code].Undo
else
' Just for test
MsgBox "Value: " & Me.Empl_Code.Text
End If
End Sub
Any ideas why I am getting an "Enter Parameter Value" input box when running this code?
Private Sub cmdPrint_Click()
Dim str As String
On Error GoTo ErrHandler
If IsNull(Me.Combo_1) Then
MsgBox "Can't print an unsaved record", _
vbOKOnly, "Error"
Exit Sub
End If
str = "Combo_1 = '" & Me!Combo_1 & "'"
Debug.Print str
DoCmd.OpenReport "rptBarCodeLabels(2)", acViewPreview, , str
Exit Sub
ErrHandler:
MsgBox Err.Number & ": " _
& Err.Description, vbOKOnly, "Error"
End Sub
Edit: The button is being used to print a label of what's currently selected in Combo_1. Once the print button has been clicked, I wanted it to display the single record I chose in the label report I have it referencing. I am using Access 2003 if that means anything.
If a field name in a query contains punctuation (Combo_1), you should enclose in brackets, like so:
str = "[Combo_1] = '" & Me!Combo_1 & "'"
The Report is expecting a parameter, but not getting it because it's not being passed through in the correct manner.
I've found a solution by using some coding that was provided here: http://www.techrepublic.com/article/how-to-print-one-or-more-labels-for-a-single-access-record/
What fixed the error was most likely creating a temporary table and temporary report.
I try to improve a report I made to document databases, by adding a VBA line count to Modules and Forms. The following code works perfectly in a standard module:
Sub test()
Dim accObj As AccessObject, bwasOpen As Boolean, objName As String
objName = "Form1"
Set accObj = CurrentProject.AllForms(objName)
bwasOpen = accObj.IsLoaded
If Not bwasOpen Then
DoCmd.OpenForm objName, acDesign, WindowMode:=acHidden
End If
If Forms(objName).HasModule Then
DoCmd.OpenModule "Form_" & objName
Debug.Print Modules("Form_" & objName).CountOfLines
End If
If Not bwasOpen Then
DoCmd.Close acForm, objName, acSaveNo
End If
End Sub
But when I use a similar code in the report itself, I have an error. And since that error is happening in the class module (the report), I feel a bit stuck with debugging. The code in the report:
Set accObj = CurrentProject.AllForms(objName)
bwasOpen = accObj.IsLoaded
If Not bwasOpen Then
DoCmd.OpenForm objName, acDesign, WindowMode:=acHidden 'Breaks here
End If
If Forms(objName).HasModule Then
DoCmd.OpenModule "Form_" & objName
GetExtraInfo = Modules("Form_" & objName).CountOfLines
End If
If Not bwasOpen Then
DoCmd.Close acForm, objName, acSaveNo
End If
The code is called from a report control using =GetExtraInfo(). The whole thing works well, except this new part where I want to return the CountOfLines for Forms.
Update: I have added some error trapping, and it gives error:
2486 - You can't carry out this action at the present time
The whole db can be downloaded here, its's only 300 KB. The report is named "rptObjList".
The "bad" code has been commented out. It is an Access 2003 db.
Thanks for your help.
Your code opens a form and checks its .HasModule property. And if the form has a module, you open that module to check .CountOfLines. However, you need not open the module to determine its .CountOfLines. And I would try to avoid opening the form, too.
? VBE.ActiveVBProject.VBComponents("Form_Form1").CodeModule.CountOfLines
6
If you ask for .CountOfLines for a module which doesn't exist, such as the following, you can trap error #9 ('Subscript out of range') to give you an alternative to checking the .HasModule property:
? VBE.ActiveVBProject.VBComponents("bogus").CodeModule.CountOfLines
Or you could check for the code module with a function similar to minimally tested ModuleExists() outlined below.
Note I'm unsure how helpful my suggestions will be because I struggled to follow your code. Furthermore I unwisely chose to step through the code behind rptObjList and became frustrated by all the unhandled errors when it calls GetDesc() for objects which have no Description property. I just gave up.
Public Function ModuleExists(ByVal pModule As String, _
Optional ByVal pProject As String = "") As Boolean
Dim blnReturn As Boolean
Dim objVBProject As Object
Dim strMsg As String
On Error GoTo ErrorHandler
If Len(pProject) = 0 Then
Set objVBProject = VBE.ActiveVBProject
Else
Set objVBProject = VBE.VBProjects(pProject)
End If
blnReturn = Len(objVBProject.VBComponents(pModule).Name) > 0
ExitHere:
Set objVBProject = Nothing
ModuleExists = blnReturn
Exit Function
ErrorHandler:
Select Case Err.Number
Case 9 ' Subscript out of range
' no such module; function returns False
Case Else
strMsg = "Error " & Err.Number & " (" & Err.Description _
& ") in procedure ModuleExists"
MsgBox strMsg
End Select
GoTo ExitHere
End Function