Find and change a character (Access 97) 2

[HenryAnthony]

Hi,

In a field that contains variable length strings, I need to find (using code, not manual search and replace) any occurance of an apostrophe and change it to a different character. Any help will be greatly appreciated.

Best regards,

Henr¥

 

[oharab]

Put this code into a module:

'************ Code Start **********
'This code was originally written by Alden Streeter.
'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
'Alden Streeter
'
Function FindAndReplace(ByVal strInString As String, _
strFindString As String, _
strReplaceString As String) As String
Dim intPtr As Integer
If Len(strFindString) > 0 Then
Do
intPtr = InStr(strInString, strFindString)
If intPtr > 0 Then
FindAndReplace = FindAndReplace & Left(strInString, intPtr - 1) & _
strReplaceString
strInString = Mid(strInString, intPtr + Len(strFindString))
End If
Loop While intPtr > 0
End If
FindAndReplace = FindAndReplace & strInString
End Function
'************ Code End **********

then create an update query on the table you are manipulating:

UPDATE tblData SET tblData.Surname = findandreplace([surname],"'","*"

change tblData & surname to match your data.

HTH

Ben
----------------------------------
Ben O'Hara
bo104@westyorkshire.police.uk
----------------------------------

 

[HenryAnthony]

Ben,

This is truly awesome! Hope I can get it to work. Looks pretty straight forward. Thank you soooooo much.

Any ideas on doing a multiple search and replace )

Best regards,

Henr¥

 

[oharab]

You can nest the functions.

findandreplace(findandreplace(strText,"1","2&quot,"3","4&quot

will find all 1's and replace them with 2's AND all 3's will be replaced with 4's.

HTH

Ben ----------------------------------
Ben O'Hara
bo104@westyorkshire.police.uk
----------------------------------

 

[HenryAnthony]

You rule

 

[HenryAnthony]

This works GREAT! Thanks for your help.

Best of all, I think I finally got it through my head how to create your own functions and use them in queries. What a revelation. And of course, Kudos to Alden Streeter, creator of the code.

I love this forum!

Best regards,

Henr¥

 

[HenryAnthony]

OK Ben, so while you are at it, how about even some more help with this one. I searched Alden Streeter and came up with this code that fixes mixed case names but I have no idea how to call it in a query. Thanks in advance. Next time you are in the Detroit, Michigan area, look me up, I owe you lunch!

'************** 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 special cap rules
If (char2 = &quot;mc&quot; Or char2 = &quot;o'&quot And Len(str) > ps + 1 Then 'Mc form
Mid$(str, ps + 2) = UCase$(Mid$(str, ps + 2, 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, &quot; &quot 'points to next blank, 0 if no more
p3 = InStr(ps, str, &quot;-&quot '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, &quot; &quot '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(&quot;ivxIVX&quot;, 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 *************

 

[Guest_imported]

I tried running this by way of creating a new module in my Access 2000.
[tt]

Function FindAndReplace(ByVal strInString As String, _
strFindString As String, _
strReplaceString As String) As String
Dim intPtr As Integer
If Len(strFindString) > 0 Then
Do
intPtr = InStr(strInString, strFindString)
If intPtr > 0 Then
FindAndReplace = FindAndReplace & Left(strInString, intPtr - 1) & _
strReplaceString
strInString = Mid(strInString, intPtr + Len(strFindString))
End If
Loop While intPtr > 0
End If
FindAndReplace = FindAndReplace & strInString
End Function
'************ Code End **********[/tt]

then created an update query on the table you are manipulating
by going into query and creating a new query such as:
[tt]
UPDATE Projects SET Projects.name = findandreplace([name],&quot;old'&quot;,&quot;new&quot;[/tt]

I then get error processing the info and it doesnt change the data in the name field.
Please adivse what I am doing wrong.

 

[HenryAnthony]

Ecuadr,

The function works fine for me. I even amazed myself because I got it to work the first time I tried it! Kudos to the programmer gods lording over this forum.

What are you searching for and what do you want to replace it with?

Best regards,

Henr¥

 

[SgtJarrow]

Just have to throw my two cents in here....the below code allows you to change as many characters as you want with just on pass....just a bit easier....

Code is called as such:
dhTranslate(strString, &quot;1234&quot;, &quot;fjgh&quot

Two points:
1. The replacement is one for one...i.e. all 1's are replaced by f's, all 2's by j's, etc
2. If your replacement string is shorter than your replace string, all &quot;extra&quot; characters in the replace string are replaced with the last in the replacement string such as: dhTranslate(strString, &quot;12345&quot;, &quot; &quot replaces all 1's, 2's, 3's, 4's, and 5's with a space.

'***********Start Code***************

Public Function dhTranslate(ByVal strIn As String, ByVal strMapIn As String, _
ByVal strMapOut As String) As String

Dim lngI As Long
Dim lngPos As Long
Dim strChar As String * 1
Dim strOut As String

'If there's no list of characters to replace, there's no point going on with the work
If Len(strMapIn) > 0 Then
'Right fill the strMapOut set
If Len(strMapOut) > 0 Then
strMapOut = Left$(strMapOut & String(Len(strMapIn), Right$(strMapOut, 1)), Len(strMapIn))
End If
For lngI = 1 To Len(strIn)
strChar = Mid$(strIn, lngI, 1)
lngPos = InStr(1, strMapIn, strChar, vbBinaryCompare)
If lngPos > 0 Then
'If strMapOut is empty, this doesn't fail, because Mid handles empty strings gracefully
strOut = strOut & Mid$(strMapOut, lngPos, 1)
Else
strOut = strOut & strChar
End If
Next lngI
End If
dhTranslate = strOut

End Function
'*****End Code**********

It's not important that someone else can do in one step what it took you ten to do...the important thing is that you found a solution.

Robert L. Johnson III, A+, Network+, MCP
Access Developer/Programmer

 

[HenryAnthony]

Hi Robert,

Thanks for that. I love how you can get to the same place so many different ways using Access. I am a graphic designer, mainly, and find using Access very stimulating from a creative perspective. Your help is greatly appreciated.

Best regards,

Henr¥