gold007eye
Registered User.
- Local time
- Today, 04:41
- Joined
- May 11, 2005
- Messages
- 260
Does anyone know how I can implement the following code into my existing "ProperCase" module so that it would work as one. The ProperCase code I got from these forums works great and has an "Exception List", but the only downfall is it can't detect numeric values before an Alpha character.
Any help would be greatly appreciated as I can't seem to figure out how to integrate the 2 together.
This code checks to see if there is an Alpha character after a number. (Example: 418c centre street) and would then convert it to upper case (418C Centre Street):
This is the current code I use for ProperCase with an Exception List:
Any help would be greatly appreciated as I can't seem to figure out how to integrate the 2 together.
This code checks to see if there is an Alpha character after a number. (Example: 418c centre street) and would then convert it to upper case (418C Centre Street):
Code:
Function NumericAddress(strIn As String) As String
Dim arrString() As String
Dim j As Integer
Dim I As Integer
strIn = StrConv(strIn, vbProperCase)
arrString = Split(strIn, " ")
For j = 0 To UBound(arrString)
For I = 1 To Len(arrString(j))
If IsNumeric(Mid(arrString(j), I, 1)) Then
arrString(j) = StrConv(arrString(j), vbUpperCase)
Exit For
End If
Next I
Next j
NumericAddress = Join(arrString(), " ")
End FunctionThis is the current code I use for ProperCase with an Exception List:
Code:
Option Compare Binary
' So that MacDonald <> Macdonald in this module only! The mdlGetException module is set to Option Compare Database
' so that exceptions need only be typed into the exception table once.
Option Explicit ' Require variable declaration
Global Const mstrTableName = "Exceptions" 'Exception table and field names. These may be changed if needed.
Global Const mstrFieldName1 = "[Exception List]" 'Holds the exception word. Case doesn't matter.
Global Const mstrFieldName2 = "Replacement" 'Holds the replacement for the exception. Capitalize this the way you want
'it to appear.
Global Const vbUpperCase = 1 'Converts the string to uppercase characters.
Global Const vbLowerCase = 2 'Converts the string to lowercase characters.
Global Const vbProperCase = 3 'Converts the first letter of every word in string to uppercase.
Global Const vbSentenceCase = 4 'Converts the first letter of the string to uppercase, all others to lowercase.
'Message box types
Global Const MB_OKCANCEL = &H1
Global Const MB_ABORTRETRYIGNORE = &H2
Global Const MB_YESNOCANCEL = &H3
Global Const MB_YESNO = &H4
Global Const MB_RETRYCANCEL = &H5
'Message box icons
Global Const MB_ICONSTOP = &H10
Global Const MB_ICONQUESTION = &H20
Global Const MB_ICONEXCLAMATION = &H30
Global Const MB_ICONINFORMATION = &H40
'Message box default buttons
Global Const MB_DEFBUTTON1 = &H0
Global Const MB_DEFBUTTON2 = &H100
Global Const MB_DEFBUTTON3 = &H200
'Message box return values
Global Const MB_OK = 1
Global Const MB_CANCEL = 2
Global Const MB_ABORT = 3
Global Const MB_RETRY = 4
Global Const MB_IGNORE = 5
Global Const MB_YES = 6
Global Const MB_NO = 7
Public dbs As Database, rst As Recordset
Dim varImpWord As Variant, varPropWord As Variant, varOutput As Variant, varTemp As Variant
' ^--Improper word ^--Proper word ^--Output string
Dim intResult As Integer
Public varSepChar As Variant, varWordList() As Variant, intSepCharCnt As Integer, intWordCount As Integer
Dim booCallFromPropMan As Boolean
Function ProperCase(varPropCaseInput As Variant, intConversion As Integer) As Variant
' This function takes a variant and applies word caps. It also has an exception list stored as an Access table where
' it overrides the word caps rule. Individual cases will have to be added to the exception list manually or at run time by using the
' ProperManager wrapper function. The exception list cannot contain wildcards; however, capitalization of the exception (first
' column) isn't important. The replacement (second column) must be capitalized the way you want it to appear. The table
' contains two indexed columns of type text and length 50. Table name and column names are given in the constants above.
' The return value is a variant containing the string in Proper Case.
Dim I As Integer
If IsNull(varPropCaseInput) Then GoTo ProperCase_Exit
varOutput = Null 'Initializes variables
varImpWord = Null
varPropWord = Null
Select Case intConversion
Case Is = vbProperCase
ParseWords (varPropCaseInput)
For I = 0 To Len(varPropCaseInput) 'Iterates through word list
If IsEmpty(varWordList(I, 0)) Then 'Word element is empty
If IsEmpty(varWordList(I, 1)) Then 'Word separator element is empty - completed proper casing.
ProperCase = BuildOutput(varPropCaseInput) 'Build output string
Exit For
End If
Else 'Word element is not empty
varImpWord = varWordList(I, 0) 'Get word
varTemp = GetException(varImpWord) 'Check word against exception list
If Len(varTemp) <> 0 Then 'Word is present in the exception list
varPropWord = varTemp 'Get replacement word for exception
Else 'Word is not in the exception list
varPropWord = UCase(Left(varImpWord, 1)) & LCase(Mid(varImpWord, 2)) 'Proper case word
If booCallFromPropMan = True Then ManageException
'Goes to exception management sub if ProperCase was called from ProperManager
End If
varWordList(I, 0) = varPropWord 'Inserts the proper cased word back into the word list
End If
Next I
Case Is = vbUpperCase
varOutput = UCase(varPropCaseInput)
Case Is = vbLowerCase
varOutput = LCase(varPropCaseInput)
Case Is = vbSentenceCase
ParseWords (varPropCaseInput)
For I = 0 To Len(varPropCaseInput) 'Iterates through word list
If IsEmpty(varWordList(I, 0)) Then 'Word element is empty
If IsEmpty(varWordList(I, 1)) Then 'Word separator element is empty - completed proper casing.
ProperCase = BuildOutput(varPropCaseInput) 'Build output string
Exit For
End If
Else 'Word element is not empty
varImpWord = varWordList(I, 0) 'Get word
varTemp = GetException(varImpWord) 'Check word against exception list
If Len(varTemp) <> 0 Then 'Word is present in the exception list
varPropWord = varTemp 'Get replacement word for exception
Else 'Word is not in the exception list
If varWordList(I, 2) = 1 Then
varPropWord = UCase(Left(varImpWord, 1)) & LCase(Mid(varImpWord, 2))
'If this is the first word in the string, then proper case word
Else
varPropWord = LCase(varImpWord) 'Convert word to lower case
End If
If booCallFromPropMan = True Then ManageException
'Goes to exception management sub if ProperCase was called from ProperManager
End If
varWordList(I, 0) = varPropWord 'Inserts the proper cased word back into the word list
End If
Next I
End Select
ProperCase = varOutput
booCallFromPropMan = False
ProperCase_Exit:
End Function
Function ProperManager(varPropManInput As Variant, intConversion As Integer) As Variant
' This function can be optionally used to *wrap* the ProperCase routine and perform some management of the exception list.
' Deleting items from the list is up to the individual developer.
booCallFromPropMan = True 'Tells the ProperCase function to call ManageExceptions when needed.
ProperManager = ProperCase(varPropManInput, intConversion)
ProperManager_Exit:
End Function
Sub ManageException() 'Queries the user and adds exceptions to the list
If varPropWord <> varImpWord Then
' ProperCase has changed the text. Confirm with user.
intResult = MsgBox("ProperCase has changed '" & varImpWord & "' to '" & varPropWord & "'. Is this correct?", _
MB_YESNO + MB_ICONQUESTION, "ProperCase Exceptions Manager")
If intResult = MB_NO Then 'Not correct
intResult = MsgBox("Do you want to add '" & varImpWord & "' to the exception list?", MB_YESNO + _
MB_ICONQUESTION, "ProperCase Exceptions Manager")
If intResult = MB_YES Then 'Add to exception list
varPropWord = InputBox("How would you like this word capitalized in the future?", , varImpWord)
'Get the replacement capitalization for this word in the future.
Set dbs = DBEngine(0)(0)
dbs.Execute "INSERT INTO " & mstrTableName & " (" & mstrFieldName1 & ", " & mstrFieldName2 & ") VALUES (" & "'" & varImpWord & "', '" & varPropWord & "');"
'Inserts the exception word into column 1 and the replacement word into column 2 of the exception table.
Else 'Don't add to exception list
varPropWord = varImpWord
End If
Else 'Correct - keep changes
End If
Else 'No change
End If
End Sub
Function BuildOutput(varBuildInput As Variant) As Variant 'Builds proper cased output string
Dim ii As Integer
For ii = 0 To Len(varBuildInput) 'Iterates through proper cased word list
If IsEmpty(varWordList(ii, 0)) Then 'Element does not contain a word
If IsEmpty(varWordList(ii, 1)) Then 'Element does not contain a word separator
Exit For 'All words and separators have been found. Output string is complete.
Else
varOutput = varOutput & varWordList(ii, 1) 'Concatenate word separator to output string
End If
Else
varOutput = varOutput & varWordList(ii, 0) 'Concatenate word to output string
End If
Next ii
BuildOutput = varOutput
End Function
Public Sub SetSepChars()
'Sets up an array of the accepted word separation characters. These may be modified by the developer as needed.
varSepChar = Array(" ", "-", ".", ",", ":", ";", "(", ")", "\", "/", "'", Chr(9), Chr(10), Chr(13))
' ^--Tab ^--{LF} ^--{CR}
intSepCharCnt = UBound(varSepChar) 'Counts the number of word separation characters in the array
End Sub
Function ParseWords(ByVal varParseInput As Variant) As Variant
Dim intStartPos As Integer, intEndPos As Integer, intArrayIndex As Integer, varTestChar As Variant, _
intTestPos As Integer, iii As Integer, varWord As Variant
If IsNull(varParseInput) Then
GoTo ExitParseWords
Else
SetSepChars
ReDim varWordList(Len(varParseInput), 2) As Variant
'Declare word list array with as many rows as there are characters in the varParseInput variable (to be conservative).
'Column 0 holds the final parsed words, column 1 holds the word separators, and column 2 holds an integer
'describing the corresponding word's position in the input string (1 for first word, 2 for second word, etc.).
intArrayIndex = 0 'Initialize variables
intStartPos = 1
intEndPos = 0
intWordCount = 0
For intTestPos = 1 To Len(varParseInput) 'Iterate through entire input string
varTestChar = Mid(varParseInput, intTestPos, 1) 'Get character to be tested
For iii = 0 To intSepCharCnt 'Iterate through word separator characters
If varTestChar <> varSepChar(iii) Then 'If something other than a word separator
If iii = intSepCharCnt Then 'All word separators have been compared with
varWord = varWord & varTestChar 'Concatenate with previous characters in the same word
If intTestPos = Len(varParseInput) Then 'Entire string has been tested
varWordList(intArrayIndex, 0) = varWord 'Insert word into proper element
intWordCount = intWordCount + 1 'Advance word counter
varWordList(intArrayIndex, 2) = intWordCount 'Enumerate word in array
intArrayIndex = intArrayIndex + 1 'Advance array index counter
End If
End If
Else 'If test character is a word separator
If Not IsNull(varWord) Or intTestPos = Len(varParseInput) Then
'Complete word has been parsed or end of string has been reached
varWordList(intArrayIndex, 0) = varWord 'Insert word into array
intWordCount = intWordCount + 1 'Advance word counter
varWordList(intArrayIndex, 2) = intWordCount 'Enumerate word in array
intArrayIndex = intArrayIndex + 1 'Advance index array counter
End If
varWordList(intArrayIndex, 1) = varTestChar 'Insert word separator into array
intArrayIndex = intArrayIndex + 1 'Advance array index counter
If Not IsNull(varWord) Then varWord = Null 'Re-initialize word variable
Exit For
End If
Next iii
Next intTestPos
End If
ParseWords = varWordList 'Set output to word list
'GoSub PrintWordList 'Test function by printing to Debug window - uncomment this line if you want to use
GoTo ExitParseWords
PrintWordList:
For intArrayIndex = 0 To UBound(varWordList) 'Iterate through word list array
If Not IsNull(varWordList(intArrayIndex, 0)) Then Debug.Print varWordList(intArrayIndex, 0)
'Print each element in array to the Debug window
Next intArrayIndex
Return
ExitParseWords:
End Function
Function GetWord(ByVal varGetInput As Variant, intIndex As Integer) As Variant
'This function will parse a string and return whatever word you like.
'Accepts: input field and index number starting with 1
'Returns: the nth word in the input string.
Dim iv As Integer
If IsNull(varGetInput) Then
GetWord = Null
GoTo ExitGetWord
Else
If intIndex < 1 Then 'Can't get a zero word!
MsgBox ("Please enter a number greater than or equal to 1.")
GoTo ExitGetWord
Else
CountWords (varGetInput)
If intIndex - 1 > intWordCount Then 'Index number given is greater than the number of words in the string.
MsgBox ("Please enter a number between 1 and " & intWordCount & ".")
Else
For iv = 0 To UBound(varWordList) 'Iterates through word list
If varWordList(iv, 2) = intIndex Then 'Column 2 (word count) equals the index number asked for.
GetWord = varWordList(iv, 0) 'Retrieves the correct word
Exit For
End If
Next iv
End If
End If
End If
ExitGetWord:
End Function
Function CountWords(ByVal varCountInput As Variant) As Integer
'Counts the words in a string.
ParseWords (varCountInput)
CountWords = intWordCount
End Function
Sub TestParseWords() 'Tests the ParseWords function
Dim strAString As String, v As Integer, intCnt As Integer
strAString = "Once, I thought I could write a module like this easily; now, I know better."
'Find out how many separated words are present
intCnt = CountWords(strAString)
Debug.Print intCnt
'Now call the other function to retrieve each one in turn
For v = 1 To intCnt
Debug.Print GetWord(strAString, v)
Next v
End Sub
Sub TestProperManager() 'Tests the ProperManager function
Debug.Print ProperManager("GREEN TREES have purPLE LEAVES, MCDONALD.", vbLowerCase)
End Sub
Sub TestProperCase() 'Tests the ProperCase function
Debug.Print ProperCase("GREEN TREES have purPLE LEAVES, mcdonald.", vbSentenceCase)
End Sub
