[7 May update: Fixes lost focus that MsgBox creates. Also improves and fixes error messages.]
This is currently designed to work w/ a MariaDB connected database (a MySQL binary replacement) so will need to be modified a bit to work with HSQLDB which uses different SQL quoting.
For the combo box data it assumes you’re using SQL ‘Type of list contents…’ (not Table, Query, etc). It grabs the information it needs from various places including the underlying SQL to make it easier to hookup to multiple columns with just one Sub.
You might need some coding experience to get this to work for you. I’ve left in some code commented out to help remind me of related things that aren’t needed in this code.
Option Explicit 'BASIC ###### ComboBox lookup auto-update ######
Private Sub BeforeUpdatingComboBox(oEvent As Object) As Boolean 'Fires when cr is hit: when something is selected or entered
On Error GoTo Error_Handler
'--- Constants
Dim sbCR As String : sbCR = chr(10)
'buttons displayed
Const sbOkOnly = 0
Const sbYesNo = 4
'icons displayed
Const sbQuestion = 32
Const sbExclamation = 48
'answers returned
Const sbYes = 6
Const sbNo = 7
'---Get context
Dim oComboBox As Object : oComboBox = oEvent.Source
'Check that setup is correct
if oComboBox.ListSourceType <> com.sun.star.form.ListSourceType.SQL Then MsgBox(_
"This version of the 'BeforeUpdatingComboBox' event handler requires that combo box 'Type of list contents...' be set to SQL (rather than Table, Query, etc.).",_
sbOkOnly+sbExclamation,_
"Fatal configuration error - Missing SQL text"): stop
'See if what was selected is in the underlying data
Dim sInput As String : sInput = oComboBox.getCurrentValue 'String that was entered before CR
' Dim sInput As String : sInput = oComboBox.Text 'String that was entered before CR
'If input is not null, then look to see if it's in the table aready, and if not add it
If sInput<>"" Then
Dim sName As String : sName = oComboBox.DataField 'My field's Name (not combo box name)
' Dim sName As String : sName = oComboBox.BoundField.Name 'My field's Name (not combo box name) (same as above)
'' Dim iItems As Integer : iItems = oComboBox.ItemCount '# of items in combo box lookup (not used)
'' Dim sItems() As String : sItems = oComboBox.StringItemList 'array of all combo box items (not used)
Dim sSQL As String : sSQL = oComboBox.ListSource 'SELECT `To` FROM `accounting`.`tos` AS `tos` ORDER BY `To` ASC
'Take SQL apart into phrases. Add WHERE for ID=
Const cOB=" ORDER BY ":Dim sOrderBy As String :sOrderBy= sRightParam(sSQL, cOB, iStart(sSQL, cOB)) :sSQL = sRemainder(sSQL ,iStart(sSQL , cOB)) 'get & remove any ORDER BY phrase
Const cWH=" WHERE " :Dim sWhere As String :sWhere = sRightParam(sSQL, cWH, iStart(sSQL, cWH)) :sSQL = sRemainder(sSQL ,iStart(sSQL , cWH)) 'get & remove any WHERE phrase
Const cFR=" FROM " :Dim sFROM As String :sFROM = sRightParam(sSQL, cFR, iStart(sSQL, cFR)) 'get FROM phrase
Const cAS=" As " : sFrom = sRemainder(sFrom,iStart(sFROM, cAS)) ' remove any As phrase
'sSQL = SELECT ... FROM ...
sSQL = sSQL & cWH & "(" & iif(sWhere<>"", sWhere & ") AND ( " ,"") & "`" & sName & "` = ?);" 'add new WHERE criteria (prepared statement)
'--- Now execute this SQL to find if the selected item already existed in the table.
'First get a connection object.
DIM oDatasource AS OBJECT :oDatasource = thisComponent.Parent.dataSource
DIM oConnection AS OBJECT :oConnection = oDatasource.getConnection("","")
Dim oSQL As Object :oSQL = oConnection.prepareStatement(sSQL) 'Create SQL prepared statement; the thing that will carry out the SQL-command
' On Error GoTo Next
' oSQL.ResultSetType = com.sun.star.sdbc.ResultSetType.SCROLL_INSENSITIVE 'For HSQLDB 1.8 (not for MySQL)
' On Error GoTo 0 '?? restore this to: On Error GoTo Error_Handler
Dim oResults As Object :oSQL.setString(1,sInput): oResults = oSQL.executeQuery() 'Execute SQL statement with parameter & get results
'If not found then possibly add it
If not oResults.First() Then
'ask what to do
Dim iAnswer As Integer : iAnswer = MsgBox(_
"""" & sInput & """ is not a previously used " & sName & ". " & sbCR & "Do you want to add it now?", _
sbYesNo + sbQuestion, _
"Unknown entry" )
Select Case iAnswer
Case sbYes
sSQL = "INSERT INTO " & sFrom & " (`" & sName & "`) Select ?;"
oSQL = oConnection.prepareStatement(sSQL) 'Create SQL prepared statement; the thing that will carry out the SQL-command
oSQL.setString(1,sInput): oResults = oSQL.executeQuery() 'Execute SQL statement with parameter & get results
oComboBox.Refresh 'Reload (sort) lookup list
BeforeUpdatingComboBox = true 'advance cursor to next field
' Dim oTable As Object : oTable = oComboBox.Parent
' Dim oControlView As Object : oControlView = ThisComponent.CurrentController.GetControl(oTable)
' oControlView.SetFocus 'restore the focus after the MsgBox lost it
ThisComponent.CurrentController.GetControl(oComboBox.Parent).SetFocus 'restore the focus after the MsgBox lost it
' oControlView.setCurrentColumnPosition(oControlView.CurrentColumnPosition) 'restore the column# (don't need this)
Case sbNo
' MsgBox "Please select an item from the list.", sbExclamation + sbOKOnly, "Invalid Entry"
BeforeUpdatingComboBox = false 'don't advance cursor to next field
End Select
End If
End If
Exit_Procedure:
Exit Sub
Error_Handler:
'Error 'Error message of the last error.
'Erl 'Integer line number of the last error.
'Err 'Integer error number of the last error.
'CVErr 'Convert an expression to an error object.
MsgBox "Line " & Erl & ": " & Error & " (error " & Err & ")"
Resume Exit_Procedure
End Sub
'- Find position of start of this phrase
Sub iStart (sStr As String, sDelim As string ) As Integer
iStart = InStr(sStr, sDelim)-1 :If iStart<0 Then: iStart=0 :End If
End Sub
'- Return the right most phrase (but not the delimiter)
Sub sRightParam (sStr As String, sDelim As string, iStart As Integer ) As String
sRightParam = "" : If iStart Then sRightParam =Right(sStr, Len(sStr)-iStart-Len(sDelim))
End Sub
'- Return what's to the left of the phrase delimiter
Sub sRemainder (sStr As String, iStart As Integer ) As String
sRemainder = sStr : If iStart Then sRemainder=Left(sStr,iStart)
End Sub
'ACCESS:
Private Sub To_NotInList(NewData As String, Response As Integer)
NotInList "Tos", "To", NewData, Response
End Sub
Private Sub With_NotInList(NewData As String, Response As Integer)
NotInList "Withs", "With", NewData, Response
End Sub
Private Sub For_NotInList(NewData As String, Response As Integer)
NotInList "Fors", "For", NewData, Response
End Sub
Private Sub NotInList(TableName As String, FieldName As String, NewData As String, Response As Integer)
On Error GoTo Error_Handler
Dim intAnswer As Integer
intAnswer = MsgBox("""" & NewData & """ is not a previously used " & FieldName & " party. " & vbCrLf & "Do you want to add it now?", vbYesNo + vbQuestion, "Invalid Category")
Select Case intAnswer
Case vbYes
DoCmd.SetWarnings False
DoCmd.RunSQL "INSERT INTO [" & TableName & "] ([" & FieldName & "]) Select """ & NewData & """;"
DoCmd.SetWarnings True
Response = acDataErrAdded
Case vbNo
MsgBox "Please select an item from the list.", vbExclamation + vbOKOnly, "Invalid Entry"
Response = acDataErrContinue
End Select
Exit_Procedure:
DoCmd.SetWarnings True
Exit Sub
Error_Handler:
MsgBox Err.Number & ", " & Err.Description
Resume Exit_Procedure
Resume
End Sub
