Attribute VB_Name = "modDmsFormat"
' ---------------------------------------------------------------------------
'
' DMSFormat
'
' Convert decimal value into degree, minutes and seconds representation
' (string) suitable for output, according to pattern string.
'
' Parameters:
'    dblVal As Double          -- the decimal degree value to be converted
'    strPattern As String      -- formatting pattern - see below
'    blnIsLatitude As Boolean  -- True if value is latitude
'    blnForceDp                -- pass True to force decimal point instead
'                                 of comma
'
' Return value:
'    String - the converted representation according to the format
'
' The following placeholders are recognized and replaced in the
' pattern string:
'
'    <Cp> : compass point
'    <Di> : integer degrees
'    <Dd> : decimal degrees
'    <Mi> : integer minutes
'    <Md> : decimal minutes
'    <Si> : integer seconds
'    <Sd> : decimal seconds
'    <lt> : escape sequence for the '<' character
'    <gt> : escape sequence for the '>' character
'
' In addition, a format specification may be added to all of the above -
' best illustrated with an example:
'
' <Dd=##0.#####:-10> specifies that decimal degrees should be output with
' (max) three digits before, and five after the decimal point or comma, left-justified
' in a field with a total number of 10 characters.
'
' More details are available in external documentation
'
'   Author: Gilles Kohl
'   (gilles@_deletewithunderscores_compuserve.com)
'   Please take questions to email only if you feel you need to
'   contact me in private, otherwise, news:public.microsoft.mappoint is
'   preferred.
'
'   This code is copyrighted freeware - use freely, but please leave this
'   header intact. Suggestions and comments welcome.
'
' ---------------------------------------------------------------------------
Option Explicit

' Utility function - loop up string in collection,
' return default value if not available
Private Function strLookUp(colCollection As Collection, strKey As String, _
                           strNA As String) As String
   strLookUp = strNA
   On Error Resume Next
   strLookUp = colCollection(strKey)
End Function

' Utility function - loop up double in collection,
' return default value if not available
Private Function dblLookUp(colCollection As Collection, strKey As String, _
                           dblNA As Double) As Double
   dblLookUp = dblNA
   On Error Resume Next
   dblLookUp = colCollection(strKey)
End Function

' Utility function - Initialize collections
' used for field data and format storage
Private Sub SetupCollections(ByVal dblVal As Double, _
                             colValues As Collection, _
                             colFormats As Collection, _
                             blnIsLatitude As Boolean)
   ' Compute various fields, fill
   ' collections with potential replacements
   Dim intTmp As Integer
   intTmp = 1
   
   ' Compute compass point index, get rid
   ' of dblVal sign
   If dblVal < 0 Then
      intTmp = IIf(blnIsLatitude, 2, 0)
      dblVal = -dblVal
   Else
      intTmp = IIf(blnIsLatitude, 3, 1)
   End If
   
   ' add compass point
   colValues.Add intTmp, "Cp"
   colFormats.Add "W|E|S|N", "Cp"
   
   ' Compute and add integer degrees
   intTmp = Int(dblVal)
   colValues.Add intTmp, "Di"
   colFormats.Add "##0", "Di"
   
   ' Compute and add decimal degrees
   colValues.Add dblVal, "Dd"
   colFormats.Add "##0.0####", "Dd"
      
   ' Compute and add integer minutes
   Dim dblTmp As Double
   dblTmp = (dblVal - intTmp) * 60
   intTmp = Int(dblTmp)
   colValues.Add intTmp, "Mi"
   colFormats.Add "#0", "Mi"
   
   ' Compute and add decimal minutes
   colValues.Add dblTmp, "Md"
   colFormats.Add "#0.0##", "Md"
   
   ' Compute and add integer seconds
   dblTmp = (dblTmp - intTmp) * 60
   intTmp = Int(dblTmp)
   colValues.Add intTmp, "Si"
   colFormats.Add "#0", "Si"
   
   ' Compute and add decimal seconds
   colValues.Add dblTmp, "Sd"
   colFormats.Add "#0.0", "Sd"
End Sub

' The actual working horse
Public Function DmsFormat(dblVal As Double, strPattern As String, _
                          blnIsLatitude As Boolean, _
                          blnForceDp As Boolean) As String
   Dim colValues As New Collection
   Dim colFormats As New Collection
   
   ' Compute fields, init collections
   SetupCollections dblVal, colValues, colFormats, blnIsLatitude
         
   Dim strRes As String ' resulting string
   Dim nCurPos As Integer ' scan position
   Dim nLen As Integer ' pattern string length
   
   strRes = ""
   nLen = Len(strPattern)
   nCurPos = 1
   
   ' scan pattern, building result string
   Do While nCurPos <= nLen
      Dim nPosLt As Integer ' current less-than
      Dim nPosGt As Integer ' current greater-than
      
      ' Find next Less-than and Greater-than
      nPosLt = InStr(nCurPos, strPattern, "<")
      nPosGt = IIf(nPosLt = 0, 0, InStr(nPosLt + 1, strPattern, ">"))
      
      If nPosLt = 0 Or nPosGt = 0 Then
         ' no more '<' found, or '<' without '>' -
         ' in these cases, we're done
         ' add remainder to result
         strRes = strRes & Mid$(strPattern, nCurPos)
         
         ' set current position to string end
         nCurPos = nLen + 1
         Exit Do ' exit the loop
      End If

      ' Add anything preceding the '<' as-is to result
      strRes = strRes & Mid$(strPattern, nCurPos, nPosLt - nCurPos)
      
      If nPosGt - nPosLt < 3 Then
         ' Invalid sequence, add as-is, continue
         strRes = strRes & Mid$(strPattern, nPosLt, nPosGt - nPosLt + 1)
         nCurPos = nPosGt + 1
         ' VB doesn't have a continue statement
         ' emulate with GoTo
         GoTo Continue
      End If

      ' Retrieve the field or formatting command
      Dim strField As String
      strField = Mid$(strPattern, nPosLt + 1, 2)
      
      Dim strFormat As String
      
      ' Is there an assignment ?
      If Mid$(strPattern, nPosLt + 3, 1) = "=" Then
         ' yes - retrieve format string
         strFormat = Mid$(strPattern, nPosLt + 4, nPosGt - nPosLt - 4)
      Else
         ' no - get its initial value otherwise
         strFormat = strLookUp(colFormats, strField, "")
      End If
      
      Dim strFmtParts() As String
      Dim nWidth As Integer
      
      ' assume no width
      nWidth = 0
      
      ' split into actual format and width
      strFmtParts = Split(strFormat, ":")
      If UBound(strFmtParts) > 0 Then
         ' we have a width, reassign format
         strFormat = strFmtParts(0)
         nWidth = Val(strFmtParts(1))
      End If
      
      Dim strFormattedField
      strFormattedField = ""
      
      Select Case UCase$(strField)
         ' Handle special cases
         Case "CP": ' compass point
            Dim strCp() As String
            strCp = Split(strFormat, "|")
            If UBound(strCp) = 3 Then
               strFormattedField = strCp(dblLookUp(colValues, "Cp", 0))
            End If
         Case "LT": ' Literal '<'
            strFormattedField = "<"
         Case "GT": ' Literal '>'
            strFormattedField = ">"
         Case Else ' Collection items
            Dim dblTheValue
            
            ' Get value corresponding to field
            dblTheValue = dblLookUp(colValues, strField, 99.99)
            If strFormat = "" Then
               strFormat = strLookUp(colFormats, strField, "")
            End If
            strFormattedField = Format(dblTheValue, strFormat)
            If blnForceDp Then
               ' replace comma with decimal field if requested
               strFormattedField = Replace(strFormattedField, _
                                           ",", ".")
            End If
      End Select
            
      ' If there a non-zero width, right-pad or left-pad
      ' with spaces according to sign
      If nWidth <> 0 Then
         strFormattedField = IIf(nWidth > 0, _
            Right$(Space$(Abs(nWidth)) & strFormattedField, Abs(nWidth)), _
            Left$(strFormattedField & Space$(Abs(nWidth)), Abs(nWidth)))
      ' If you're wondering why Abs() is being used in the two cases,
      ' Vb seems to evaluate the two expressions first, then selects
      ' which one to use.
      End If
      
      ' add formatted field to result string
      strRes = strRes & strFormattedField
      
      ' move pointer beyond ">"
      nCurPos = nPosGt + 1
      
Continue:
   Loop
   
   DmsFormat = strRes
End Function