Not in List event?

[Gasman]

Hi all,

I am using a routine that populates my combobox if the value is not there using the NotInList event. The data is entered in the form Surname Initial.Initial

The relevant code is hown below.

However as it is now, I have to remove the initials from the opened form that displays the new value added each time

So I tried the line
NewData = Left(NewData, InStr(NewData, " ") - 1)

to give me just the surname, but whilst that passes the correct value on, I get a repeat of the Not in list message and then property not found message when I return to the data entry form and the fieldis not populated as it is with the correct value when I do not use this line of code. Nor are any options showing in the drop down until I backspace sufficient to see and select the new value.

I made this amendment to speed up data entry, but it is having the opposite effect at present, hence commenting that line out.

I cannot find out why this behaviour is occurring and hoping for some expert help?

TIA

Private Sub Crew_ID_NotInList(NewData As String, Response As Integer)
'Dim strSurname As String
'NewData = Left(NewData, InStr(NewData, " ") - 1)
Response = AddNewToList(mixed_case(NewData), "Crew", "Surname", "Crews", "frmCrew")

End Sub


'************** Code Start *************
'This code was originally written by Jay Holovacs.
'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.
'
'Code Courtesy of
'Jay Holovacs
'
Public Function mixed_case(str As Variant) As String
'returns modified string, first character of each word us uppercase
'all others lower case
Dim ts As String, ps As Integer, char2 As String
    If IsNull(str) Then
        mixed_case = ""
        Exit Function
    End If
    str = Trim(str) 'added 11/22/98
    If Len(str) = 0 Then
        mixed_case = ""
        Exit Function
    End If
    ts = LCase$(str)
    ps = 1
    ps = first_letter(ts, ps)
    Special_Name ts, 1 'try to fix the beginning
    Mid$(ts, 1) = UCase$(Left$(ts, 1))
    If ps = 0 Then
        mixed_case = ts
        Exit Function
    End If
    While ps <> 0
        If is_roman(ts, ps) = 0 Then 'not roman, apply the other rules
            Special_Name ts, ps
            Mid$(ts, ps) = UCase$(Mid$(ts, ps, 1)) 'capitalize the first letter
        End If
        ps = first_letter(ts, ps)
    Wend
    mixed_case = ts
End Function
Private Sub Special_Name(str As String, ps As Integer)
'expects str to be a lower case string, ps to be the
'start of name to check, returns str modified in place
'modifies the internal character (not the initial)

Dim char2 As String
char2 = Mid$(str, ps, 2) 'check for Scots Mc
If (char2 = "mc") And Len(str) > ps + 1 Then '3rd char is CAP
    Mid$(str, ps + 2) = UCase$(Mid$(str, ps + 2, 1))
End If

char2 = Mid$(str, ps, 2) 'check for ff
If (char2 = "ff") And Len(str) > ps + 1 Then 'ff form
    Mid$(str, ps, 2) = LCase$(Mid$(str, ps, 2))
End If

char2 = Mid$(str, ps + 1, 1) 'check for apostrophe as 2nd char
If (char2 = "'") Then '3rd char is CAP
    Mid$(str, ps + 2) = UCase$(Mid$(str, ps + 2, 1))
End If

Dim char3 As String
char3 = Mid$(str, ps, 3) 'check for scots Mac
If (char3 = "mac") And Len(str) > ps + 1 Then 'Mac form
    Mid$(str, ps + 3) = UCase$(Mid$(str, ps + 3, 1))
End If

Dim char4 As String
char4 = Mid$(str, ps, 4) 'check for Fitz
If (char4 = "fitz") And Len(str) > ps + 1 Then 'Fitz form
    Mid$(str, ps + 4) = UCase$(Mid$(str, ps + 4, 1))
End If

End Sub
Private Function first_letter(str As String, ps As Integer) As Integer
'ps=starting point to search (starts with character AFTER ps)
'returns next first letter, 0 if no more left
'modified 6/18/99 to handle hyphenated names
Dim p2 As Integer, p3 As Integer, s2 As String
    s2 = str
    p2 = InStr(ps, str, " ") 'points to next blank, 0 if no more
    p3 = InStr(ps, str, "-") 'points to next hyphen, 0 if no more
    If p3 <> 0 Then
        If p2 = 0 Then
            p2 = p3
        ElseIf p3 < p2 Then
            p2 = p3
        End If
    End If
    If p2 = 0 Then
        first_letter = 0
        Exit Function
    End If
    'first move to first non blank, non punctuation after blank
    While is_alpha(Mid$(str, p2)) = False
        p2 = p2 + 1
        If p2 > Len(str) Then 'we ran off the end
            first_letter = 0
            Exit Function
        End If
    Wend
    first_letter = p2
End Function
Public Function is_alpha(ch As String)
'returns true if this is alphabetic character
'false if not
    Dim c As Integer
    c = Asc(ch)
    Select Case c
        Case 65 To 90
            is_alpha = True
        Case 97 To 122
            is_alpha = True
        Case Else
            is_alpha = False
    End Select
    
End Function
Private Function is_roman(str As String, ps As Integer) As Integer
'starts at position ps, until end of word. If it appears to be
'a roman numeral, than the entire word is capped in passed back
'string, else no changes made in string
'returns 1 if changes were made, 0 if no change
Dim mx As Integer, p2 As Integer, flag As Integer, i As Integer
    mx = Len(str) 'just so we don't go off the edge
    p2 = InStr(ps, str, " ") 'see if there is another space after this word
    If p2 = 0 Then
        p2 = mx + 1
    End If
    'scan to see if any inappropriate characters in this word
    flag = 0
    For i = ps To p2 - 1
        If InStr("ivxIVX", Mid$(str, i, 1)) = 0 Then
            flag = 1
        End If
    Next i
    If flag Then
        is_roman = 0
        Exit Function 'this is not roman numeral
    End If
    Mid$(str, ps) = UCase$(Mid$(str, ps, p2 - ps))
    is_roman = 1
End Function
'************** Code End  *************



' usage..... Response = AddNewToList(NewData, "LtblCounties", "txtCounty", "Counties")
Public Function AddNewToList(NewData As String, stTable As String, _
                                   stFieldName As String, strPlural As String, _
                                   Optional strNewForm As String) As Integer
On Error GoTo err_proc
    'Adds a new record to a drop down box list
    'If form name passed, then open this form to the newly created record

    'Declare variables
    Dim rst As DAO.Recordset
    Dim IntNewID As Long
    Dim strPKField As String
    Dim strMessage As String
    
    ' Display message box asking if user wants to add the new item
    strMessage = "'" & NewData & "' is not in the current list. " & Chr(13) & Chr(13) & _
                 "Do you want to add it to the list of " & strPlural & "?" & Chr(13) & Chr(13) & _
                 "(Please check the entry before proceeding)."

    If MsgBox(strMessage, vbYesNo + vbQuestion + vbDefaultButton2, "Add New Data") = vbYes Then
        Set rst = CurrentDb.OpenRecordset(stTable, , dbAppendOnly)
        rst.AddNew
            rst(stFieldName) = NewData                'Add new data from combo box
            strPKField = rst(0).Name                  'Find name of Primary Key (ID) Field
        rst.Update
        rst.Move 0, rst.LastModified
        IntNewID = rst(strPKField)

        'if a form specified, then open the form with the primary key equal to the new record ID as the criteria
        If strNewForm <> "" Then DoCmd.OpenForm strNewForm, , , strPKField & "=" & IntNewID
  
        AddNewToList = acDataErrAdded                'Set response 'Data added'
    Else
        AddNewToList = acDataErrContinue             'Set response 'Data NOT added'
    End If
    
exit_proc:
On Error Resume Next
    rst.Close
    Set rst = Nothing
    Exit Function

err_proc:
    MsgBox "Error in Function: 'AddNewToList'" & Chr(13) & Err.Description, , "Function Error"
    Resume exit_proc

End Function
'Notes:
'1. The Primary Key field must be numeric (long integer) and must always be the first field in the table.
'2. The 'Limit to List' property of the combo box must be set to 'Yes'
'3. strNewForm is opened in edit mode as the new record is added first and the form then opened to that record. A consequence of this is that other fields in the table must have their 'Required' property set to 'No' or a (valid) default property value set in the table design.
'4. FieldNamePlural is there simply to make the message grammatically correct; in the AddNewToList code the message box string generated as: strMessage = "'" & NewData & "' is not in the current list. " & Chr(13) ..... would result in the warning message (e.g.):
'London' is not in the current list. "
'Do you want to add it to the list of Cities?
'(Please check the entry before proceeding).
'5. If an edit form is opened (strNewForm <> "") then the field that is displayed in the combo box should be in a locked control on the form, alternatively remove the acDialog argument and ensure the combo box is re-queried when the form is closed.
'6. The form 'strNewForm' should have it's 'Allow Additions' and 'Data Entry' properties set to 'No' to prevent users from adding additional entries to the entry requested by the Not In List event.
'Enjoy!
'Edit1: 18/02/2013: Added Note 4
'Edit2: 02/03/2014: Added Notes 5 & 6.

 

[RuralGuy]

Would you explain again why you feel you need to remove the initial?

 

[moke123]

the problem is that your combobox is using a concatenated field as the newdata variable but your table stores the surname and initials in separate fields. generally the NIL is used for such things as categories, not names and initials. for instance Adams, J. could stand for John Adams or James Adams and therefore it would be unreliable data. You may need to take a different approach.

 

[Gasman]

Would you explain again why you feel you need to remove the initial?

RuralGuy,

I think Moke123 has hit the problem on the head.
In my Crew table I have ID, Surname, Initials. and my combo box on the Links data entry form shows the surname and initials together. That way I can select between different Jones, Smiths etc

However when the NIL fires I end up with RuralGuy A.A in the surname field of the Crew form, when all I want is Ruralguy

As Moke123 states, i might have to think my approach. I was just trying to shave some time off all the data entry I have to key in when a name is not already there.

 

[Gasman]

the problem is that your combobox is using a concatenated field as the newdata variable but your table stores the surname and initials in separate fields. generally the NIL is used for such things as categories, not names and initials. for instance Adams, J. could stand for John Adams or James Adams and therefore it would be unreliable data. You may need to take a different approach.

Thank you Moke123, for pointing me in the right direction.
As you say, I will need to take a different approach, but as I believe you might have identified where problem lies, I can now think of a solution.

 

[moke123]

try this in the forms notinlist event

Private Sub Crew_ID_NotInList(NewData As String, Response As Integer)
    Dim txtSur As String
    Dim txtInitials As String
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim strSql As String

    Response = acDataErrContinue

    If MsgBox(NewData & " is not in list. Add it?", vbYesNo) = vbYes Then

        strSql = "select * from  Crew"
        Set db = CurrentDb()
        Set rs = db.OpenRecordset(strSql)
        txtSur = Left(NewData, InStr(1, NewData, ",") - 1)
        txtInitials = Trim(Mid(NewData, InStr(1, NewData, ",") + 1))


        rs.AddNew
        rs!Surname = txtSur
        rs!Initials = txtInitials
        rs.Update

        Response = acDataErrAdded


MyExit:
        rs.Close
        Set rs = Nothing
        Set db = Nothing

    Else

        Response = acDataErrDisplay

    End If
End Sub

 

[Gasman]

Thank you Moke123

As you will have seen, I am using code found from the net, but your code tells me EXACTLY where I need to modify the code for that to work.

For now the code is not generic, so I am happy to change to suit.

Will report back on result.

Thanks again.

 

[moke123]

I am using code found from the net,

Actually i found that code and gave it to you a while back

you can probably add the other code - mixed_case, to the procedure just before the code to parse the newdata into txtSur and txtInitials

NewData = mixed_case(NewData)

 

[Gasman]

Actually i found that code and gave it to you a while back

you can probably add the other code - mixed_case, to the procedure just before the code to parse the newdata into txtSur and txtInitials

NewData = mixed_case(NewData)

Yes you did, and it has saved me a fair bit of time in data entry. I did not mean to imply that I had found it, just that it was not created by myself.

 

[Gasman]

That worked well Moke,
I left the other combos to still use the generic routine you initially supplied and cut out the form altogether (as I am the only one keying in the data) and just uppercased the initials.

Shaving some more time off data entry.

 

[moke123]

good to hear, good luck with your project.