VBA Snippets
Char_Capital
Ensures that a single character is in uppercase.Public Function Str_CharCapital( _
ByVal sChar As String) _
As String
Const sPROCNAME As String = "Str_CharCapital"
On Error GoTo ErrorHandler
If (Asc(sChar) >= 97) And (Asc(sChar) <= 122) Then
Str_CharCapital = Chr(Asc(sChar) - 32)
Else
Str_CharCapital = sChar
End If
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"make sure the character """ & sChar & """ is in uppercase")
End Function
Char_FindPositionofNext
Returns the character position of a particular character in a string.Public Function Str_CharFindPositionofNext( _
ByVal sText As String, _
ByVal sChar As String, _
Optional ByVal iOccuranceNo As Integer = 1) _
As Integer
Const sPROCNAME As String = "Str_CharFindPositionofNext"
Dim iposition As Integer
Dim soriginal As String
On Error GoTo ErrorHandler
iposition = 0
soriginal = sText
Do While (iOccuranceNo > 0) And (iposition <> -1)
iposition = InStr(1, sText, sChar)
If iposition = 0 Then
Str_CharFindPositionofNext = -1
End If
If iposition = 0 Then
Exit Function
End If
sText = Right(sText, Len(sText) - iposition)
iOccuranceNo = iOccuranceNo - 1
Loop
Str_CharFindPositionofNext = Len(soriginal) - Len(sText)
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"return the characater position of the " & iOccuranceNo & _
" occurrence of the character """ & sChar & """")
End Function
Char_IsIt
Determines if a character is a valid letter, either lowercase or uppercase. Returns True or False.Public Function Str_CharIsIt( _
ByVal sChar As String) _
As Boolean
Const sPROCNAME As String = "Str_CharIsIt"
On Error GoTo ErrorHandler
If Len(sChar) = 0 Then
Str_CharIsIt = False
End If
If Len(sChar) = 0 Then
Exit Function
End If
If ((Asc(sChar) >= 65 And Asc(sChar) <= 90)) Or _
((Asc(sChar) >= 97 And Asc(sChar) <= 122)) Then
Str_CharIsIt = True
Else
Str_CharIsIt = False
End If
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"determine if the character """ & sChar & """" & _
"is a valid character")
End Function
Char_IsNumber
Determines if a character is a valid number, either a single digit or multiple digits. Returns True or False.Public Function Str_CharIsNumber( _
ByVal sChar As String) _
As Boolean
Const sPROCNAME As String = "Str_CharIsNumber"
On Error GoTo ErrorHandler
If (IsNumeric(sChar) = True) Then
Str_CharIsNumber = True
End If
If (IsNumeric(sChar) = False) Then
Str_CharIsNumber = False
End If
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"determine if the character """ & sChar & """" & _
"is a valid number")
End Function
Char_No
Public Function Str_CharNo( _
ByVal sText As String, _
ByVal iCharNo As Integer) _
As String
Const sPROCNAME As String = "Str_CharNo"
Dim shalfway As String
On Error GoTo ErrorHandler
If iCharNo > 0 Then
shalfway = Left(sText, iCharNo) 'remove the LHS
Str_CharNo = Right(shalfway, 1) 'remove the RHS
Else
Str_CharNo = ""
End If
If gbDEBUG_ERRMSG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"return character " & iCharNo & " from the string '" & sText & "'.")
End Function
Char_NoOf
Returns the total number of occurrences of a particular character in a string.Public Function Str_CharNoOf( _
ByVal sText As String, _
ByVal sChar As String) As Integer
Const sPROCNAME As String = "Str_CharNoOf"
Dim icountCR As Integer
Dim icharCR As Integer
On Error GoTo ErrorHandler
icountCR = 0
Do While InStr(1, sText, sChar) > 0
icharCR = InStr(1, sText, sChar)
icountCR -icountCR + 1
sText = Right(sText, Len(sText) - icharCR - 1)
Loop
Str_CharNoOf = icountCR
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"return the total number of times the character '" & sChar & "'" & _
"appears in the text" & vbCrLf & "'" & sText & "'")
End Function
Char_Replace
Finds and replaces a character with another character in a string, returning the modified string.Public Function Str_CharReplace( _
ByVal sText As String, _
ByVal sFindChar As String, _
ByVal sReplaceChar As String) _
As String
Const sPROCNAME As String = "Str_CharReplace"
Dim sfinaltext As String
Dim icount As Integer
On Error GoTo ErrorHandler
For icount = 1 To Len(sText)
If Mid(sText, icount, 1) = sFindChar Then
sfinaltext = sfinaltext & sReplaceChar
Else
sfinaltext = sfinaltext & Mid(sText, icount, 1)
End If
Next icount
Str_CharReplace = sfinaltext
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description,, _
"find the char """ & sFindChar & """ and replace it with the characater " & _
"""" & sReplaceChar & """ in the string" & vbCrLf & """" & sText & """")
End Function
Char_SizeArialNarrow8Bold
Returns the width of an individual character in the font style Arial Narrow, 8, Bold.Public Function Str_CharSizeArialNarrow8Bold( _
ByVal sChar As String, _
Optional ByVal sngTextBoxWidth As Single = 0) _
As Single
Const sPROCNAME As String = "Str_CharSizeArialNarrow8Bold"
Dim icharwidth As Integer
On Error GoTo ErrorHandler
Select Case sChar
End Select
' Char_ArialNarrow8Bold = ??? / icharwidth
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"return the width of the char """ & sChar & """ in Arial Narrow, 8, Bold")
End Function
Char_SizeArialNarrow8Reg
Returns the width of an individual character in the font style Arial Narrow, 8, Regular.Public Function Str_CharSizeArialNarrow8Reg( _
ByVal sChar As String, _
Optional ByVal sngTextBoxWidth As Single = 0) _
As Single
Const sPROCNAME As String = "Str_CharSizeArialNarrow8Reg"
Dim icharwidth As Integer
On Error GoTo ErrorHandler
Select Case sChar
End Select
' Char_ArialNarrow8Reg = ??? / icharwidth
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"return the width of the char """ & sChar & """ in Arial Narrow, 8, Reg")
End Function
Char_SizeArialNarrow9Bold
Returns the width of an individual character in the font style Arial Narrow, 9, Bold.Public Function Str_CharSizeArialNarrow9Bold( _
ByVal sChar As String, _
Optional ByVal sngTextBoxWidth As Single = 0) _
As Single
Const sPROCNAME As String = "Str_CharSizeArialNarrow9Bold"
Dim icharwidth As Integer
On Error GoTo ErrorHandler
Select Case sChar
End Select
' Char_ArialNarrow9Bold = ??? / icharwidth
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"return the width of the char """ & sChar & """ in Arial Narrow, 9, Bold")
End Function
Char_SizeArialNarrow9Reg
Returns the width of an individual character in the font style Arial Narrow, 9 Regular.Public Function Str_CharSizeArialNarrow9Reg( _
ByVal sChar As String, _
Optional ByVal sngTextBoxWidth As Single = 0) _
As Single
Const sPROCNAME As String = "Str_CharSizeArialNarrow9Reg"
Dim icharwidth As Integer
On Error GoTo ErrorHandler
Select Case sChar
Case "a", "b", "d", "e", "g", "h", "n", "o", "p", "q", "u": icharwidth = 170 '191
Case "c", "k", "s", "v", "x", "y", "z": icharwidth = 195 '212
Case "f", "t": icharwidth = 360 '382
Case "i", "j", "l": icharwidth = 450 '478
Case "m": icharwidth = 128
Case "r": icharwidth = 315 ' 319
Case "w": icharwidth = 147
Case "A", "B", "E", "K", "P", "S", "V", "X", "Y": icharwidth = 140 '159
Case "C", "D", "H", "N", "R", "U": icharwidth = 135 '147
Case "F", "T", "Z": icharwidth = 174
Case "G", "O", "Q": icharwidth = 137
Case "I": icharwidth = 382
Case "J": icharwidth = 212
Case "L": icharwidth = 191
Case "M": icharwidth = 128
Case "W": icharwidth = 113
Case "Z": icharwidth = 174
Case "1", "2", "3", "4", "5", "6", "7", "8", "9", "0": icharwidth = 170 '191
Case "%": icharwidth = 120
Case "&": icharwidth = 159
Case ".": icharwidth = 368 '382
Case """": icharwidth = 312
Case ",": icharwidth = 382
Case "\": icharwidth = 319
Case "/": icharwidth = 319
Case "-": icharwidth = 320
Case "+": icharwidth = 182
Case " ": icharwidth = 350 '382
Case "†": icharwidth = 191
Case Else: icharwidth = 140
End Select
Char_ArialNarrow9Reg = 781 / icharwidth '761
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"return the width of the char """ & sChar & """ in Arial Narrow, 9, Reg")
End Function
Char_SizeSabon10Bold
Returns the width of an individual character in the font style Sabon, 10, Bold.Public Function Char_SizeSabon10Bold( _
ByVal sChar As String, _
Optional ByVal sngTextBoxWidth As Single = 0) _
As Single
Const sPROCNAME As String = "Char_SizeSabon10Bold"
Dim icharwidth As Integer
On Error GoTo ErrorHandler
Select Case sChar
Case "a", "b", "d", "e", "g", "o", "p", "q", "v", "x", "y": icharwidth = 54
Case "c", "r", "s", "z": icharwidth = 64
Case "f", "t": icharwidth = 76
Case "h", "n", "u": icharwidth = 48
Case "i", "j", "l", " ": icharwidth = 96
Case "k", "w": icharwidth = 42
Case "m": icharwidth = 32
Case "A": icharwidth = 28
Case "B", "L", "N", "U": icharwidth = 42
Case "C", "D", "H", "K", "R", "V", "X", "Y": icharwidth = 38
Case "E", "F", "G", "P", "S", "T", "Z": icharwidth = 48
Case "I": icharwidth = 64
Case "J": icharwidth = 54
Case "M": icharwidth = 32
Case "O", "Q": icharwidth = 34
Case "W": icharwidth = 27
Case "1", "2", "3", "4", "5", "6", "7", "8", "9", "0": icharwidth = 54
Case "%": icharwidth = 25
Case "&": icharwidth = 32
Case "*", "$": icharwidth = 54
Case "-", "(", ")", ":": icharwidth = 76
Case """": icharwidth = 48
Case ",", ".": icharwidth = 86
Case Else: icharwidth = 65
End Select
Char_Sabon10Bold = 288 / icharwidth
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"return the width of the char """ & sChar & """ in Sabon, 10, Bold")
End Function
Char_SizeSabon10Reg
Returns the width of an individual character in the font style Sabon, 10, Regular.Public Function Str_CharSizeSabon10Reg( _
ByVal sChar As String, _
Optional ByVal sngTextBoxWidth As Single = 0) _
As Single
Const sPROCNAME As String = "Str_CharSizeSabon10Reg"
Dim icharwidth As Integer
On Error GoTo ErrorHandler
Select Case sChar
Case "a", "e", "s", "z": icharwidth = 64
Case "b", "c", "d", "g", "h", "k", "n", "o", "p", "q", "u", "v", _
"x", "y": icharwidth = 54
Case "f", "r": icharwidth = 76
Case "i", "j", "l": icharwidth = 128
Case "m": icharwidth = 38
Case "t", " ": icharwidth = 96
Case "w": icharwidth = 36
Case "A", "C", "H", "K", "R", "T", "U", "V", "Y": icharwidth = 42
Case "B", "E", "F", "G", "L", "P", "S", "Z": icharwidth = 48
Case "D", "N", "O", "Q", "X": icharwidth = 38
Case "I": icharwidth = 76
Case "J": icharwidth = 64
Case "M", "%": icharwidth = 32
Case "W": icharwidth = 29
Case "1", "2", "3", "4", "5", "6", "7", "8", "9", "0": icharwidth = 54
Case "&": icharwidth = 34
Case "*", "$": icharwidth = 54
Case "-", "(", ")", """": icharwidth = 76
Case ",", ".": icharwidth = 86
Case ":": icharwidth = 118
Case Else: icharwidth = 65
End Select
Char_Sabon10Reg = 288 / icharwidth
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"return the width of the char """ & sChar & """ in Sabon, 10, Reg")
End Function
Char_SizeTahoma8Reg
Returns the width of an individual character in the font style Tahamo, 9, Regular.Public Function Str_CharSizeTahoma8Reg( _
ByVal sChar As String, _
Optional ByVal sngTextBoxWidth As Single = 0) _
As Single
Const sPROCNAME As String = "Str_CharSizeTahoma8Reg"
Dim icharwidth As Integer
On Error GoTo ErrorHandler
Select Case sChar
Case "a": icharwidth = 118
Case "b", "d", "g", "p", "q", "h", "n", "u", "E", "P", "S", "Z": icharwidth = 113
Case "c": icharwidth = 134
Case "e": icharwidth = 117
Case "f": icharwidth = 194
Case "i", "l": icharwidth = 269
Case "j": icharwidth = 219
Case "k", "v", "x", "y", "L": icharwidth = 124
Case "m": icharwidth = 74
Case "o": icharwidth = 114
Case "r": icharwidth = 171
Case "s", "z": icharwidth = 138
Case "t": icharwidth = 184
Case "w": icharwidth = 80
Case "A", "C", "V": icharwidth = 103
Case "B", "K", "T", "X", "Y": icharwidth = 105
Case "D", "G", "H", "N", "U": icharwidth = 92
Case "F": icharwidth = 118
Case "I": icharwidth = 165
Case "J": icharwidth = 148
Case "M": icharwidth = 80
Case "O", "Q": icharwidth = 87
Case "R": icharwidth = 100
Case "W": icharwidth = 100 'check this \\
Case " ": icharwidth = 198
Case Else: icharwidth = 140
End Select
Char_Tahoma8Reg = 493 / icharwidth
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"return the width of the char """ & sChar & """ in Tahamo, 8, Reg")
End Function
Char_SizeUniversLight8Reg
Returns the width of an individual character in the font style UniversLight, 8, Regular.Public Function Str_CharSizeUniversLight8Reg( _
ByVal sChar As String, _
Optional ByVal sngTextBoxWidth As Single = 0) _
As Single
Const sPROCNAME As String = "Str_CharSizeUniversLight8Reg"
Dim inoofchars As Integer
On Error GoTo ErrorHandler
inoofchars = 65 'incase not recognised, use width 65
Select Case sChar
Case "a", "c", "k", "s", "x", "y": inoofchars = 180 '196
Case "b", "d", "e", "g", "h", "n", "o", "p", "q", "u", "v": inoofchars = 160 '176
Case "f", "r": inoofchars = 294
Case "i", "j", "l": inoofchars = 440
Case "m": inoofchars = 110
Case "t", inoofchars = 293
Case "w": inoofchars = 118
Case "z": inoofchars = 220
Case "A", "B", "C", "R": inoofchars = 135 '147
Case "D", "G", "H", "N", "U": inoofchars = 125 '136
Case "E", "K", "P", "S", "V", "X", "Y": inoofchars = 150 '160
Case "F", "L", "T", "Z": inoofchars = 176
Case "I": inoofchars = 352
Case "J": inoofchars = 196
Case "M", inoofchars = 104
Case "O", "Q": inoofchars = 126
Case "W": inoofchars = 98
Case "1", "2", "3", "4", "5", "6", "7", "8", "9", "0": inoofchars = 160 '176
Case "%": inoofchars = 98
Case "&": inoofchars = 136
Case "(", ")", "\", "/", ".", ",", """": inoofchars = 310 '352
Case "+": inoofchars = 149
Case "-": inoofchars = 353
Case ".": inoofchars = 352
Case " ": inoofchars = 200
Case Else: inoofchars = 100
End Select
Char_UniversLight8Reg = 785 / inoofchars
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"return the width of the char """ & sChar & """ in UniversLight, 8, Reg")
End Function
Chars_1013
Determines if a string contains either the character (10 = line feed) or the character (13 = carriage return) What is character (7) ????.Public Function Str_Chars1013( _
ByVal sText As String) _
As Boolean
Const sPROCNAME As String = "Str_Chars1013"
On Error GoTo ErrorHandler
Do While sText <> ""
'make a full / proper list of characaters 1 to 20 !!!!!!!!!!!!!!!!!!
If (Not Left(sText, 1) = Chr(13)) _
And (Not Left(sText, 1) = Chr(10)) Then 'check the leftmost chars
Str_Chars1013 = False
Exit Function
End If
sText = Right(sText, Len(sText) - 1) 'remove the leftmost char
Loop
Str_Chars1013 = True
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"determine if the string """ & sText & """ consists of just Chars (10) & (13)")
End Function
Chars_1013HasAny
Determines if a string contains either the character (10) or the character (7). Returns True or False.Public Function Str_Chars1013HasAny( _
ByVal sText As String) _
As Boolean
Const sPROCNAME As String = "Str_Chars1013HasAny"
Dim scurrenttext As String
On Error GoTo ErrorHandler
Str_Chars1013HasAny = False
If sText = Chr(13) & Chr(7) Then
Exit Function
End If
If (Right(sText, 2) = Chr(13) & Chr(7)) Then
sText = Left(sText, Len(sText) - 2)
End If
Do While sText <> ""
If (Right(sText, 1) = Chr(13)) Or (Right(sText, 1) = Chr(7)) Then
Str_Chars1013HasAny = True
Exit Function
End If
sText = Left(sText, Len(sText) - 1)
Loop
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"determine if the string """ & sText & """ has any Chars (13) or (10) in it")
End Function
Chars_1013Remove
Removes all the occurences of the characters (10) or (7), returning the modified string.Public Function Str_Chars1013Remove( _
ByVal sText As String) _
As String
Const sPROCNAME As String = "Str_Chars1013Remove"
Dim sfinaltext As String
Dim scurrenttext As String
On Error GoTo ErrorHandler
Do While Len(sText) > 0
If (Not Right(sText, 1) = Chr(13)) And _
(Not Right(sText, 1) = Chr(7)) Then _
sfinaltext = Right(sText, 1) & sfinaltext
sText = Left(sText, Len(sText) - 1)
Loop
Str_Chars1013Remove = sfinaltext
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"remove all the occurences of the chars (10) or (7) from the string " & _
vbCrLf & """" & sText & """")
End Function
Chars_Delete
Removes all the characters that are provided as an array from a string.Public Function Str_CharsDelete( _
ByVal sText As String, _
ParamArray vRemoveChars() As Variant) _
As String
Const sPROCNAME As String = "Str_CharsDelete"
Dim iposition As Integer
Dim stexttemp As String
Dim stextleft As String
Dim stextfinal As String
Dim vchar As Variant
On Error GoTo ErrorHandler
stexttemp = sText
For Each vchar In vRemoveChars()
stextfinal = ""
Do Until (stexttemp = "")
If (Left(stexttemp, 1) <> vchar) Then
stextfinal = stextfinal & Left(stexttemp, 1)
End If
stexttemp = Right(stexttemp, Len(stexttemp) - 1)
Loop
stexttemp = stextfinal
Next vchar
Str_CharsRemove = stextfinal
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"remove the chars """ & ">>>>>>" & """ from the string" & vbCrLf & sText)
End Function
Chars_FindPositionofNext
Returns the position of the first occurrence of any of the characters in an array from a string. If there are no occurrences then -1 is returned.Public Function Chars_FindPositionofNext( _
ByVal sText As String, _
ParamArray vChars() As Variant) _
As Integer
Const sPROCNAME As String = "Chars_FindPositionofNext"
Dim iposition As Integer
Dim stextleft As String
Dim vchar As Variant
On Error GoTo ErrorHandler
iposition = 1
stextleft = sText
Do Until Len(stextleft) = 0
For Each vchar In vChars()
If Left(stextleft, 1) = vchar Then
Str_CharFindPositionofNext = iposition
Exit Function
End If
Next
iposition = iposition + 1
stextleft = Right(stextleft, Len(stextleft) - 1)
Loop
Chars_FindPositionofNext = -1
If gbDEBUG_ERRMSG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"return the position of the first occurrence of any of the given characters " & _
"in the string '" & sText & "'")
End Function
Chars_Replace
Replaces all the characters in an array with a different character in a text string.Public Function Chars_Replace( _
ByVal sText As String, _
ByVal sWithChar As String, _
ParamArray vReplaceChars() As Variant) _
As String
Const sPROCNAME As String = "Chars_Replace"
Dim stextleft As String
Dim stextreturn As String
Dim iposition As Integer
Dim vchar As Variant
On Error GoTo ErrorHandler
stextleft = sText
Do Until Len(stextleft) = 0
For Each vchar In vReplaceChars()
If (Left(stextleft, 1) = vchar) Then
stextreturn = stextreturn & sWithChar
Else
stextreturn = stextreturn & Left(stextleft, 1)
End If
Next vchar
iposition = iposition + 1
stextleft = Right(stextleft, Len(stextleft) - 1)
Loop
Chars_Replace = stextreturn
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"replace all the characters """ & vReplaceChars & _
" with the character """ & sWithChar & """ in the string """ & sText & """")
End Function
Chars_ReturnASCII
Public Function Str_CharsReturnASCII( _
ByVal sCharacters As String) _
As String
Const sPROCNAME As String = "Str_CharsReturnASCII"
Dim itotal As Integer
Dim icharcount As Integer
Dim sreturncode As String
On Error GoTo ErrorHandler
sreturncode = ""
itotal = Len(sCharacters)
For icharcount = 1 To itotal
sreturncode = sreturncode & Asc(Left(sCharacters, 1))
sCharacters = Right(sCharacters, Len(sCharacters) - 1)
Next icharcount
CharsReturnASCII = sreturncode
Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Function
Str_AddUnique
Determine if a string already exists in a string concatenation and adds an entry if it doesn't already exist.Public Function Str_AddUnique( _
ByVal sText As String, _
ByVal sTextConcat As String, _
Optional sSeperateChar As String = ";") As String
Const sPROCNAME As String = "Str_AddUnique"
Dim scurrenttext As String
Dim stextleft As String
On Error GoTo ErrorHandler
stextleft = sTextConcat
scurrenttext = Str_NextGet(stextleft)
If (scurrenttext = "") Then
Str_AddUnique = sText & sSeperateChar
Exit Function
End If
Do While (scurrenttext <> "")
If scurrenttext = sText Then
Str_AddUnique = sTextConcat
Exit Function
Else
stextleft = Str_NextRemove(stextleft)
scurrenttext = Str_NextGet(stextleft)
End If
Loop
Str_AddUnique = sTextConcat & sText & sSeperateChar
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"determine if the string """ & sText & """ exists already " & _
"in the concatenation" & vbCrLf & sTextConcat & vbCrLf & "and add it if not")
End Function
Str_CapitalFirstLetter
Returns a string ensuring that the first character is a capital letter and the remaining characters are all lowercase.Public Function Str_CapitalFirstLetter( _
ByVal sText As String) As String
Const sPROCNAME As String = "Str_CapitalFirstLetter"
Dim sfinaltext As String
Dim snextchar As String
Dim icount As Integer
Dim bexceptionchar As Boolean
On Error GoTo ErrorHandler
bexceptionchar = True
' find the first char thats a letter and make it a capital
For icount = 1 To Len(sText)
' replace this will a LEFT and RIGHT
snextchar = Str_LeftOf(sText, Len(sText) - 1)
' for everything else leave unless it is a capital letter
If (bexceptionchar = False) And _
(Asc(snextchar) >= 65) And (Asc(snextchar) <= 90) Then
sfinaltext = sfinaltext & Chr(Asc(snextchar) + 32)
Else
sfinaltext = sfinaltext & snextchar
End If
bexceptionchar = False
' If (snextchar = " ") Or _
' (snextchar = "(") Or _
' (snextchar = "-") Or _
' (snextchar = ".") Or _
' (snextchar = """") Then bexceptionchar = True
sText = Right(sText, Len(sText) - 1)
Next icount
Str_CapitalFirstLetter = sfinaltext
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"return the string """ & sText & """ ensuring that the first letter is a capital")
End Function
Str_Capitals
Returns a string ensuring that all the characters are in uppercase.Public Function Str_Capitals( _
ByVal sText As String) As String
Const sPROCNAME As String = "Str_Capitals"
Dim sfinaltext As String
Dim snextchar As String
Dim icount As Integer
On Error GoTo ErrorHandler
For icount = 1 To Len(sText)
' replace this will a LEFT and RIGHT
snextchar = Str_LeftOf(sText, Len(sText) - 1)
If (Asc(snextchar) >= 65) And (Asc(snextchar) <= 90) Then
sfinaltext = sfinaltext & Chr(Asc(snextchar) + 32)
Else
sfinaltext = sfinaltext & snextchar
End If
sText = Right(sText, Len(sText) - 1)
Next icount
Str_Capitals = sfinaltext
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"return the string """ & sText & """" & _
"ensuring that the first letter is a capital")
End Function
Str_CharsNoOf
Public Function Str_CharsNoOf(ByVal sText As String, _
ByVal sSeparateChar As String) As Integer
Dim icount As Integer
Dim ichar As Integer
On Error GoTo ErrorHandler
icount = 0
Do While (InStr(1, sText, sSeparateChar) > 0)
ichar = InStr(1, sText, sSeparateChar)
icount = icount + 1
sText = Right(sText, Len(sText) - ichar - 1)
Loop
Str_CharsNoOf = icount
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_HandlemsMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"find the number of occurrences of the character '" & sSeparateChar & "'")
End Function
Str_ConCatAfter
Public Function Str_ConCatAfter( _
ByVal sText As String, _
ByVal sFindText As String, _
Optional ByVal bInformUser As Boolean = True, _
Optional ByVal sSeperateChar As String = ";") As String
Const sPROCNAME As String = "Str_ConCatAfter"
Dim iseperatepos As Integer
Dim serrortext As String
Dim scurrent As String
Dim snext As String
Dim bfound As Boolean
On Error GoTo ErrorHandler
serrortext = sText
bfound = False
Do While Len(sText) > 0
iseperatepos = InStr(1, sText, sSeperateChar)
If InStr(1, sText, sSeperateChar) > 0 Then
snext = Left(sText, iseperatepos - 1)
sText = Right(sText, Len(sText) - iseperatepos)
Else
snext = sText
sText = ""
End If
If scurrent = sFindText Then
bfound = True
Str_ConCatAfter = snext
Exit Do
End If
scurrent = snext
Loop
If snext = sFindText Then
bfound = True
Str_ConCatAfter = ""
End If
If bfound = False And bInformUser = True Then GoTo AnError
If gbDEBUG = False Then Exit Function
ErrorHandler:
Str_ConCatAfter = ""
Call Error_Handle(msMODULENAME, sPROCNAME, _
"find the string """ & sFindText & """ in the following:" & _
vbCrLf & """" & serrortext & """")
End Function
Str_ConCatBefore
Public Function Str_ConCatBefore( _
ByVal sText As String, _
ByVal sFindText As String, _
Optional bInformUser As Boolean = True, _
Optional sSeperateChar As String = ";") As String
Const sPROCNAME As String = "Str_ConCatBefore"
Dim iseperatepos As Integer
Dim serrortext As String
Dim scurrent As String
Dim sprevious As String
Dim bfound As Boolean
On Error GoTo ErrorHandler
serrortext = sText
bfound = False
Do While Len(sText) > 0
iseperatepos = InStr(1, sText, sSeperateChar)
If InStr(1, sText, sSeperateChar) > 0 Then
scurrent = Left(sText, iseperatepos - 1)
sText = Right(sText, Len(sText) - iseperatepos)
Else
scurrent = sText
sText = ""
End If
If scurrent = sFindText Then
bfound = True
Str_ConCatBefore = sprevious
Exit Do
End If
sprevious = scurrent
Loop
If bfound = False And bInformUser = True Then GoTo AnError
If gbDEBUG = False Then Exit Function
ErrorHandler:
Str_ConCatBefore = ""
Call Error_Handle(msMODULENAME, sPROCNAME, _
"find the string '" & sFindText & "' in the following:" & _
vbCrLf & "'" & serrortext & "'")
End Function
Str_ConCatExists
Determines if a text string already exists in a concatenation of text strings. Returns True of False.Public Function Str_ConCatExists( _
ByVal sText As String, _
ByVal sTextConcat As String, _
Optional sSeperateChar As String = ";", _
Optional bIgnoreBrackets As Boolean = False) As Boolean
Const sPROCNAME As String = "Str_ConCatExists"
Dim scurrenttext As String
Dim iopenbracketpos As Integer
Dim larraycount As Long
On Error GoTo ErrorHandler
scurrenttext = Str_NextGet(sTextConcat)
Do While scurrenttext <> ""
If bIgnoreBrackets = True Then
iopenbracketpos = InStr(1, scurrenttext, "(")
scurrenttext = Left(scurrenttext, iopenbracketpos - 1)
End If
If scurrenttext = sText Then
Str_ExistsStrConCat = True
Exit Function
Else
sTextConcat = Str_NextRemove(sTextConcat)
scurrenttext = Str_NextGet(sTextConcat)
End If
Loop
Str_ConCatExists = False
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, _
"determine if the string """ & sText & """ exists already " & _
"in the concatenation" & vbCrLf & """" & sTextConcat & """")
End Function
Str_ConCatFrom
Public Function Str_ConCatFrom( _
ByVal sAddress As String, _
ByVal sCharInsert As String, _
Optional sCharSeperate As String = "#") As String
Const sPROCNAME As String = "Str_ConCatFrom"
Dim icharCR As Integer
Dim snewaddress As String
On Error GoTo ErrorHandler
snewaddress = ""
Do While InStr(1, sAddress, sCharSeperate) > 0
icharCR = InStr(1, sAddress, sCharSeperate)
snewaddress = snewaddress & Left(sAddress, icharCR - 1) & sCharInsert
sAddress = Right(sAddress, Len(sAddress) - icharCR + 1 - Len(sCharSeperate))
Loop
snewaddress = snewaddress & sAddress
Str_ConCatFrom = snewaddress
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle("Str_ConCatFrom", msMODULENAME, 1, _
"expand the address from a single line")
End Function
Str_ConCatRemove
Public Function Str_ConCatRemove( _
ByVal sText As String, _
ByVal sRemoveText As String, _
Optional sSeparateChar As String = ";") As String
Const sPROCNAME As String = "Str_ConCatRemove"
Dim iseparatepos As Integer
Dim serrortext As String
Dim scurrent As String
Dim snewtext As String
On Error GoTo ErrorHandler
serrortext = sText
Do While Len(sText) > 0
iseparatepos = InStr(1, sText, sSeparateChar)
If InStr(1, sText, sSeparateChar) > 0 Then
scurrent = Left(sText, iseparatepos - 1)
sText = Right(sText, Len(sText) - iseparatepos)
Else
scurrent = sText
sText = ""
End If
If InStr(1, sRemoveText, scurrent) = 0 Then 'ie not in the list then add
snewtext = snewtext & scurrent & sSeparateChar
End If
Loop
Str_ConCatRemove = Left(snewtext, Len(snewtext) - 1)
If gbDEBUG = False Then Exit Function
ErrorHandler:
Str_ConCatRemove = serrortext
Call Error_Handle(msMODULENAME, sPROCNAME, _
"remove the string entries '" & sRemoveText & "'" & vbCrLf & _
"from the following: '" & serrortext & "' string")
End Function
Str_ConCatReverse
Reverses the entries in a string concatenation.Public Function Str_ConCatReverse( _
ByVal sText As String, _
Optional ByVal sSeperateChar As String = ";") As String
Const sPROCNAME As String = "Str_ConCatReverse"
Dim stemptext As String
Dim iseperatepos As String
On Error GoTo ErrorHandler
stemptext = ""
Do While sText <> ""
iseperatepos = InStr(sText, sSeperateChar)
If InStr(sText, sSeperateChar) > 0 Then
stemptext = sSeperateChar & Left(sText, iseperatepos - 1) & stemptext
sText = Right(sText, Len(sText) - iseperatepos)
Else
stemptext = sText & stemptext
sText = ""
End If
Loop
Str_ConCatReverse = stemptext
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, _
"return the reverse of the string concatenation " & vbCrLf & sText)
End Function
Str_CountOccurrences
Returns the number of occurrences of a string within another string.Public Function Str_CountOccurrences( _
ByVal sText As String, _
ByVal sFindText As String, _
Optional lCompareMethod As Long) As Long
Const sPROCNAME As String = "Str_CountOccurrences"
Dim lPos As Long
Dim ltemp As Long
Dim lcount As Long
On Error GoTo ErrorHandler
lPos = 1
Do
lPos = InStr(lPos, sText, sFindText, lCompareMethod)
ltemp = lPos
If (lPos > 0) Then
lcount = lcount + 1
lPos = lPos + Len(sFindText)
End If
Loop Until (lPos = 0)
Str_CountOccurrences = lcount
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Function
Str_ExistsArray
Determines if a text string is equal to any of the possible entries in an array. Returns True or False.Public Function Str_ExistsArray( _
ByVal sText As String, _
ParamArray vWords() As Variant) As Boolean
Const sPROCNAME As String = "Str_ExistsArray"
Dim vword As Variant
Dim scombine As String
On Error GoTo ErrorHandler
Str_ExistsArray = False
For Each vword In vWords
If sText = CStr(vword) Then
Str_ExistsArray = True
Exit Function
End If
Next vword
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"determine if the text """ & sText & """" & _
" equals one of the entries """ & ">>>>>>>")
End Function
Str_FindPositionOfOddSeq
Returns the position ?? TEST !!!.Public Function Str_FindPositionOfOddSeq( _
ByVal sText As String, _
ByVal sCharLast As String, _
ByVal sCharSeq As String, _
ByVal iCharStart As Integer) As Integer
Const sPROCNAME As String = "Str_FindPositionOfOddSeq"
Dim icharpos As Integer
Dim icharsback As Integer
Dim bOddorEven As Boolean
On Error GoTo ErrorHandler
icharpos = iCharStart
Do While True
If Mid(sText, icharpos, 1) = sCharLast And _
Mid(sText, icharpos - 1, 1) = sCharSeq Then
bOddorEven = True
icharsback = 2
Do While Mid(sText, icharpos - icharsback, 1) = sCharSeq
If (bOddorEven = True) Then
bOddorEven = False
Else
bOddorEven = True
End If
icharsback = icharsback + 1
Loop
If (bOddorEven = True) Then
Str_FindPositionOfOddSeq = icharpos
End If
If (bOddorEven = True) Then
Exit Function
End If
End If
icharpos = icharpos + 1
Loop
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"")
End Function
Str_FullStopAdd
Returns a string ensuring that there is a full stop or char(?) at the end of it.Public Function Str_FullStopAdd( _
ByVal sText As String) As String
Const sPROCNAME As String = "Str_FullStopAdd"
On Error GoTo ErrorHandler
If (Right(sText, 1) = ".") Then
Str_FullStopAdd = sText
End If
If (Right(sText, 1) <> ".") Then
Str_FullStopAdd = sText & "."
End If
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"add the full stop characater to the end of the text" & vbCrLf & _
"""" & sText & """")
End Function
Str_InBrackets
Returns the string in brackets that has been appended to a string ( ie FileName(2) ).Public Function Str_InBrackets( _
ByVal sText As String) As String
Const sPROCNAME As String = "Str_InBrackets"
Dim iopenbracketpos As Integer
On Error GoTo ErrorHandler
iopenbracketpos = InStr(1, sText, "(")
Str_InBrackets = Mid(sText, iopenbracketpos + 1, Len(sText) - iopenbracketpos - 1)
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"return the string contained within the brackets from the string" & _
vbCrLf & """" & sText & """")
End Function
Str_InText
Determines if a string exists within another string as in a substring. Basically the Instr() function. Returns True or False.Public Function Str_InText( _
ByVal sText As String, _
ByVal sFindText As String) As Boolean
Const sPROCNAME As String = "Str_InText"
Dim sfinaltext As String
Dim icount As Integer
On Error GoTo AnError
InStr() ???????????????
For icount = 1 To Len(sText)
If (Mid(sText, icount, Len(sFindText)) = sFindText) Then
Str_InText = True
Exit Function
Else
Str_InText = False
sfinaltext = sfinaltext & Mid(sText, icount, 1)
End If
Next icount
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"determine if the string """ & sFindText & """" & _
"exists in the string """ & sText & """")
End Function
Str_LastGet
Returns the last entry in a concatenated string.Public Function Str_LastGet( _
ByVal sTextConcat As String, _
Optional ByVal sSeperateChar As String = ";", _
Optional ByVal bInformUser As Boolean = False) As String
Const sPROCNAME As String = "Str_LastGet"
Dim inextcharpos As Integer
On Error GoTo ErrorHandler
If (sTextConcat <> "") Then
inextcharpos = Str_CharsNoOf(sTextConcat, sSeperateChar)
If (inextcharpos = 1) Then
Str_LastGet = Left(sTextConcat, Len(sTextConcat) - 1)
sTextConcat = ""
Else
inextcharpos = 1
Do While Left(Right(Left(sTextConcat, Len(sTextConcat) - 1), _
inextcharpos), 1) <> sSeperateChar
inextcharpos = inextcharpos + 1
Loop
Str_LastGet = Right(sTextConcat, inextcharpos)
Str_LastGet = Left(Str_GetLast, Len(Str_GetLast) - 1)
End If
Else
Str_LastGet = ""
If bInformUser = True Then
Call Frm_Inform("", "There are no sub-strings to get")
End If
End If
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"obtain the last entry in the concatenated string" & vbCrLf & _
"""" & sTextConcat & """")
End Function
Str_LastNumber
Returns the number that is at the end of a string.Public Function Str_LastNumber( _
ByVal sText As String) As String
Const sPROCNAME As String = "Str_LastNumber"
Dim sfinaltext As String
Dim icount As Integer
On Error GoTo ErrorHandler
For icount = 1 To Len(sText)
If (Asc(Mid(sText, icount, 1)) >= 48) And (Asc(Mid(sText, icount, 1)) <= 57) Then
Str_LastNumber = Right(sText, Len(sText) - icount + 1)
Exit Function
Else
sfinaltext = sfinaltext & Mid(sText, icount, 1)
End If
Next icount
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"return the number that is at the end of the string" & vbCrLf & _
"""" & sText & """")
End Function
Str_LinesNoOf
sdasdas.Public Function Str_LinesNoOf( _
ByVal sText As String, _
ByVal iNoOfLines As Integer) As String
Const sPROCNAME As String = "Str_LinesNoOf"
Dim icharcr As Integer
Dim inoofcrs As Integer
Dim snewstring As String
On Error GoTo ErrorHandler
inoofcrs = Str_CharNoOf(stext)
snewstring = sText
For icharCr = inoofcrs To (iNoOfLines - 2)
snewstring = snewstring & Chr(13)
Next icharcr
Str_LinesNoOf = snewstring
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"return the number of lines ...")
End Function
Str_MiddleOf
Public Function Str_MiddleOf( _
ByVal sText As String, _
ByVal iRemoveRightlen As Integer, _
ByVal iRemoveLeftlen As Integer) As String
Const sPROCNAME As String = "Str_MiddleOf"
Dim shalfway As String
On Error Resume Next
shalfway = Right(sText, Len(sText) - iRemoveLeftlen)
Str_MiddleOf = Left(shalfway, Len(shalfway) - iRemoveRightlen)
If gbDEBUG_ERRMSG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"return the text in the middle of the string '" & sText & "'.")
End Function
Str_NextGet
Returns the next entry in a string concatenation.Public Function Str_NextGet( _
ByVal sTextConcat As String, _
Optional ByVal sSeperateChar As String = ";", _
Optional ByVal bInformUser As Boolean = False) As String
Const sPROCNAME As String = "Str_NextGet"
Dim inextcharpos As Integer
On Error GoTo ErrorHandler
If sTextConcat <> "" Then
inextcharpos = InStr(1, sTextConcat, sSeperateChar)
If (inextcharpos > 0) Then
Str_NextGet = Left(sTextConcat, inextcharpos - 1)
Else
Str_NextGet = sTextConcat
sTextConcat = ""
End If
Else
Str_NextGet = ""
If bInformUser = True Then Call MsgBox("There are no sub-strings to get")
End If
If gbDEBUG_ERRMSG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"obtain the next entry in the concatenated string" & vbCrLf & _
"'" & sTextConcat & "'")
End Function
Str_NextRemove
Removes the next entry in a string concatenation.Public Function Str_NextRemove( _
ByVal sTextConcat As String, _
Optional ByVal sSeperateChar As String = "", _
Optional ByVal bInformUser As Boolean = False) As String
Const sPROCNAME As String = "Str_NextRemove"
Dim inextcharpos As Integer
On Error GoTo ErrorHandler
If (sSeperateChar = "") Then
sSeperateChar = Chr(10)
End If
If InStr(sTextConcat, sSeperateChar) = 0 Then
Str_NextRemove = ""
Else
Str_NextRemove = Str_RightOf(sTextConcat, , sSeperateChar)
End If
If gbDEBUG_ERRMSG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"remove the next entry in the concatenated string" & vbCrLf & _
"'" & sTextConcat & "'")
End Function
Str_NoOfCRs
Returns the total number of carriage (ie Char(10)) returns in a text string.Public Function Str_NoOfCRs( _
ByVal sTheText As String) As Integer
Const sPROCNAME As String = "Str_NoOfCRs"
Dim scurrenttext As String
Dim inoofCR As Integer
Dim inextCRno As Integer
On Error Resume Next
scurrenttext = sTheText
noofCR = 0
Do Until (scurrenttext = "")
inextCRno = Str_CharFindPositionofNext(scurrenttext, Chr(10))
If (inextCRno = -1) Then
scurrenttext = ""
Else
scurrenttext = Right(scurrenttext, Len(scurrenttext) - inextCRno)
inoofCR = inoofCR + 1
End If
Loop
Str_NoOfCRs = inoofCR
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"return the number of carriage returns in the text" & vbCrLf & _
"""" & sTheText & """")
End Function
Str_NumberFindPositionofNext
Returns the character position of the first occurrence of a number in a string.Public Function Str_NumberFindPositionofNext( _
ByVal sText As String) As Integer
Const sPROCNAME As String = "Str_NumberFindPositionofNext"
Dim ifirstnumber As Integer
On Error Resume Next
' ifirstnumber = Str_FindPositionofNextChars(sText, _
' "0", "1", "2", "3", "4", "5", "6", "7", "8", "9")
Str_FindPositionofNextNumber = ifirstnumber
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"return the character position of the next number in the string" & vbCrLf & _
"""" & sText & """")
End Function
Str_ParaCombine
Returns a string containing no carriage returns. Removes all carriage returns and adds full stops and capital letters to sentances.Public Function Str_ParaCombine( _
ByVal sText As String, _
ByVal sSeperateChar As String, _
Optional ByVal bCapitalPrefix As Boolean = True, _
Optional ByVal bFullStop As Boolean = True) As String
Const sPROCNAME As String = "Str_ParaCombine"
Dim ichr13pos As Integer
Dim spara As String
Dim snewtext As String
On Error GoTo ErrorHandler
snewtext = ""
sText = Trim(sText)
Do While True
ichr13pos = InStr(1, sText, Chr(13))
If (ichr13pos = 0) Then
If (sText <> "" And bCapitalPrefix = True) Then
sText = Str_CharCapital(Left(sText, 1)) & Right(sText, Len(sText) - 1)
End If
If (sText <> "" And sSeperateChar = Chr(46)) Then
If (Right(sText, 1) <> Chr(46)) Then
sText = sText & Chr(46)
End If
End If
Para_Combine = snewtext & sText
Exit Do
End If
If (ichr13pos = 1) Then
sText = Trim(Right(sText, Len(sText) - 1))
End If
If (ichr13pos > 1) Then
spara = Trim(Left(sText, ichr13pos - 1))
If (bFullStop = True) Then
If (Right(spara, 1) <> Chr(46)) Then
spara = spara & sSeperateChar
End If
End If
spara = spara & Chr(32)
If (bCapitalPrefix = True) Then
spara = Str_CharCapital(Left(spara, 1)) & Right(spara, Len(spara) - 1)
End If
snewtext = snewtext & spara
sText = Trim(Right(sText, Len(sText) - ichr13pos))
End If
Loop
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"remove all the carriage returns and ensure there are full stops and capital" & _
" letters from the text " & vbCrLf & """" & sText & """")
End Function
Str_ParaWidth
Returns the total width of the paragraph or line ??.Public Function Str_ParaWidth( _
ByVal sTheText As String, _
ByVal bBold As Boolean) As Single
Const sPROCNAME As String = "Str_ParaWidth"
Dim scurrenttext As String
Dim sngtota As Single
Dim inextspaceno As Integer
Dim sngwordwidth As Single
On Error GoTo AnError
scurrenttext = sTheText
sngtotal = 0
Do Until (scurrenttext = "")
inextspaceno = Str_CharFindPositionofNext(scurrenttext, " ")
If inextspaceno = -1 Then inextspaceno = Len(scurrenttext)
sngwordwidth = Str_WordWidth(Left(scurrenttext, inextspaceno), bBold)
sngtotal = sngtotal + sngwordwidth
If (inextspaceno < Len(scurrenttext)) Then
scurrenttext = Right(scurrenttext, Len(scurrenttext) - inextspaceno)
Else
scurrenttext = ""
End If
Loop
Str_ParagraphWidth = sngtotal
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, _
"return the total width of a paragraph or line")
End Function
Str_ReplaceFunnyChars
Public Function Str_ReplaceFunnyChars( _
ByVal sText As String) As String
Const sPROCNAME As String = "Str_ReplaceFunnyChars"
Dim sitem As String
On Error GoTo ErrorHandler
sitem = sText
sitem = Replace(sitem, Chr(40), "0040") '(
sitem = Replace(sitem, Chr(41), "0041") ')
sitem = Replace(sitem, Chr(44), "0044") ',
sitem = Replace(sitem, Chr(45), "0045") '-
sitem = Replace(sitem, Chr(46), "0046") '.
sitem = Replace(sitem, Chr(47), "0047") '/
sitem = Replace(sitem, Chr(92), "0092") '[
sitem = Replace(sitem, Chr(93), "0093") ']
sitem = Replace(sitem, Chr(121), "0121") '\
sitem = Replace(sitem, Chr(214), "0214") 'O hat
sitem = Replace(sitem, Chr(226), "0226") 'a hat
sitem = Replace(sitem, Chr(228), "0228") 'a 2hats
sitem = Replace(sitem, Chr(39), "0039") '' apostrophe
sitem = Replace(sitem, Chr(43), "0043") '+
sitem = Replace(sitem, Chr(194), "0194") 'capital a hat
sitem = Replace(sitem, Chr(196), "0196") 'capital a 2 hats
sitem = Replace(sitem, Chr(200), "0200") 'capital e forward line
sitem = Replace(sitem, Chr(201), "0201") 'capital e backward line
sitem = Replace(sitem, Chr(205), "0205") 'capital i with dash
sitem = Replace(sitem, Chr(209), "0209") 'capital n with squiggle
sitem = Replace(sitem, Chr(211), "0211") 'capital o with backward line
sitem = Replace(sitem, Chr(220), "0220") 'capital u with 2 lines
Str_ReplaceFunnyChars = sitem
Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Function
Str_ReplaceIfZorN
Returns the string unless it is either Null or equal to a zero ("0") then it returns another character if it is.Public Function Str_ReplaceIfZorN( _
ByVal sText As String, _
Optional ByVal sReturnChar As String = " ") As String
Const sPROCNAME As String = "Str_ReplaceIfZorN"
On Error GoTo ErrorHandler
If (IsNull(sText) Or (sText = "0")) Then
Str_ReplaceIfZorN = sReturnChar
Else
Str_ReplaceIfZorN = sText
End If
If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, _
"return the string " & vbCrLf & """" & sText & """" & vbCrLf & _
"substituting if it is Null or ""0""")
End Function
Str_Reverse
Returns a string with all the characters reversed.Public Function Str_Reverse( _
ByVal sText As String) As String
Const sPROCNAME As String = "Str_Reverse"
Dim llength As Long
Dim lcharcounter As Long
On Error GoTo AnError
Str_Reverse = ""
llength = Len(sText)
For lcharcounter = llength To 1 Step -1
Str_Reverse = Str_Reverse & Mid(sText, lcharcounter, 1)
Next lcharcounter
If gbDEBUG_ERRMSG = False Then Exit Function
AnError:
Call Error_Handle("Str_Reverse", msMODULENAME, _
"return the reverse of the string" & vbCrLf & _
"'" & sText & "'")
End Function
Str_RightOf
Public Function Str_RightOf( _
ByVal sText As String, _
Optional ByVal iRemoveFromLeft As Integer = 0, _
Optional ByVal sFirstCharFromLeft As String = "", _
Optional ByVal sFirstCharFromRight As String = "") As String
Const sPROCNAME As String = "Str_RightOf"
Dim icharposition As Integer
On Error GoTo AnError
If (iRemoveFromLeft <> 0) Then
Str_RightOf = Right(sText, Len(sText) - iRemoveFromLeft)
End If
If (sFirstCharFromLeft <> "") Then
icharposition = Str_CharFindPositionofNext(sText, sFirstCharFromLeft)
If (icharposition = -1) Then
Str_RightOf = sText
Else
Str_RightOf = Right(sText, Len(sText) - icharposition)
End If
End If
If (sFirstCharFromRight <> "") Then
icharposition = Str_CharFindPositionofNext(Str_Reverse(sText), sFirstCharFromRight)
Str_RightOf = Right(sText, icharposition - 1)
End If
If gbDEBUG_ERRMSG = False Then Exit Function
AnError:
Call Error_Handle("Str_RightOf", msMODULENAME, _
"return remove " & iRemoveFromLeft & " characters " & _
"from the left of the string '" & sText * "'.")
End Function
Str_TextGetMatch
Returns a string given a sub string in a seperated string concatenation.Public Function Str_TextGetMatch( _
ByVal sText As String, _
ByVal sSubStrText As String, _
Optional ByVal sSeparateChar As String = ";") As String
Const sPROCNAME As String = "Str_TextGetMatch"
Dim stemptext As String
Dim sfinaltext As String
Dim istartpos As Integer
Dim ifinishpos As Integer
On Error Goto AnError
istartpos = InStr(1, sText, sSubStrText)
If istartpos = 0 Then If Left(sText, 1) <> Left(sSubStrText, 1) Then istartpos = -1
If istartpos = -1 Then
Str_TextGetMatch = ""
Else
stemptext = Left(sText, istartpos - 1)
If InStr(1, stemptext, sSeparateChar < 1 Then
sfinaltext = Left(sText, Len(stemptext) + Len(sSubStrText))
Else
Do While istartpos > 0
If Right(stemptext, 1) = sSeparateChar Then
sfinaltext = sfinaltext & sSubStrText
istartpos = 0
Else
sfinaltext = Right(stemptext, 1) & sfinaltext
stemptext = Left(stemptext, Len(stemptext) - 1)
istartpos = istartpos - 1
End If
Loop
End If
ifinishpos = InStr(1, sText, sSubStrText) + Len(sSubStrText) - 1
stemptext = Right(sText, Len(sText) - ifinishpos)
Do While ifinishpos < Len(sText)
If Left(stemptext, 1) = sSeparateChar Then
ifinishpos = Len(sText)
Else
sfinaltext = sfinaltext & Left(stemptext, 1)
stemptext = Right(stemptext, Len(stemptext) - 1)
ifinishpos = ifinishpos + 1
End If
Loop
Str_TextGetMatch = sfinaltext
End If
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Str_TextGetMatch", msMODULENAME, 1, _
"returns a string given a sub string in a seperated string concatenation")
End Function
Str_TextReplace
Replaces all the occurances of a text string with a different text string.Public Function Str_TextReplace( _
ByVal sText As String, _
ByVal sFindText As String, _
ByVal sReplaceText As String) As String
Const sPROCNAME As String = "Str_TextReplace"
Dim sfinaltext As String
Dim icount As Integer
On Error GoTo AnError
For icount = 1 To Len(sText) - Len(sFindText)
If Mid(sText, icount, Len(sFindText)) = sFindText Then
sfinaltext = sfinaltext & sReplaceText
icount = icount + Len(sFindText) - 1
Else
sfinaltext = sfinaltext & Mid(sText, icount, 1)
End If
Next icount
If Right(sText, Len(sFindText)) = sFindText Then
Str_TextReplace = sfinaltext
Else
Str_TextReplace = sfinaltext & Right(sText, Len(sFindText) - 1)
End If
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Str_TextReplace", msMODULENAME, 1, _
"replace the text """ & sFindText & """ and replace it with the text " & _
"""" & sReplaceText & """ in the string" & vbCrLf & """" & sText & """")
End Function
Str_TextToEnd
Returns a concatenation string having moved a particular text item to the end.Public Function Str_TextToEnd( _
ByVal sText As String, _
ByVal sTextToMove As String, _
Optional ByVal sSeperateChar As String = ";") As String
Const sPROCNAME As String = "Str_TextToEnd"
Dim istartpos As Integer
Dim ifinishpos As Integer
On Error GoTo AnError
istartpos = InStr(1, sText, sTextToMove)
If istartpos = 0 Then If Left(sText, 1) <> Left(sTextToMove, 1) Then
istartpos = -1
End If
If istartpos = -1 Then
Str_TextToEnd = sText 'just return since there is more text
' text string cannot be found - include a bInformUser !!
Else
ifinishpos = istartpos + Len(sTextToMove)
Str_TextToEnd = Left(sText, istartpos - 1) + _
Right(sText, Len(sText) - ifinishpos) & sTextToMove & sSeperateChar
End If
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Str_TextToEnd", msMODULENAME, 1, _
"move the string """ & sTextToMove & """ to the end of the string " & _
"""" & sText & """")
End Function
Str_TextToStart
Returns a concatenation string having moved a particular text item to the start.Public Function Str_TextToStart( _
ByVal sText As String, _
ByVal sTextToMove As String, _
Optional ByVal sSeperateChar As String = "") As String
Const sPROCNAME As String = "Str_TextToStart"
Dim istartpos As Integer
Dim ifinishpos As Integer
On Error GoTo AnError
istartpos = InStr(1, sText, sTextToMove)
If istartpos = 0 Then If Left(sText, 1) <> Left(sTextToMove, 1) Then istartpos = -1
If istartpos = -1 Then
Str_TextToStart = sText
' text string cannot be found - include a bInformUser !!
Else
ifinishpos = istartpos + Len(sTextToMove)
Str_TextToStart = sTextToMove & sSeperateChar & _
Left(sText, istartpos - 1) & Right(sText, Len(sText) - ifinishpos)
End If
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Str_TextToStart", msMODULENAME, 1, _
"move the string & """ & sTextToMove & """ to the start of the string " & _
"""" & sText & """")
End Function
Str_TickerCodeToSave
Removes any fullstops from a text string and replaces them with another character.Public Function Str_TickerCode_ToSave( _
ByVal sTicker As String) As String
Const sPROCNAME As String = "Str_TickerCode_ToSave"
Dim idot As Integer
On Error GoTo AnError
idot = InStr(1, sTicker, ".")
If (idot > 0) Then
TickerCode_ToSave = Left(sTicker, idot - 1) & "#" & _
Right(sTicker, Len(sTicker) - idot)
Else
TickerCode_ToSave = sTicker
End If
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Str_TickerCode_ToSave", msMODULENAME, 1, _
"")
End Function
Str_TickerCodeToUse
Replaces any characters in a text string that should actually be fullstops.Public Function Str_TickerCode_ToUse( _
ByVal sTicker As String) As String
Const sPROCNAME As String = "Str_TickerCode_ToUse"
Dim ihash As Integer
On Error GoTo AnError
ihash = InStr(1, sTicker, "#")
If (idot > 0) Then
TickerCode_ToUse = Left(sTicker, ihash - 1) & "." & _
Right(sTicker, Len(sTicker) - ihash)
Else
TickerCode_ToUse = sTicker
End If
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Str_TickerCode_ToUse", msMODULENAME, 1, _
"")
End Function
Str_ToArray
Transfers all the entries in a concatenated string to a single or multi dimensional array.Public Sub Str_ToArray( _
ByVal sText As String, _
ByRef vArrayName As Variant, _
Optional ByVal sSeperateChar As String = ";")
Const sPROCNAME As String = "Str_ToArray"
Dim snextentry As String
Dim iarraycount As Integer
Dim inoofchars As Integer
On Error GoTo ErrorHandler
inoofchars = Str_CharsNoOf(sText, sSeperateChar)
If inoofchars > 0 Then
ReDim vArrayName(inoofchars)
iarraycount = 0
Do While Len(sText) > 0
If InStr(1, sText, sSeperateChar) = 0 Then
snextentry = sText
sText = ""
Else
snextentry = Left(sText, InStr(1, sText, sSeperateChar) - 1)
sText = Right(sText, Len(sText) - Len(snextentry) - 1)
End If
vArrayName(iarraycount) = snextentry
iarraycount = iarraycount + 1
Loop
End If
Exit Sub
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, _
"split up the string" & vbCrLf & sText & vbCrLf & _
"separated by " & sSeperateChar & " and place them in an array")
End Sub
Str_ToBinary
Public Function Str_ToBinary(ByVal sText As String) As String
Dim bin As String
Dim j As Long
Dim str As String
Dim i As Long
Dim z As Double
Dim y As Double
bin = ""
For j = 1 To Len(sText)
str = Mid(sText, j, 1)
z = Asc(str)
For i = 7 To 0 Step -1
y = (2 ^ i)
bin = bin & Int(((z / y) - Int(((z / y) / 2)) * 2))
Next i
bin = bin & " "
Next j
Str_ToBinary = bin
End Function
Str_ToCharsArray
Seperates out all the characters from a string into an array.Public Function Str_ToCharsArray( _
ByVal sText As String)
Const sPROCNAME As String = "Str_CharsToArray"
Dim stemp As String
Dim vArray As Variant
On Error GoTo ErrorHandler
stemp = StrConv(sText, vbUnicode)
vArray = Split(Left(stemp, Len(stemp) - 1), vbNullChar)
Str_ToCharsArray = vArray
If gbDEBUG = False Then Exit Sub
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"split up the characters in """ & sText & """" & _
" and place them into the array """ & sArrayName & """")
End Function
Str_ToCollection
Public Function Str_ToCollection( _
ByVal sText As String, _
Optional ByVal sSeparateChar As String = ",") As Collection
Const sPROCNAME As String = "Str_ToCollection"
Dim objCollection As Collection
Dim snextentry As String
Do While Len(sText) > 0
If InStr(1, sText, sSeparateChar) = 0 Then
snextentry = sText
sText = ""
Else
snextentry = Left(sText, InStr(1, sText, sSeparateChar) - 1)
sText = Right(sText, Len(sText) - Len(snextentry) - 1)
End If
objCollection.Add snextentry
Loop
Set Str_ToCollection = objCollection
End Function
Str_ToDate
Public Function Str_ToDate( _
ByVal sDateValue As String, _
Optional ByVal sDateFormat As String = "dd/mm/yyyy") As String
Const sPROCNAME As String = "Str_ToDate"
Str_ToDate = Format(CDate(sDateValue), sDateFormat)
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, _
"convert the date string ??")
End Function
Str_ToListComboBox
Transfers all the entries in a concatenated string to a single or multi column listbox or combobox.Public Sub Str_ToListComboBox( _
ByVal sText As String, _
ByVal lstBoxName As Control, _
Optional ByVal sSeparateChar As String = ";", _
Optional ByVal sRowChar As String = "#", _
Optional ByVal bSelectIfOne As Boolean = True)
Const sPROCNAME As String = "Str_ToListComboBox"
Dim iseparatepos As Integer
Dim seachone As String
On Error GoTo AnError
lstBoxName.Clear
Do While Len(sText) > 0
iseparatepos = InStr(sText, sSeparateChar)
If InStr(1, sText, sSeparateChar) > 0 Then
lstBoxName.AddItem Left(sText, iseparatepos - 1)
sText = Right(sText, Len(sText) - iseparatepos)
Else
lstBoxName.AddItem sText
sText = ""
End If
Loop
If lstBoxName.ListCount = 1 And bSelectIfOne = True Then lstBoxName.ListIndex = 0
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Str_ToListComboBox", msMODULENAME, 1, _
"transfer the concatenated string to the control '" & lstBoxName.Name & "'.")
End Sub
Str_ToTextFile
Transfers all the entries in a concatenated string to a textfile.Public Sub Str_ToTextFile( _
ByVal sText As String, _
ByVal sFolderPath As String, _
ByVal sTextFile As String, _
Optional ByVal sExtension As String = ".txt", _
Optional ByVal sSeparateChar As String = "#")
Const sPROCNAME As String = "Str_ToTextFile"
Dim iFileNo As Integer
Dim snextentry As String
Dim iseparatepos As Integer
On Error GoTo AnError
iFileNo = FreeFile 'get the next free file number
sTextFile = sFolderPath & sTextFile & sExtension
Open sTextFile For Output As iFileNo
Do While Len(sText) > 0
iseparatepos = InStr(1, sText, sSeparateChar)
If (iseparatepos > 0) Then
snextentry = Left(sText, iseparatepos - 1)
Print #iFileNo, snextentry
sText = Right(sText, Len(sText) - Len(snextentry) - 1)
Else
Print #iFileNo, sText
sText = ""
End If
Loop
Close iFileNo
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("File_Exists", msMODULENAME, 1, _
"transfer the concatenated string " & vbCrLf & _
"""" & sText & """" & vbCrLf & _
"to the following text file:" & vbCrLf & _
sFolderPath & sTextFile & sExtension)
End Sub
Str_ValueReturn
Public Function Str_ValueReturn( _
ByVal sTextNumber As String) As Single
If IsNumeric(sTextNumber ) = True Then
Str_ValueReturn= CSng(sTextNumber )
Else
Str_ValueReturn= 0
End If
End Function
Str_WidthParagraph
Returns the total width of a paragraph.Public Function Str_WidthParagraph( _
ByVal sText As String, _
ByVal bBold As Boolean) As Single
Const sPROCNAME As String = "Str_WidthParagraph"
Dim inextspaceno As Integer
Dim sngwordwidth As Single
Dim sngtotal As Single
On Error GoTo AnError
sngtotal = 0
Do Until (sText = "")
inextspaceno = InStr(1, sText, " ")
If inextspaceno = -1 Then inextspaceno = Len(sText)
sngwordwidth = Str_WidthWord(Left(sText, inextspaceno), bBold)
sngtotal = sngtotal + sngwordwidth
If (inextspaceno < Len(sText)) Then
sText = Right(sText, Len(sText) - inextspaceno)
Else
sText = ""
End If
Loop
Str_WidthParagraph = sngtotal
Exit Function
AnError:
Call Error_Handle("Str_WidthParagraph", msMODULENAME, 1, _
"return the total width of the paragraph" & vbCrLf & """" & sText & """")
End Function
Str_WidthWidest
Returns the line that has the widest number of characters in it and returns the width of all these characters.Public Function Str_WidthWidest( _
ByVal sText As String, _
ByVal bBold As Boolean) As Single
Const sPROCNAME As String = "Str_WidthWidest"
Dim scurrenttext As String
Dim inextCRno As Integer
Dim sngparawidth As Single
Dim maxparawidth As Single
On Error GoTo AnError
scurrenttext = sText
maxparawidth = 0
Do Until (scurrenttext = "")
' assumes seperated by Chr(10)
inextCRno = Str_FindPositionofNextChar(scurrenttext, Chr(10))
If inextCRno = -1 Then
sngparawidth = Str_WidthParagraph(Left(scurrenttext, Len(scurrenttext)), bBold)
Else
sngparawidth = Str_WidthParagraph(Left(scurrenttext, inextCRno - 2), bBold)
End If
If sngparawidth > maxparawidth Then maxparawidth = sngparawidth 'increment max
If (inextCRno = -1) Then
scurrenttext = ""
Else
scurrenttext = Right(scurrenttext, Len(scurrenttext) - inextCRno)
End If
Loop
Str_WidthWidest = maxparawidth
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Str_WidthWidest", msMODULENAME, 1, _
"return the total width of the widest paragraph in the text" & vbCrLf & sText)
End Function
Str_WordCount
Public Function Str_WordCount()
End Sub
Str_WordFirst
Public Function Str_WordFirst( _
ByVal sText As String) As String
Const sPROCNAME As String = "Str_WordFirst"
Dim ispace As Integer
On Error GoTo AnError
ispace = Instr(1, sText, " ")
If ispace > 0 Then Str_WordFirst = Left(sText, ispace - 1)
If ispace = 0 Then Str_WordFirst = sText
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Str_WordFirst", msMODULENAME, 1, _
"obtain the first word from """ & sText & """")
End Function
Str_WordLast
Public Function Str_WordLast( _
ByVal sText As String) As String
Const sPROCNAME As String = "Str_WordLast"
Dim ispace As Integer
On Error GoTo AnError
If Instr(1, sText, " ") = -1 Then
Str_WordLast = ""
Exit Function
End If
Do While Instr(1, sText, " ") > 0 Then
ispace = Instr(1, sText, " ")
sText = Right(sText, len(sText) - ispace)
Loop
Str_WordLast = sText
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Str_WordLast", msMODULENAME, 1, _
"obtain the last word from '" & sText & "'.")
End Function
Str_WordReplace
Public Function Str_WordReplace( _
ByVal sText As String, _
ByVal sFindStr As String, _
ByVal sReplaceStr As String) As String
Const sPROCNAME As String = "Str_WordReplace"
Dim aText() As String
Dim lcount As Long
On Error GoTo AnError
aText = Split(sText)
For lcount = LBound(aText) To UBound(aText)
If aText(lcount) Like sFindStr Then
aText(lcount) = sReplaceStr
End If
Next lcount
Str_WordReplace = Join(aText)
Exit Function
AnError:
End Function
Str_WordWidth
Returns the total width of characters in a word.Public Function Str_WordWidth( _
ByVal sWord As String, _
ByVal bBold As Boolean) As Single
Const sPROCNAME As String = "Str_WordWidth"
Dim sChar As String
Dim scurrenttext As String
Dim sngtotalwidth As Single
On Error GoTo AnError
sngtotalwidth = 0
Do Until (sWord = "")
sChar = Left(sWord, 1)
sngtotalwidth = sngtotalwidth + Char_Tahoma8Reg(sChar)
' If bBold = True Then sngtotalwidth = sngtotalwidth + Char_RegularWidth(sChar)
' If bBold = False Then sngtotalwidth = sngtotalwidth + Char_Tahoma8Reg(sChar)
sWord = Right(sWord, Len(sWord) - 1)
Loop
Str_WordWidth = sngtotalwidth
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Str_WordWidth", msMODULENAME, 1, _
"return the total width of the characters in the string """ & sWord & """")
End Function
© 2024 Better Solutions Limited. All Rights Reserved. © 2024 Better Solutions Limited Top