Chip 1999 August/Chip_1999-08_cd.bin/zkuste/VBasic/Data/Priklady/basstr.Bas

BASIC Source File | 1999-05-13 | 6KB | 263 lines

Attribute VB_Name = "basString"
Option Explicit

Private Declare Function IsCharAlpha Lib "user32" Alias "IsCharAlphaA" (ByVal cChar As Byte) As Long
Private Declare Function IsCharAlphaNumeric Lib "user32" Alias "IsCharAlphaNumericA" (ByVal cChar As Byte) As Long

'Funkce vracφ slovo z °et∞zce
'Parametry:  s     - vstupnφ °etezec
'            token -odd∞lovaΦ
'            Nth   - kterß Φßst °et∞zce
'P°φklad: tmp=GetWord("Visual Basic verze 5.0", " ", 3)   ="verze"
Public Function GetToken(s As String, token As String, ByVal Nth As Integer) As String
   Dim i As Integer
   Dim p As Integer
   Dim r As Integer

   If Nth < 1 Then
      GetToken = ""
      Exit Function
   End If

   r = 0

   For i = 1 To Nth
      p = r
      r = InStr(p + 1, s, token)
      If r = 0 Then
         If i = Nth Then
            GetToken = Mid$(s, p + 1, Len(s) - p)
         Else
            GetToken = ""
         End If
         Exit Function
      End If
   Next i

   GetToken = Mid$(s, p + 1, r - p - 1)
End Function

'Funkce vracφ vytvo°enΘ pole z °et∞zce
'Parametry: sTxt   - vstupnφ °et∞zec
'           sToken -odd∞lovaΦ
Public Function GetTokens(sTxt As String, sToken As String) As Variant
    Dim iTokenLen As Integer
    Dim iTokenCnt As Integer
    Dim lOffset As Long
    Dim lPrevOffset As Long
    Dim aTokens() As String

    iTokenLen = Len(sToken)
    lOffset = InStr(sTxt, sToken)

    Do While lOffset > 0
        ReDim Preserve aTokens(iTokenCnt)
        If lOffset - lPrevOffset > 1 Then
            aTokens(iTokenCnt) = Mid$(sTxt, lPrevOffset + 1, lOffset - 1 - lPrevOffset)
        Else
            aTokens(iTokenCnt) = ""
        End If

        lPrevOffset = lOffset
        lOffset = InStr(lOffset + iTokenLen, sTxt, sToken)
        iTokenCnt = iTokenCnt + 1
    Loop

    ReDim Preserve aTokens(iTokenCnt)
    aTokens(iTokenCnt) = Mid$(sTxt, lPrevOffset + 1)
    GetTokens = CVar(aTokens)
End Function

'Konvertuje double do stringu - cisla za desetinnou carkou jsou ignorovana
Function Int2String(ByVal l As Double) As String
   Dim tmp As String
   Dim str As String
   Dim i As Integer
   Dim j As Integer

   tmp = Format(l, "000000000000")
   str = ""

   If Len(tmp) > 12 Then
      Int2String = ""
      Exit Function
   End If

   If Val(tmp) = 0 Then
      Int2String = "zero"
      Exit Function
   End If

   i = Val(Left$(tmp, 3))
   If i <> 0 Then
      GoSub do_hundreds
      str = str + " trillion"
   End If

   i = Val(Mid$(tmp, 4, 3))
   If i <> 0 Then
      GoSub do_hundreds
      str = str + " million"
   End If

   i = Val(Mid$(tmp, 7, 3))
   If i <> 0 Then
      GoSub do_hundreds
      str = str + " thousand"
   End If

   i = Val(Right$(tmp, 3))
   If i <> 0 Then
      GoSub do_hundreds
   End If

   Int2String = str
   Exit Function

do_hundreds:
   If i > 99 Then
      j = i
      i = i \ 100
      GoSub do_ones
      str = str + " hundred"
      i = j Mod 100
   End If

   If i <> 0 Then
      GoSub do_tens
   End If
   Return

do_tens:
   Select Case i Mod 100
      Case 90 To 99:
         str = str + " ninety"
         GoSub do_ones
      Case 80 To 89:
         str = str + " eighty"
         GoSub do_ones
      Case 70 To 79:
         str = str + " seventy"
         GoSub do_ones
      Case 60 To 69:
         str = str + " sixty"
         GoSub do_ones
      Case 50 To 59:
         str = str + " fifty"
         GoSub do_ones
      Case 40 To 49:
         str = str + " fourty"
         GoSub do_ones
      Case 30 To 39:
         str = str + " thirty"
         GoSub do_ones
      Case 20 To 29:
         str = str + " twenty"
         GoSub do_ones

      Case 19: str = str + " nineteen"
      Case 18: str = str + " eighteen"
      Case 17: str = str + " seventeen"
      Case 16: str = str + " sixteen"
      Case 15: str = str + " fifteen"
      Case 14: str = str + " fourteen"
      Case 13: str = str + " thirteen"
      Case 12: str = str + " twelve"
      Case 11: str = str + " eleven"
      Case 10: str = str + " ten"

      Case Else
         GoSub do_ones
   End Select
   Return


do_ones:
   If i < 10 Or i Mod 10 = 0 Then
      str = str + " "
   Else
      str = str + "-"
   End If

   Select Case i Mod 10
      Case 9: str = str + "nine"
      Case 8: str = str + "eight"
      Case 7: str = str + "seven"
      Case 6: str = str + "six"
      Case 5: str = str + "five"
      Case 4: str = str + "four"
      Case 3: str = str + "three"
      Case 2: str = str + "two"
      Case 1: str = str + "one"
   End Select

   Return
End Function

'Vraci 0 pokud je string slozen z pismen, jinak vraci
'pozici chybneho znaku
Public Function IsStringAlpha(s As String) As Long
   Dim i As Long

   For i = 1 To Len(s)
      If IsCharAlpha(Asc(Mid$(s, i, 1))) = 0 Then
         IsStringAlpha = i
         Exit Function
      End If
   Next i

   IsStringAlpha = 0
End Function

'Vraci 0 pokud je string slozen z pismen a cislic
'v opacnem pripade vraci pozici chybneho znaku
Public Function IsStringAlphaNumeric(s As String) As Long
   Dim i As Long

   For i = 1 To Len(s)
      If IsCharAlphaNumeric(Asc(Mid$(s, i, 1))) = 0 Then
         IsStringAlphaNumeric = i
         Exit Function
      End If
   Next i

   IsStringAlphaNumeric = 0
End Function

'Vraci 0 je-li string slozen jen z pismen
'v opacnem pripade vraci pozici chybneho znaku
Public Function IsStringNumeric(s As String) As Long
   Dim i As Long
   Dim j As Byte

   For i = 1 To Len(s)
      j = Asc(Mid$(s, i, 1))
      If IsCharAlphaNumeric(j) = 1 Then
         If IsCharAlpha(j) = 1 Then
            IsStringNumeric = i
            Exit Function
         End If
      Else
         IsStringNumeric = i
         Exit Function
      End If
   Next i

   IsStringNumeric = 0
End Function

'Zrusi ze stringu znaky vracene ze systemovych funkci, napr. asc=0
Public Function STrim(s As String) As String
   Dim i As Integer
   Dim s2 As String

   s2 = Trim(s)
   i = InStr(s2, Chr$(0))

   If i > 0 Then
      s2 = Left$(s2, i - 1)
   End If

   STrim = s2
End Function