aml_func.bas

This sample demonstrates the use of the projection objects ProjCoordSys and GeoCoordSys, and the C

Attribute VB_Name = "aml_func"
'             Environmental Systems Research Institute, Inc.
'Module Name: aml_func.bas
'Description: Used to perform AML-like functions for string manipipulation.
'             Also parses out tokens in a string to elements in an array.
'
'   Requires: ParseString and ParseStringR require that you Dim the named array arg in
'             the calling propgram: Must be a zero dimensioned string array:
'             Dim yourarray() as string

'    Methods: After   - Returns the substring to the right of the leftmost occurrence of
'                       searchStr
'             Before  - Returns the substring to the left of the leftmost occurrence of
'                       searchStr.
'             Extract - Returns an element from a list of elements
'             Index   - Returns the position of the leftmost occurrence of a specified
'                       string in a target string.
'             Keyword - Returns the position of a keyword within a list of keywords.
'             Search  - Returns the position of the first character of a search string
'                       in a target string.
'             Sort    - Returns a sorted a list of elements.
'             Subst   - Returns a string that has had one string subsituted for another
'             Substr  - Returns a substring that starts at a specified character position.
'             Token   - Allows tokens in a list to be manipulated.
'
'                       Count - the number of tokens in a list
'                       Find  - the position of a token in a list
'                       Move  - tokens in a list
'                       Insert- a new token into a list
'                       Delete- a token in a list
'                       Replace-one token in a list for another
'                       Switch -one token in a list for another
'
'        ParseString  - Populates string array with tokens in a string.
'        ParseStringR - Same as ParseString except blanks and commas are
'                       treated as delimiters.
'
'    History: DMA - 03/04/97 - Original coding
'
Option Explicit

Public Sub ParseString(Str As String, StrArray() As String, Delim As String)

' Populates a named string array with elements in a string. Each array element
' contains one word. Multiple words ' within single quotes ' are treated as
' one word. NOTE: Use parseStringR if you want both commas and blanks to be
' treated as delimiting characters.
'
' Before calling this Sub you must declare your array in the calling program
' As String, with no bounds.
'
' Dim myarray() As String
' mystring = "ARC YES, POLY NO, TICS YES"
' parseString (mystring), myarray, ","
' Returns:
' array(0) = ARC YES
' array(1) = POLY NO
' array(2) = TICS YES

' parseString(mystring),myarray," "
' Returns:
' array(0) = ARC
' array(1) = YES,
' array(2) = POLY
' array(3) = NO,
' array(4) = TICS
' array(5) = YES,

' mystring = "'Universe,Medium','Helvetica,Bold','Times,Medium'"
' parsestring(mystring),myarray,","
' Returns:
' array(0) = Universe,Medium
' array(1) = Helvetica,Bold
' array(2) = Times,Medium

' Dim counters

Dim i As Integer
Dim tokenlen As Integer
Dim tmpstr As String
Dim position As Integer
Dim length As Integer

'Dim variables to keep track of embedded quotes

Dim switch As Integer
Dim position1 As Integer
Dim position2 As Integer
Dim pair As Integer

On Error Resume Next

' If string contains no elements raise error
  If Trim(Subst(Str, Delim)) = "" Then
    Err.Raise vbObjectError + errBlankArg, "aml_func.ParseString", _
    "StringPassed"
    Exit Sub
  End If

' intialize array. Warning: This will overwrite any data elements currently
' stored in this named array

  ReDim StrArray(0)

'intializer counters and tracking variables

  pair = False
  switch = 0
  length = Len(Str)
  position = 1
  i = 0
  tmpstr = Str

'check each character in the array. If it is a quote, store if it is first or last
' 0 = havent read one yet
' 1 = read first single quote
' 2 = read second single quote

  Do While position < length
    If Mid(tmpstr, position, 1) = "'" Then
      If Not (switch = 1) Then
        switch = 1
        position1 = position
        pair = False
      Else
        switch = 2
        position2 = position
        pair = True
      End If
    End If

' if last char read was last in a pair of quotes, store contents between first and last
' in current array element and reset tracking variables

    If pair = True Then
      Mid(tmpstr, position1, 1) = " "
      Mid(tmpstr, position2, 1) = " "
      StrArray(i) = Mid(tmpstr, position1, position2 - position1)
      StrArray(i) = Trim(StrArray(i))
      pair = False
      switch = 0
      
' check to see if we are reading till the next single quote. If switch = 0, we are not
' if not check if the next character is a delimiter. if it is store everything to the left
' replace everything to the left of original str with blanks so we can safely use LEFT
' function then trim the blanks

    Else
      If switch = 0 Then
        If Mid(tmpstr, position, 1) = Delim Then
          StrArray(i) = Left(tmpstr, position)
          tokenlen = Len(StrArray(i))
          StrArray(i) = Trim(StrArray(i))
          If Not (Len(StrArray(i)) = 0) Then
            Mid(tmpstr, 1, tokenlen) = String(tokenlen, " ")
            ReDim Preserve StrArray(LBound(StrArray) To UBound(StrArray) + 1)
            i = i + 1
          End If
        End If
      End If
    End If
    position = position + 1
  Loop
  StrArray(i) = Trim(tmpstr)

' we have populated our array, now remove the delimiters from each element

  position = 1
  For i = 0 To UBound(StrArray)
    position = Len(StrArray(i))
    If Mid(StrArray(i), position, 1) = Delim Then
      Mid(StrArray(i), position, 1) = " "
      StrArray(i) = Trim(StrArray(i))
    End If
  Next i
End Sub

Public Function After(Str As String, SearchStr As String) As String
' Returns the substring of Str to the right of the leftmost
' occurrence of the searchStr.
Dim position As Integer
Dim length As Integer

  position = InStr(Str, SearchStr)
  length = Len(SearchStr)
  If Not (position = 0) Then
   After = Mid(Str, position + length)
  End If

End Function

Public Function Before(Str As String, SearchStr As String) As String
' Returns the substring of Str to the left of the leftmost
' occurrence of the searchStr.
Dim position As Integer
Dim length As Integer

  position = InStr(Str, SearchStr)
  length = Len(SearchStr)
  If Not (position = 0) Then
   Before = Mid(Str, 1, position - 1)
  End If

End Function

Public Function Extract(ElemNum As Integer, ElemList As String) As String
' extracts an element from a list of elements

Dim StrArray() As String

  ParseStringR (ElemList), StrArray
  If ElemNum > UBound(StrArray) + 1 Then
   Exit Function
  End If
  
  If ElemNum = 0 Then
   Exit Function
  End If
  Extract = StrArray(ElemNum - 1)

End Function

Public Function Index(Str As String, SearchStr As String) As Integer
' Returns the position of the leftmost occurrence of searcStr in str.

  Index = InStr(Str, SearchStr)

End Function

Public Sub ParseStringR(Str As String, StrArray() As String, Optional ReturnQuoted)

' Populates a named string arrary with elements in a string. Each array element
' contains one word. Multiple words ' within single quotes ' are treated as
' one word. Treats both blanks and commas as delimters NOTE: Use parseString
' to specify a specific delimiting character.

' ReturnQuoted - indicates if elements are to be returned quoted.
' FALSE - DEFAULT return elements unquoted
' TRUE - return elements quoted

' Before calling this function you must declare your array in the calling program
' As String, with no bounds.
'
' Dim myarray() As String
' mystring = "ARC YES, POLY NO, TICS YES"
' parseStringR(mystring),myarray

' Returns:
' array(0) = ARC
' array(1) = YES
' array(2) = POLY
' array(3) = NO
' array(4) = TICS
' array(5) = YES

' mystring = "'Universe,Medium','Helvetica,Bold','Times,Medium'"

' parsestringR(mystring),myarray
' Returns:
' array(0) = Universe,Medium
' array(1) = Helvetica,Bold
' array(2) = Times,Medium

' parsestring(mystring,myarray,TRUE)
' Returns:
' array(0) = 'Universe,Medium'
' array(1) = 'Helvetica,Bold'
' array(2) = 'Times,Medium'

' Dim counters

Dim i As Integer
Dim tokenlen As Integer
Dim switch As Integer
Dim position1 As Integer
Dim position2 As Integer
Dim pair As Integer
Dim parseAgain As Boolean
Dim tmpstr As String
Dim position As Integer
Dim length As Integer

On Error Resume Next

' If string contains no elements raise error
  If Trim(Subst(Str, ",")) = "" Then
    Err.Raise vbObjectError + errBlankArg, "aml_func.ParseStringR", _
    "StringPassed"
    Exit Sub
  End If

' intialize counters and tracking variables
  ReDim StrArray(0)
  pair = False
  switch = 0
  length = Len(Str)
  position = 1
  i = 0
  tmpstr = Str

  If IsMissing(ReturnQuoted) Then
    ReturnQuoted = False
  End If
  If Not (ReturnQuoted = False) Then
    ReturnQuoted = True
  End If

' check each character in the array. If it is a quote, store if it is first or last
' 0 = havent read one yet
' 1 = read first single quote
' 2 = just read second single quote

  Do While position < length
    If Mid(tmpstr, position, 1) = "'" Then
      If Not (switch = 1) Then
      switch = 1
      position1 = position
      pair = False
    Else
      switch = 2
      position2 = position
      pair = True
      End If
    End If
     
' if last char read was last in a pair of single quotes, store contents between first
' and last in current array element and reset tracking variables
 
    If pair = True Then
      Mid(tmpstr, position1, 1) = " "
      Mid(tmpstr, position2, 1) = " "
      StrArray(i) = Mid(tmpstr, position1, position2 - position1)
      StrArray(i) = Trim(StrArray(i))
      pair = False
      switch = 0
    
' check to see if we are reading till the next single quote. If switch = 0, we are not
' if not check if the next character is a delimiter. if it is store everything to the left
' replace everything to the left of original str with blanks so we can safely use LEFT
' function then trim the blanks
  
    Else
      If switch = 0 Then
        If Mid(tmpstr, position, 1) = "," Or Mid(tmpstr, position, 1) = " " Then
          StrArray(i) = Left(tmpstr, position)
          tokenlen = Len(StrArray(i))
          StrArray(i) = Trim(StrArray(i))
          If Not (Len(StrArray(i)) = 0) Then
            Mid(tmpstr, 1, tokenlen) = String(tokenlen, " ")
            ReDim Preserve StrArray(LBound(StrArray) To UBound(StrArray) + 1)
            i = i + 1
          End If
        End If
      End If
    End If
    position = position + 1
  Loop
    StrArray(i) = Trim(tmpstr)

' we have populated our array, now remove the delimiters from each element
' set parseAgain flag if there are any blank elements

  parseAgain = False
  position = 1

  For i = 0 To UBound(StrArray)
    position = Len(StrArray(i))
    If Mid(StrArray(i), position, 1) = "," Then
      Mid(StrArray(i), position, 1) = " "
      StrArray(i) = Trim(StrArray(i))
      If Len(StrArray(i)) = 0 Then
        parseAgain = True
      End If
    End If