aml_func.bas

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

  Next i
  
' now remove any blank elements
  
  If parseAgain = True Then
    tmpstr = ""
    For i = 0 To UBound(StrArray)
      If Not (Len(StrArray(i))) = 0 Then
        tmpstr = tmpstr & "'" & StrArray(i) & "'" & ","
      End If
    Next i
    ParseString (tmpstr), StrArray, ","
  End If
      
  If ReturnQuoted = True Then
    For i = 0 To UBound(StrArray)
     StrArray(i) = "'" & StrArray(i) & "'"
    Next i
  End If

End Sub

Public Function Keyword(Str As String, SearchStr As String) As Integer
' Returns the position of a string within a list of keywords.
' converts Str and searchStr to upper case before comparing
'  0  if keyword not found
' -1  if string is ambiguous - mutiple occurances of same keyword
'  n  position of keyword in string

Dim StrArray() As String
Dim i As Integer
Dim keywordCnt As Integer

  ParseStringR (Str), StrArray
  keywordCnt = 0
    For i = 0 To UBound(StrArray)
    If UCase(SearchStr) = UCase(StrArray(i)) Then
      Keyword = i + 1
      keywordCnt = keywordCnt + 1
    End If
    Next i
  
  If keywordCnt > 1 Then
    Keyword = -1
  End If

End Function

Public Function Search(Str, SearchStr) As Integer
' Returns the position of the first character in Str
' which occurs in searchStr.

Dim StrArray() As String
Dim i As Integer
Dim Index As Integer
Dim firstchar
Dim InString As Boolean

  Index = 1
  ReDim StrArray(Len(Str))

  For i = 0 To Len(SearchStr) - 1
    firstchar = Mid(SearchStr, i + 1, 1)
    Index = InStr(Str, firstchar)
    StrArray(Index) = i + 1
  Next i
  
  InString = False
  
  For i = 1 To UBound(StrArray)
    If Not (StrArray(i)) = "" Then
    InString = True
    Exit For
    Else
    End If
  Next i
  
  If InString = False Then
    Search = 0
  Else
    Search = i
  End If

End Function

Public Function Sort(Str As String, Optional SortOption, Optional SortType) As String
' Returns a string of sorted elements

  If IsMissing(SortOption) Then
    SortOption = "-ASCEND"
  ElseIf Not (UCase(SortOption) = "-DESCEND") Then
    SortOption = "-ASCEND"
  End If
  
  If IsMissing(SortType) Then
    SortType = "-CHARACTER"
  ElseIf Not (UCase(SortType) = "-NUMERIC") Then
    SortType = "-CHARACTER"
  End If
  
  If (UCase(SortType)) = "-NUMERIC" Then
    Call Sort_Num(Str, SortOption)
  Else
    Call Sort_Char(Str, SortOption, True)
  End If
    Sort = Str
  End Function

Private Function Sort_Num(Str As String, SortOption) As String

' Sort function - performs a numerical sort
' Ref: Selectionsort Chapter8 of VB Algorithms; Rod Stephens

Dim i As Integer
Dim j As Integer
Dim min As Integer
Dim max As Integer
Dim best_value As String
Dim best_j As Integer
Dim sortArray() As String
Dim sorted As String

  ParseStringR (Str), sortArray
  
  min = LBound(sortArray)
  max = UBound(sortArray)
  
  For i = min To max - 1
    best_value = sortArray(i)
    best_j = i
    
    For j = i + 1 To max
      If Val(sortArray(j)) < Val(best_value) Then
        best_value = sortArray(j)
        best_j = j
      End If
    Next j
      
    sortArray(best_j) = sortArray(i)
    sortArray(i) = best_value
  Next i
    
  If UCase(SortOption) = "-DESCEND" Then
    For i = max To min Step -1
      sorted = sorted & sortArray(i) & ","
    Next i
  Else
    For i = min To max
      sorted = sorted & sortArray(i) & ","
    Next i
  End If
  
  Mid(sorted, Len(sorted), 1) = " "
  Str = sorted
  Sort_Num = sorted
End Function

Private Function Sort_Char(Str As String, SortOption, Optional ReturnQuoted) As String

' Sort function - performs a character sort
' Ref: Selectionsort Chapter8 of VB Algorithms; Rod Stephens

Dim i As Integer
Dim j As Integer
Dim min As Integer
Dim max As Integer
Dim best_value As String
Dim best_j As Integer
Dim sortArray() As String
Dim sorted As String

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

ParseStringR (Str), sortArray, ReturnQuoted

min = LBound(sortArray)
max = UBound(sortArray)

  For i = min To max - 1
    best_value = sortArray(i)
    best_j = i
    
    For j = i + 1 To max
      If sortArray(j) < best_value Then
      best_value = sortArray(j)
      best_j = j
      End If
    Next j
    
    sortArray(best_j) = sortArray(i)
    sortArray(i) = best_value
  Next i
  
  If UCase(SortOption) = "-DESCEND" Then
    For i = max To min Step -1
      sorted = sorted & sortArray(i) & " "
    Next i
  Else
    For i = min To max
      sorted = sorted & sortArray(i) & " "
    Next i
  End If
  Mid(sorted, Len(sorted), 1) = " "
  
  Str = sorted
  Sort_Char = sorted
End Function

Public Function Subst(Str As String, SearchChar As String, Optional ReplaceChar) As String

' Replaces all occurances of specified char in string.

Dim complete As Boolean
Dim i As Integer
Dim first As String
Dim last As String
Dim tmpstr As String
Dim position As Integer

tmpstr = Str

position = 1
complete = False

If IsMissing(ReplaceChar) Then
  Do Until complete = True
    position = InStr(position, tmpstr, SearchChar)
    If position = 0 Or position > Len(tmpstr) Then
      complete = True
    Else
      first = Before(tmpstr, SearchChar)
      last = After(tmpstr, SearchChar)
      tmpstr = first & last
    End If
  Loop
End If

Do Until complete = True
  position = InStr(position, tmpstr, SearchChar)
  If position = 0 Or position > Len(tmpstr) Then
    complete = True
  Else
    Mid(tmpstr, position, Len(ReplaceChar)) = ReplaceChar
    position = position + Len(ReplaceChar)
  End If
Loop

Subst = tmpstr

End Function

Public Function Substr(Str As String, position As Integer, Optional NumChars) As String
'extracts a substring starting at a specified character position.

If IsMissing(NumChars) Then
  If position = 0 Or position > Len(Str) Then
    Substr = ""
  Else
    Substr = Mid(Str, position)
  End If
Else
  If position = 0 Or position > Len(Str) Then
    Substr = ""
  Else
   Substr = Mid(Str, position, NumChars)
  End If
End If

End Function

Public Function Token(ElemList As String, Arg As String, ParamArray OtherArgs()) As Variant
' Performs various functions for string manipulation

Dim StrArray() As String
Dim i As Integer
Dim temp As String
Dim from_elem  As Integer
Dim to_elem As Integer
Dim start_elem As Integer
Dim insertStr As String
Dim Delete As Integer
Dim SearchStr As String

' Parse ElemList out to strarray
' Select TOKEN argument and perform function

  ParseStringR (ElemList), StrArray
  Arg = Subst(Arg, "-")
  
  Select Case UCase(Arg)

  ' Count - returns the number of tokens in a list
    Case "COUNT"
      Token = UBound(StrArray) + 1
    
  ' Find <token> - returns the position of a token in a list
    Case "FIND"
      SearchStr = OtherArgs(0)
      Token = 0
      For i = 0 To UBound(StrArray)
        If UCase(SearchStr) = UCase(StrArray(i)) Then
          Token = i + 1
        End If
      Next i
    
  ' Move <from_position> <to_position> - moves a token in the list
    Case "MOVE"
      from_elem = OtherArgs(0) - 1
      to_elem = OtherArgs(1)
      temp = StrArray(to_elem)
      StrArray(to_elem) = StrArray(from_elem)
      For i = from_elem To to_elem - 1
        StrArray(i) = StrArray(i + 1)
        Next i
         StrArray(i) = temp
      For i = 0 To UBound(StrArray) - 1
        Token = Token & StrArray(i) & ","
      Next i
    
  ' Insert <position> - inserts a new token at <position> in the list
    Case "INSERT"
      ReDim Preserve StrArray(UBound(StrArray) + 1)
      start_elem = OtherArgs(0) - 1
      insertStr = OtherArgs(1)
      For i = UBound(StrArray) To start_elem Step -1
        StrArray(i) = StrArray(i - 1)
        Next i
        StrArray(start_elem) = insertStr
        For i = 0 To UBound(StrArray) - 1
        Token = Token & StrArray(i) & ","
      Next i
    
  ' Delete <position> - removes the token at <position> from the list.
    Case "DELETE"
      Delete = OtherArgs(0) - 1
      For i = Delete To UBound(StrArray) - 1
        StrArray(i) = StrArray(i + 1)
      Next i
      For i = 0 To UBound(StrArray) - 1
        Token = Token & StrArray(i) & ","
      Next i
    
  ' Replace <position> <new_string> - replaces the token at <position> with the
  ' <new_string>.
    Case "REPLACE"
      StrArray(OtherArgs(1) - 1) = OtherArgs(0)
      For i = 0 To UBound(StrArray)
        Token = Token & StrArray(i) & ","
      Next i
    
  ' Switch <position_1> <position_2> - moves token at <position_1> to <position_2> and moves
  ' token at <position_2> to <position_1>.
    Case "SWITCH"
      from_elem = OtherArgs(0) - 1
      to_elem = OtherArgs(1) - 1
      temp = StrArray(to_elem)
      StrArray(to_elem) = StrArray(from_elem)
      StrArray(from_elem) = temp
      For i = 0 To UBound(StrArray)
        Token = Token & StrArray(i) & ","
      Next i
    
    Case Else
  End Select
End Function