StringUtility

Option Explicit
Const sDEFAULT_DELIM = ","' Default delimiter For parsing strings
Const sDEFAULT_PAD = " " ' Default pad character

Function sGetToken(ByVal sString As String, ByVal sDelimiter As String) As String
  Static s_sString As String
  Static s_sDelimiter As String * 1
  Static s_nPos As Integer
  Dim nTempPos As Integer
  sGetToken = ""
 'If String supplied...
  If (sString <> "") Then
    'Assume we're getting the first token
     s_sString = sString
     If (sDelimiter <> "") Then
       'Use supplied delimiter
        s_sDelimiter = sDelimiter
     Else
       'Use default delimiter if none supplied
        s_sDelimiter = sDEFAULT_DELIM
     End If
     If Right(s_sString, 1) <> sDelimiter Then
        s_sString = s_sString & s_sDelimiter
     End If
     nTempPos = 1
  Else
    'Assume we're getting the next token
     If (sDelimiter <> s_sDelimiter) Then
        Mid(s_sString, Len(s_sString)) = sDelimiter
        s_sDelimiter = sDelimiter
     End If
     nTempPos = s_nPos + 1
  End If
 'Retrieve the token
  s_nPos = InStr(nTempPos, s_sString, s_sDelimiter)
  If s_nPos And s_nPos > nTempPos Then
     sGetToken = Mid(s_sString, nTempPos, s_nPos - nTempPos)
  End If
End Function

'Description: See if pathname is a valid 8.3 path/filename
'Params:(IN) Pathname to check.
'Returns: True if valid 8.3 pathname, False if not.

Function bIsValid8Dot3Pathname(ByVal sPathName As String) As Integer
  Dim bIsOk As Integer
  Dim nLenBase As Integer
  Dim nLenExt As Integer
  Dim p As Integer
  Dim i As Integer
  Dim sSavedPathname As String
  Dim sDrive As String
  Dim sDirectory As String
  Dim sToken As String
  Dim sBaseName As String
  Dim sExtension As String
  Dim sInvalidCharacters As String
  bIsOk = True
  sInvalidCharacters = "/:*?<>|" & Chr$(34)
  sSavedPathname = UCase(sPathName)
 'Check for empty string
  If (Len(sSavedPathname) = 0) Then
     bIsOk = False
  End If
 'Parse out Drive letter
  If (bIsOk And InStr(sSavedPathname, ":")) Then
     sToken = sGetToken(sSavedPathname, ":")
     If (sToken <> "") Then
        Select Case Len(sToken)
        Case Is = 1:
           ' If drive specified, must be A-Z
             If (InStr("ABCDEFGHIJKLMNOPQRSTUVWXYZ", sToken) = 0) Then
                bIsOk = False
             Else
                sSavedPathname = Mid(sPathName, 3)
             End If
        Case Is = 0:
           ' If no drive specified, we're OK
             bIsOk = True
        Case Else:
           ' If drive is > 2 characters, error
             bIsOk = False
        End Select
    End If
  End If
  'Check for invalid characters
  If (bIsOk And Len(sSavedPathname) > 0) Then
     For i = 1 To Len(sSavedPathname)
         If (InStr(sInvalidCharacters, Mid(sSavedPathname, i, 1))) Then
            bIsOk = False
            Exit For
        End If
     Next i
  End If
  If (bIsOk) Then
 'Parse and validate the rest of the pathname
  If (Left(sSavedPathname, 1) = "\" And Len(sSavedPathname) > 1) Then
     sSavedPathname = Mid(sSavedPathname, 2)
  End If
  sToken = sGetToken(sSavedPathname, "\")
  If (sToken <> "") Then
 'Loop: Verify each token between the backslashes, as well 
 'as the filename, is 8.3
  Do
   'Parse out the basename and extension
    p = InStr(sToken, ".")
    If (p) Then
      'There is an extension
       sBaseName = Left(sToken, p - 1)
       sExtension = Mid(sToken, p + 1)
    Else
      'No extension
       sBaseName = sToken
       sExtension = ""
    End If
      'Validate 8.3
       nLenBase = Len(sBaseName)
       nLenExt = Len(sExtension)
       If (nLenBase > 8 Or nLenBase < 1 Or nLenExt > 3) Then
          bIsOk = False
       End If
       sToken = sGetToken("", "\")
  Loop Until (sToken = "" Or bIsOk = False)
  End If
  End If
  bIsValid8Dot3Pathname = bIsOk
End Function

'Description: Count # of occurrences of a character in a string.
'Params:(IN) String to search,(IN) Character to look for.
'Returns: # of occurrences.

Function nStrCount(sSource As String, sChar As String) As Integer
  Dim nPos As Integer
  Dim nCount As Integer
  nCount = 0
  nPos = InStr(sSource, sChar)
  While nPos
      nCount = nCount + 1
      nPos = InStr(nPos + 1, sSource, sChar)
  Wend
  nStrCount = nCount
End Function

'Description: Pad a string with a pad char
'Params:(IN) String to pad,
'(IN) Max size of string,
'(IN) Pad character (optional; default =space).
'Returns: Padded string

Function sPad(sSrc As String, nSize As Integer, sPadChar As String) As String
  Dim tmpPadChar As String * 1
  If (sPadChar <> "") Then
     tmpPadChar = sPadChar
  Else
     tmpPadChar = sDEFAULT_PAD
  End If
  If Len(sSrc) < nSize Then
     sPad = sSrc & String(nSize - Len(sSrc), tmpPadChar)
  Else
     sPad = sSrc
  End If
End Function

'Description: Delete characters from a string
'Params:(IN/OUT) String to delete from,
'(IN) Starting position for delete,
'(IN) Number of characters to delete.
'Modifies: Destination string

Sub StrDelete(sDest As String, nStart As Integer, nCount As Integer)
  Dim sLeft As String, sRight As String
  Dim nLen As Integer
  nLen = Len(sDest)
  If nStart >= 0 And nStart <= nLen Then
    'Deletion point is valid, OK to continue...
    'Isolate the left part
     If nStart > 1 And nLen > 0 Then
        sLeft = Left(sDest, nStart - 1)
     Else
        sLeft = ""
     End If
    'Isolate the right part
     If (nStart + nCount) <= nLen Then
        sRight = Mid(sDest, nStart + nCount)
     Else
        sRight = ""
     End If
    'Put string back together, minus the deleted chars
     sDest = sLeft & sRight
  End If
End Sub

'Description: Strip null characters from a string. 
'This is useful for cleaning up strings returned from Win API calls.
'Params:(IN) String with null characters
'Returns: Converted string
'Assumed: Anything after the 1st null character is not needed

Function sTrimNulls(s) As String
  Dim nPos As Integer
  nPos = InStr(s, Chr$(0))
  Select Case nPos
     Case Is > 1
        sTrimNulls = Left(s, nPos - 1)
     Case 1
        sTrimNulls = ""
     Case Else
        sTrimNulls = s
    End Select
End Function

'Description: Insert a substring into atarget string.
'Params:(IN/OUT) Destination string,
'(IN) Substring to insert,
'(IN) Insertion point.
'Returns: True if able to insert; Falseif not
'Modifies: Destination string.

Function StrInsert(sDest As String, sInsert As String, nStart As Integer) As Integer
  Dim sLeft As String, sRight As String
  Dim nLen As Integer
  nLen = Len(sDest)
  If nStart >= 0 And nStart <= nLen Then
    'Insertion point is valid, OK to continue...
    'Isolate the left part
     If nStart > 1 And nLen > 0 Then
        sLeft = Left(sDest, nStart - 1)
     Else
        sLeft = ""
     End If
    'Isolate the right part
     sRight = Right(sDest, nLen - nStart + 1)
    'Insert the new text
     sDest = sLeft & sInsert & sRight
     StrInsert = True
  Else
     StrInsert = False
  End If
End Function
 Description: 
Get token from string; For parsing strings in a 
fashion similar to the C strtok() library function.

Params:(IN) String to parse 
(Only required for 1st token; subsequent calls should pass "")
(IN) Delimiter character (""=use default; default = ",")
Returns: 
String containing token, or "" if no more tokens.

Assumed: If string param <> "", 
assumes first token. Otherwise, it is
assumed that the caller is requesting the next token.

Example: Dim sToken as string
sToken = sGetToken("c:\level1\level2\level3", "/" )
Do while ( sToken <> "" )
Debug.Print sToken
sToken = sGetToken( "", "\" )
Loop

Option Explicit
Const sDEFAULT_DELIM = ","' Default delimiter For parsing strings
Const sDEFAULT_PAD = " " ' Default pad character

Function sGetToken(ByVal sString As String, ByVal sDelimiter As String) As String
Static s_sString As String
Static s_sDelimiter As String * 1
Static s_nPos As Integer
Dim nTempPos As Integer
sGetToken = ""
'If String supplied...

If (sString <> "") Then
'Assume we're getting the first token

s_sString = sString
If (sDelimiter <> "") Then
'Use supplied delimiter

s_sDelimiter = sDelimiter
Else
'Use default delimiter if none supplied

s_sDelimiter = sDEFAULT_DELIM
End If
If Right(s_sString, 1) <> sDelimiter Then
s_sString = s_sString & s_sDelimiter
End If
nTempPos = 1
Else
'Assume we're getting the next token

If (sDelimiter <> s_sDelimiter) Then
Mid(s_sString, Len(s_sString)) = sDelimiter
s_sDelimiter = sDelimiter
End If
nTempPos = s_nPos + 1
End If
'Retrieve the token

s_nPos = InStr(nTempPos, s_sString, s_sDelimiter)
If s_nPos And s_nPos > nTempPos Then
sGetToken = Mid(s_sString, nTempPos, s_nPos - nTempPos)
End If
End Function

'Description: See if pathname is a valid 8.3 path/filename

'Params:(IN) Pathname to check.

'Returns: True if valid 8.3 pathname, False if not.

Function bIsValid8Dot3Pathname(ByVal sPathName As String) As Integer
Dim bIsOk As Integer
Dim nLenBase As Integer
Dim nLenExt As Integer
Dim p As Integer
Dim i As Integer
Dim sSavedPathname As String
Dim sDrive As String
Dim sDirectory As String
Dim sToken As String
Dim sBaseName As String
Dim sExtension As String
Dim sInvalidCharacters As String
bIsOk = True
sInvalidCharacters = "/:*?<>|" & Chr$(34)
sSavedPathname = UCase(sPathName)
'Check for empty string

If (Len(sSavedPathname) = 0) Then
bIsOk = False
End If
'Parse out Drive letter

If (bIsOk And InStr(sSavedPathname, ":")) Then
sToken = sGetToken(sSavedPathname, ":")
If (sToken <> "") Then
Select Case Len(sToken)
Case Is = 1:
' If drive specified, must be A-Z

If (InStr("ABCDEFGHIJKLMNOPQRSTUVWXYZ", sToken) = 0) Then
bIsOk = False
Else
sSavedPathname = Mid(sPathName, 3)
End If
Case Is = 0:
' If no drive specified, we're OK

bIsOk = True
Case Else:
' If drive is > 2 characters, error

bIsOk = False
End Select
End If
End If
'Check for invalid characters

If (bIsOk And Len(sSavedPathname) > 0) Then
For i = 1 To Len(sSavedPathname)
If (InStr(sInvalidCharacters, Mid(sSavedPathname, i, 1))) Then
bIsOk = False
Exit For
End If
Next i
End If
If (bIsOk) Then
'Parse and validate the rest of the pathname

If (Left(sSavedPathname, 1) = "\" And Len(sSavedPathname) > 1) Then
sSavedPathname = Mid(sSavedPathname, 2)
End If
sToken = sGetToken(sSavedPathname, "\")
If (sToken <> "") Then
'Loop: Verify each token between the backslashes, as well

'as the filename, is 8.3

Do
'Parse out the basename and extension

p = InStr(sToken, ".")
If (p) Then
'There is an extension

sBaseName = Left(sToken, p - 1)
sExtension = Mid(sToken, p + 1)
Else
'No extension

sBaseName = sToken
sExtension = ""
End If
'Validate 8.3

nLenBase = Len(sBaseName)
nLenExt = Len(sExtension)
If (nLenBase > 8 Or nLenBase < 1 Or nLenExt > 3) Then
bIsOk = False
End If
sToken = sGetToken("", "\")
Loop Until (sToken = "" Or bIsOk = False)
End If
End If
bIsValid8Dot3Pathname = bIsOk
End Function

'Description: Count # of occurrences of a character in a string.

'Params:(IN) String to search,(IN) Character to look for.

'Returns: # of occurrences.

Function nStrCount(sSource As String, sChar As String) As Integer
Dim nPos As Integer
Dim nCount As Integer
nCount = 0
nPos = InStr(sSource, sChar)
While nPos
nCount = nCount + 1
nPos = InStr(nPos + 1, sSource, sChar)
Wend
nStrCount = nCount
End Function

'Description: Pad a string with a pad char

'Params:(IN) String to pad,

'(IN) Max size of string,

'(IN) Pad character (optional; default =space).

'Returns: Padded string

Function sPad(sSrc As String, nSize As Integer, sPadChar As String) As String
Dim tmpPadChar As String * 1
If (sPadChar <> "") Then
tmpPadChar = sPadChar
Else
tmpPadChar = sDEFAULT_PAD
End If
If Len(sSrc) < nSize Then
sPad = sSrc & String(nSize - Len(sSrc), tmpPadChar)
Else
sPad = sSrc
End If
End Function

'Description: Delete characters from a string

'Params:(IN/OUT) String to delete from,

'(IN) Starting position for delete,

'(IN) Number of characters to delete.

'Modifies: Destination string

Sub StrDelete(sDest As String, nStart As Integer, nCount As Integer)
Dim sLeft As String, sRight As String
Dim nLen As Integer
nLen = Len(sDest)
If nStart >= 0 And nStart <= nLen Then
'Deletion point is valid, OK to continue...

'Isolate the left part

If nStart > 1 And nLen > 0 Then
sLeft = Left(sDest, nStart - 1)
Else
sLeft = ""
End If
'Isolate the right part

If (nStart + nCount) <= nLen Then
sRight = Mid(sDest, nStart + nCount)
Else
sRight = ""
End If
'Put string back together, minus the deleted chars

sDest = sLeft & sRight
End If
End Sub

'Description: Strip null characters from a string.

'This is useful for cleaning up strings returned from Win API calls.

'Params:(IN) String with null characters

'Returns: Converted string

'Assumed: Anything after the 1st null character is not needed

Function sTrimNulls(s) As String
Dim nPos As Integer
nPos = InStr(s, Chr$(0))
Select Case nPos
Case Is > 1
sTrimNulls = Left(s, nPos - 1)
Case 1
sTrimNulls = ""
Case Else
sTrimNulls = s
End Select
End Function

'Description: Insert a substring into atarget string.

'Params:(IN/OUT) Destination string,

'(IN) Substring to insert,

'(IN) Insertion point.

'Returns: True if able to insert; Falseif not

'Modifies: Destination string.

Function StrInsert(sDest As String, sInsert As String, nStart As Integer) As Integer
Dim sLeft As String, sRight As String
Dim nLen As Integer
nLen = Len(sDest)
If nStart >= 0 And nStart <= nLen Then
'Insertion point is valid, OK to continue...

'Isolate the left part

If nStart > 1 And nLen > 0 Then
sLeft = Left(sDest, nStart - 1)
Else
sLeft = ""
End If
'Isolate the right part

sRight = Right(sDest, nLen - nStart + 1)
'Insert the new text

sDest = sLeft & sInsert & sRight
StrInsert = True
Else
StrInsert = False
End If
End Function
Description:
Get token from string; For parsing strings in a
fashion similar to the C strtok() library function.

Params:(IN) String to parse
(Only required for 1st token; subsequent calls should pass "")
(IN) Delimiter character (""=use default; default = ",")
Returns:
String containing token, or "" if no more tokens.

Assumed: If string param <> "",
assumes first token. Otherwise, it is
assumed that the caller is requesting the next token.

Example: Dim sToken as string
sToken = sGetToken("c:\level1\level2\level3", "/" )
Do while ( sToken <> "" )
Debug.Print sToken
sToken = sGetToken( "", "\" )
Loop