 |
|
 |
JLRodgers
Level: Moderator
Registered: 04-04-2002
Posts: 1616
|
Useful String Functions
Questions have been posted asking for stuff like this, I stuck a common answer here for everyone.
' As a note, the StrConv is also useful, and does some of the below (IE: StrConv->Propercase = Title Case beloew)
' Routines don't do array's as returns, but can do types
Public Type tReturnValues
StringArray() As String
End Type
' How string will be returned
Public Enum eReturnCase
rc_UPPER
rc_LOWER
rc_ANY
End Enum
Public Enum eCompare
EC_NOMATCH
EC_EXACTMATCH
EC_TEXTMATCH
End Enum
Option Explicit
'////////////////////////////////////
'// String compariason used by functions
Public Function StrCmp(ByVal String1 As String, ByVal String2 As String) As eCompare
If String1 = String2 Then
StrCmp = EC_EXACTMATCH
ElseIf UCase(String1) = UCase(String2) Then
StrCmp = EC_TEXTMATCH
Else
StrCmp = EC_NOMATCH
End If
End Function
'////////////////////////////////////
'// "A Long ROAD" -> "Long Road, A"
Public Function ProperTitleCase(ByVal Value As String) As String
ProperTitleCase = TitleCase(ArticalCase(Value))
End Function
'////////////////////////////////////
'// "A Long ROAD" -> "A Long Road"
Public Function TitleCase(ByVal Value As String) As String
Dim tmp() As String
Dim i As Integer
tmp = Split(Value, " ")
For i = LBound(tmp()) To UBound(tmp())
If Trim(tmp(i)) <> "" Then
TitleCase = TitleCase & SentenceCase(tmp(i)) & " "
End If
Next
TitleCase = Trim(TitleCase)
End Function
'////////////////////////////////////
'// "A Long Road" -> "A long road"
Public Function SentenceCase(ByVal Value As String) As String
Dim sTmp As String
If Trim(Value) <> "" Then
sTmp = UCase(Left(Value, 1)) & LCase(Right(Value, Len(Value) - 1))
SentenceCase = sTmp
Else
SentenceCase = Value
End If
End Function
'////////////////////////////////////
'// "A Long Road" -> "Long Road, A"
Public Function ArticalCase(ByVal Value As String) As String
Dim tmp As String
Dim Match As eCompare
If Trim(Value) <> "" And Len(Value) > 2 Then
tmp = Value
If Len(Value) > 4 Then
If StrCmp(Left(Value, 4), "the ") <> EC_NOMATCH Then
tmp = Trim(Right(Value, Len(Value) - 4)) & ", The"
End If
End If
If Len(Value) > 3 Then
If StrCmp(Left(Value, 3), "an ") <> EC_NOMATCH Then
tmp = Trim(Right(Value, Len(Value) - 3)) & ", An"
End If
End If
If StrCmp(Left(Value, 2), "a ") <> EC_NOMATCH Then
tmp = Trim(Right(Value, Len(Value) - 2)) & ", A"
End If
ArticalCase = tmp
Else
ArticalCase = Value
End If
End Function
'////////////////////////////////////
'// John Doe -> Doe, John
Public Function NameSwap(ByVal Value As String) As String
' Format name as LastName, Firstname Middle Name
Dim tmp() As String
Dim strFN As String
Dim strMN As String
Dim strLN As String
If Trim(Value) <> "" Then
tmp = Split(Value, " ")
strFN = tmp(LBound(tmp()))
strLN = tmp(UBound(tmp()))
If UBound(tmp()) = 2 Then
strMN = tmp(1)
Else
strMN = ""
End If
End If
NameSwap = Trim(TitleCase(strLN & ", " & strFN & " " & strMN))
End Function
'////////////////////////////////////
'// Make sure time is in 0:00 format
Public Function ProperTime(ByVal Value As String) As String
Dim tmp As String
tmp = Value
If InStr(1, Value, ":") = 0 Then
Select Case Value
Case "0", "00", "000", "0000"
tmp = "0:00"
Case Else
tmp = Value & ":00"
End Select
Else
If Left(Value, 1) = ":" Then
tmp = "0" & Value
ElseIf Right(Value, 1) = ":" Then
tmp = Value & "00"
ElseIf Len(Value) < 4 Then
If InStr(Len(Value) - 2, Value, ":") = 0 Then
tmp = "0" & Value
Else
tmp = Value & "0"
End If
ElseIf Len(Value) - InStr(1, Value, ":") < 2 Then
Do
DoEvents
tmp = Value & "0"
Loop Until Len(Value) - InStr(1, Value, ":") < 2
End If
End If
ProperTime = tmp
End Function
'////////////////////////////////////
'// Upper/Lower case checking
Public Function IsLower(ByVal Value As String) As Boolean
IsLower = Not IsUpper(Value)
End Function
Public Function IsUpper(ByVal Value As String) As Boolean
Dim i As Integer
Dim fLower As Boolean
i = 1
Do
Select Case Mid(Value, i, 1)
Case "a" To "z"
fLower = True
End Select
i = i + 1
Loop Until i > Len(Value) Or fLower
IsUpper = Not fLower
End Function
'////////////////////////////////////
'// Word count & string splits
Public Function WordCount(ByVal Value As String) As Long
WordCount = UBound(SplitString(Value, " ").StringArray) + 1
End Function
Public Function SplitString(ByVal Value As String, ByVal SplitChar As String) As tReturnValues
Dim i As Integer
Dim tmp() As String
tmp = Split(Value, SplitChar)
ReDim SplitString.StringArray(UBound(tmp()))
For i = LBound(tmp()) To UBound(tmp())
SplitString.StringArray(i) = tmp(i)
Next
End Function
'////////////////////////////////////
'// Remove double characters
Public Function RemoveDoubleChars(ByVal Value As String, Optional ByVal CaseSensitive As Boolean = True, Optional ByVal ReturnAs As eReturnCase = rc_UPPER)
Dim i As Integer
Dim CompareMethod As VbCompareMethod
If CaseSensitive Then
For i = Asc("a") To Asc("z")
If InStr(1, Value, Chr(i) & Chr(i)) > 0 Then
Do
DoEvents
Value = Replace(Value, Chr(i) & Chr(i), Chr(i), , , CompareMethod)
Value = Replace(Value, Chr(i - 32) & Chr(i - 32), Chr(i - 32), , , CompareMethod)
Loop Until InStr(1, Value, Chr(i) & Chr(i)) = 0 And InStr(1, Value, Chr(i - 32) & Chr(i - 32)) = 0
End If
Next
Else
Value = LCase(Value)
For i = Asc("a") To Asc("z")
If InStr(1, Value, Chr(i) & Chr(i)) > 0 Then
Do
DoEvents
Value = Replace(Value, Chr(i) & Chr(i), Chr(i), , , CompareMethod)
Loop Until InStr(1, Value, Chr(i) & Chr(i)) = 0
End If
Next
End If
If ReturnAs = rc_ANY Then
RemoveDoubleChars = Value
ElseIf ReturnAs = rc_LOWER Then
RemoveDoubleChars = LCase(Value)
Else
RemoveDoubleChars = UCase(Value)
End If
End Function
|
[Edited by JLRodgers on 11-03-2003 at 02:12 PM GMT]
[Edited by JLRodgers on 12-03-2003 at 02:27 PM GMT]
____________________________
Everywhere's Local (classifieds, job postings, & more for everycity in the world - user entered)
|
|
11-03-2003 at 08:11 PM |
|
|
stickleprojects
Level: Moderator
Registered: 09-09-2002
Posts: 891
|
Re: Useful String Functions
Hi JL,
Just a few variations on your routines:
'////////////////////////////////////
'// John Doe -> Doe, John
Public Function NameSwap(ByVal Value As String) As String
' Format name as LastName, Firstname Middle Name
dim space_pos as integer
If Trim(Value) <> "" Then
space_pos = instrrev (value," ")
if space_pos>0 then
nameswap = right$(value,space_pos+1) & ", " & trim(left(value,space_pos)
else
nameswap = value
end if
end if
End Function
public function ProperTime (byval oldtime as string) as string
' Remove ":"
oldtime = replace(oldtime,":","")
' Check all numeric
if not isnumeric(oldtime) then
msgbox "Rubbish time!"
exit function
end if
' format the resultant number
propertime = format(val(oldtime),"00:00")
end function
Thoughts?
K
____________________________
Build it better, faster, quicker, easier.. then fix it (non-offical MS mission statement)
|
|
18-05-2005 at 03:26 PM |
|
|
|
|
 |
|
