Option Explicit
Function TranslateChar(StrIn As String) As String
' This function may be used in Excel or Access, or in any VB/VBA project.
' Function evaluates an ANSI string that may have special characters, identified
' in the collection populated below. If a special character is found, the function
' replaces that character with a designated replacement string (may be any number
' of characters). There is no support for Unicode.
' The function conserves case, so if the special character is uppercase, then the
' first character of the replacement string will be uppercase as well.
' While the intent of this function is to "replace" characters with diacritical
' marks with their Roman alphabet equivalents (you should feel free to change the
' mapping below if you do not think it's right or it does not suit your purposes;
' I am no linguist). However, you could use the code to replace any single ANSI
' character with whatever string you desire.
Dim Counter As Long
Static coll As Collection
Dim Check As String
Dim WasLower As Boolean
Dim Letter As String
' See if the collection exists. The collection is set up as a static variable, so
' that it will persist between function calls; that will save a few cycles on later
' function calls as there will be no need to create and populate the collection again.
' There wil be no "Set coll = Nothing" to release the object variable, though; we
' will rely on VBA to clean up the collection object for us when the user exits the
' application
If coll Is Nothing Then
Set coll = New Collection
' Populate a Collection with the mapping. The Key is the special character, and the
' Item is the replacement. The key must always be a single character, but the item
' may be 1+ characters. Use lower case in this list, and continue the list as
' needed.
coll.Add Item:="a", Key:="?"
coll.Add Item:="a", Key:="?"
coll.Add Item:="a", Key:="?"
coll.Add Item:="a", Key:="?"
coll.Add Item:="a", Key:="?"
coll.Add Item:="a", Key:="?"
coll.Add Item:="ae", Key:="?"
coll.Add Item:="c", Key:="?"
coll.Add Item:="e", Key:="?"
coll.Add Item:="e", Key:="?"
coll.Add Item:="e", Key:="?"
coll.Add Item:="e", Key:="?"
coll.Add Item:="i", Key:="?"
coll.Add Item:="i", Key:="?"
coll.Add Item:="i", Key:="?"
coll.Add Item:="i", Key:="?"
coll.Add Item:="n", Key:="?"
coll.Add Item:="o", Key:="?"
coll.Add Item:="o", Key:="?"
coll.Add Item:="o", Key:="?"
coll.Add Item:="o", Key:="?"
coll.Add Item:="o", Key:="?"
coll.Add Item:="oe", Key:="?"
coll.Add Item:="ss", Key:="?" ' German sharp s
coll.Add Item:="th", Key:="?" ' Old English eth
coll.Add Item:="th", Key:="?" ' Old English thorn
coll.Add Item:="u", Key:="?"
coll.Add Item:="u", Key:="?"
coll.Add Item:="u", Key:="?"
coll.Add Item:="u", Key:="?"
coll.Add Item:="y", Key:="?"
coll.Add Item:="y", Key:="?"
' This entry is for illustration only! You should remove before using!
coll.Add Item:="dollar", Key:="$"
End If
' Loop through string to look for special characters needing replacement
For Counter = 1 To Len(StrIn)
' Look in collection to see if the current character being considered is a "special"
' character
On Error Resume Next
Letter = Mid(StrIn, Counter, 1)
Check = coll(Letter)
' Check to see if original character was upper or lower case
WasLower = (StrComp(Letter, LCase(Letter), vbBinaryCompare) = 0)
' If there was no error, that means character was in collection and thus is a
' special character needing replacement
If Err <> 0 Then
Err.Clear
Check = Letter
End If
On Error Goto 0
' If character was lower case, return the translation in lower case. If upper case,
' return in proper case (first character capitalized)
TranslateChar = TranslateChar & IIf(WasLower, LCase(Check), StrConv(Check, vbProperCase))
Next
End Function
|