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 inoofCR AsInteger
Dim inextCRno As Integer
   On Error Resume Next

   inoofCR = 0
   Do Until (sText = "")
      inextCRno = InStr(1, sText, sChar)
      If (inextCRno = 0) Then
         sText = ""
      Else
         sText = Right(sText, Len(sText) - inextCRno)
         inoofCR = inoofCR + 1
      End If
   Loop
   Str_CharsNoOf = inoofCR

   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

Public Function Str_CharNoOf2(ByVal sText As String, _
                              sChar As String) As Integer
Dim icountCR As Integer
Dim icharCR As Integer
   On Error GoTo AnError
   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_CharNoOf2 = icountCR
   
   If gbDEBUG = False Then Exit Function
AnError:
   Call Error_Handle("Str_CharNoOf2", msMODULENAME, 1, _
        "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 AnError

   Select Case sChar

   End Select
'   Char_ArialNarrow8Bold = ??? / icharwidth

   If gbDEBUG = False Then Exit Function
AnError:
   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

Chars_ToArray

Seperates out all the characters from a string into an array.

Public Sub Str_CharsToArray( _
         ByVal sText As String, _
         ByVal sArrayName As String, _
         ByRef vArrayName As Variant)

Const sPROCNAME As String = "Str_CharsToArray"
Dim snextentry As String
   On Error GoTo ErrorHandler

   ReDim vArrayName(0)
   Do While (Len(sText) > 0)
      snextentry = Left(sText, 1)
      vArrayName(UBound(vArrayName)) = snextentry
      sText = Right(sText, Len(sText) - 1)
      If sText <> "" Then 
         ReDim Preserve vArrayName(UBound(vArrayName) + 1)
      End If
   Loop

   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
        "split up the characters in """ & sText & """" & _
        " and place them into the array """ & sArrayName & """")
End Sub

Remove_AppendedBrackets

vba

Remove_LastDoubleReturn

vba

Remove_LeadingSpaces

vba

Remove_SmartQuotes

vba

RemoveSmartQuotes

vba

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_ASC

vba

Str_ASCStr

vba

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 sChar As String) As Integer

Const sPROCNAME As String = "Str_CharsNoOf"
Dim inoofCR As Integer
Dim inextCRno As Integer
   On Error GoTo ErrorHandler

   inoofCR = 0
   Do Until (sText = "")
      inextCRno = InStr(1, sText, sChar)
      If (inextCRno = 0) Then
         sText = ""
      Else
         sText = Right$(sText, Len(sText) - inextCRno)
         inoofCR = inoofCR + 1
      End If
   Loop
   Str_CharsNoOf = inoofCR
   Exit Function

ErrorHandler:
    Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
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 Resume Next

   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
AnError:
   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_FormatDateTime

source code

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_IsBlank

source code

Str_IsNumeric

source code

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("Str_ParaWidth", msMODULENAME, 1, _
        "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 AnError

   If (IsNull(sText) Or (sText = "0")) Then
      Str_ReplaceIfZorN = sReturnChar
   Else: Str_ReplaceIfZorN = sText
   End If

   If gbDEBUG = False Then Exit Function
AnError:
   Call Error_Handle("Str_ReplaceIfZorN", msMODULENAME, 1, _
        "return the string " & vbCrLf & """" & sText & """" & vbCrLf & _
        "substituting if it is Null or ""0""")
End Function

Str_ReturnNumberInBrackets

source code

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_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_VBALeft

vba

Str_VBAMid

vba

Str_VBARight

vba

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

ConCat_After

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 AnError

   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
AnError:
   Str_ConCatAfter = ""
   Call Error_Handle("Str_ConCatAfter", msMODULENAME, 1, _
        "find the string """ & sFindText & """ in the following:" & _
        vbCrLf & """" & serrortext & """")
End Function

ConCat_Before

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 AnError

   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
AnError:
   Str_ConCatBefore = ""
   Call Error_Handle("Str_ConCatBefore", msMODULENAME, 1, _
        "find the string """ & sFindText & """ in the following:" & _
        vbCrLf & """" & serrortext & """")
End Function

ConCat_DictionaryValuesLookup

source code

ConCat_Exists

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 AnError

   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
AnError:
   Call Error_Handle("Str_ConCatExists", msMODULENAME, 1, _
        "determine if the string """ & sText & """ exists already " & _
        "in the concatenation" & vbCrLf & """" & sTextConcat & """")
End Function

ConCat_From

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 AnError

   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
AnError:
   Call Error_Handle("Str_ConCatFrom", msMODULENAME, 1, _
        "expand the address from a single line")
End Function

ConCat_Remove

Public Function Str_ConCatRemove( _
         ByVal sText As String, _
         ByVal sRemoveText As String, _
Optional sSeparateChar As String = ";") As String

Dim iseparatepos As Integer
Dim serrortext As String
Dim scurrent As String
Dim snewtext As String
   On Error GoTo AnError

   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
AnError:
   Str_ConCatRemove = serrortext
   Call Error_Handle("Str_ConCatRemove", msMODULENAME, 1, _
        "remove the string entries """ & sRemoveText & """" & vbCrLf & _
        "from the following: """ & serrortext & """ string")
End Function

ConCat_Reverse

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 AnError

   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
AnError:
   Call Error_Handle("Str_ConCatReverse", msMODULENAME, 1, _
        "return the reverse of the string concatenation " & vbCrLf & sText)
End Function

ConCat_To

source code

ConCat_ToArray

vba

ConCat_ToArrayInteger

source code

ConCat_ToArrayList

source code

ConCat_ToArrayString

source code

ConCat_ToDictionaryValues

source code

Str_ToArray

Transfers all the entries in a concatenated string to a single or multi diemsional 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("Str_ToArray", msMODULENAME, 1, _
        "split up the string" & vbCrLf & sText & vbCrLf & _
        "separated by " & sSeperateChar & " and place them in an array")
End Sub

Str_ToByteArray

vba

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_ToComboBox

vba

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("Str_ToDate", msMODULENAME, 1, _
        "convert the date string ??")
End Function

Str_ToDateTime

vba

Str_ToFile

vba

Str_ToListBox

vba

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_ToProperCase

vba

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

Word_Count

vba

Word_First

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

Word_Last

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

Word_Replace

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

Word_Width

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