Foro de elhacker.net

Option Explicit
Private sw As cls_NumSpanishWord

Private Sub cmd_Click()
    Set sw = New cls_NumSpanishWord
    tletras = sw.ConvertCurrencyToSpanish(txt, "Quetzales")
    Set sw = Nothing
End Sub

Private Sub Command1_Click()
End
End Sub

Private Sub Command2_Click()
txt.Text = ""
tletras.Text = ""
txt.SetFocus
End Sub

DefLng A-Z
Option Explicit

Public Const Void As String = ""
Public Const Dot  As String = "."

'//String utility
Public Sub ReplaceStringFrom(s As String, OldWrd As String, NewWrd As String, ptr)
    s = Left$(s, ptr - 1) + NewWrd + Mid$(s, Len(OldWrd) + ptr)
End Sub

'//String utility
Public Sub ReplaceAll(s As String, OldWrd As String, NewWrd As String)
    Dim ptr
    Do
       ptr = InStr(s, OldWrd)
       If ptr Then
          s = Left$(s, ptr - 1) + NewWrd + Mid$(s, Len(OldWrd) + ptr)
       End If
    Loop Until ptr = 0
End Sub

'//String utility
Public Function Singular(s As String) As String
    If Len(s) >= 2 Then
       If Right$(s, 1) = "s" Then
          If Right$(s, 2) = "es" Then
             Singular = Left$(s, Len(s) - 2)
          Else
             Singular = Left$(s, Len(s) - 1)
          End If
       Else
          Singular = s
       End If
    End If
End Function

DefLng A-Z
Option Explicit

'//PROPERTY: m_FeminineGenerous
Private m_FeminineGenerous As Boolean

Public Function ConvertCurrencyToSpanish( _
    ByVal Number As Variant, _
    ByVal CurrentMoney As Variant, _
    Optional FeminineGenerous As Variant = False _
    ) As String
    Dim s            As String
    Dim DecimalPlace As Long
    Dim IntPart      As String
    Dim Cents        As String

    m_FeminineGenerous = FeminineGenerous
    s = Format(Val(Number), "0.00")
    DecimalPlace = InStr(s, Dot)
   
    If DecimalPlace Then
       IntPart = Left$(s, DecimalPlace - 1)
       Cents = Left$(Mid$(s, DecimalPlace + 1, 2), 2)
    Else
       IntPart = s
       Cents = Void
    End If

    If IntPart = "0" Or IntPart = Void Then
       s = "Cero "
    ElseIf Len(IntPart) > 7 Then
       s = IntNumToSpanish(Val(Left$(IntPart, Len(IntPart) - 6))) + _
           "Millones " + IntNumToSpanish(Val(Right$(IntPart, 6)))
    Else
       s = IntNumToSpanish(Val(IntPart))
    End If

    If Right$(s, 9) = "Millones " Or Right$(s, 7) = "Millón " Then
       s = s + "de "
    End If
    Select Case s
        Case "Un ", "Una "
            s = s & Singular(CStr(CurrentMoney))
        Case Else
            s = s & CurrentMoney
    End Select

    If Val(Cents) Then
       Cents = " con " + IntNumToSpanish(Val(Cents)) + "Centavos"
    Else
       Cents = " con Cero Centavos"
    End If

    ConvertCurrencyToSpanish = s + Cents
End Function

Public Function IntNumToSpanish(numero As Long) As String
    Dim ptr
    Dim n
    Dim i
    Dim s   As String
    Dim rtn As String
    Dim tem As String
   
    s = CStr(numero)
    n = Len(s)

    tem = Void
    i = n
    Do Until i = 0
       tem = EvalPart(Val(Mid$(s, n - i + 1, 1) + String$(i - 1, "0")))
       If Not tem = "Cero" Then
          rtn = rtn + tem + " "
       End If
       i = i - 1
    Loop
    
    '//Filters
    GoSub filterThousands
    GoSub filterHundreds
    GoSub filterMisc
    GoSub filterOne
    GoSub addAnd
  
    IntNumToSpanish$ = rtn
Exit Function

filterThousands:
  ReplaceAll rtn, " Mil Mil", " Un Mil"
  Do
     ptr = InStr(rtn, "Mil ")
     If ptr Then
        If InStr(ptr + 1, rtn, "Mil ") Then
           ReplaceStringFrom rtn, "Mil ", "", ptr
        Else: Exit Do
        End If
     Else: Exit Do
     End If
  Loop
Return

filterHundreds:
  ptr = 0
  Do
     ptr = InStr(ptr + 1, rtn, "Cien ")
     If ptr Then
        tem = Left$(Mid$(rtn, ptr + 5), 1)
        If tem = "M" Or tem = Void Then
        Else
           ReplaceStringFrom rtn, "Cien", "Ciento", ptr
        End If
     End If
  Loop Until ptr = 0
Return

filterMisc:
  ReplaceAll rtn, "Diez Un", "Once"
  ReplaceAll rtn, "Diez Dos", "Doce"
  ReplaceAll rtn, "Diez Tres", "Trece"
  ReplaceAll rtn, "Diez Cuatro", "Catorce"
  ReplaceAll rtn, "Diez Cinco", "Quince"
  ReplaceAll rtn, "Diez Seis", "Dieciseis"
  ReplaceAll rtn, "Diez Siete", "Diecisiete"
  ReplaceAll rtn, "Diez Ocho", "Dieciocho"
  ReplaceAll rtn, "Diez Nueve", "Diecinueve"
  ReplaceAll rtn, "Veinte Un", "Veintiun"
  ReplaceAll rtn, "Veinte Dos", "Veintidos"
  ReplaceAll rtn, "Veinte Tres", "Veintitres"
  ReplaceAll rtn, "Veinte Cuatro", "Veinticuatro"
  ReplaceAll rtn, "Veinte Cinco", "Veinticinco"
  ReplaceAll rtn, "Veinte Seis", "Veintiseís"
  ReplaceAll rtn, "Veinte Siete", "Veintisiete"
  ReplaceAll rtn, "Veinte Ocho", "Veintiocho"
  ReplaceAll rtn, "Veinte Nueve", "Veintinueve"
Return

filterOne:
  If Left$(rtn, 1) = "M" Then
     rtn = "Un " + rtn
  End If
  '//Un Mil...
  If Left$(rtn, 6) = "Un Mil" Then
     rtn = Mid$(rtn, 4)
  End If
Return

addAnd:
  For i = 65 To 88
      If Not i = 77 Then
         ReplaceAll rtn, "a " + Chr$(i), "* y " + Chr$(i)
      End If
  Next
  ReplaceAll rtn, "*", "a"
Return

End Function

Private Function EvalPart(x As Long) As String
    Dim rtn As String, s As String, i
    Do
       GoSub SinglePart
       If s = Void Then
          i = i + 1
          x = x / 1000
          If x = 0 Then i = 0
       Else
         Exit Do
       End If
    Loop Until i = 0
   
    rtn = s
    GoSub EngPart
   
    EvalPart = rtn + s
Exit Function

SinglePart:
    Select Case x
           Case 0:  s = "Cero"
           Case 1:  s = "Un"
           Case 2:  s = "Dos"
           Case 3:  s = "Tres"
           Case 4:  s = "Cuatro"
           Case 5:  s = "Cinco"
           Case 6:  s = "Seis"
           Case 7:  s = "Siete"
           Case 8:  s = "Ocho"
           Case 9:  s = "Nueve"
           Case 10: s = "Diez"
           Case 20: s = "Veinte"
           Case 30: s = "Treinta"
           Case 40: s = "Cuarenta"
           Case 50: s = "Cincuenta"
           Case 60: s = "Sesenta"
           Case 70: s = "Setenta"
           Case 80: s = "Ochenta"
           Case 90: s = "Noventa"
           Case 100: s = "Cien"
           Case 200: s = "Doscientos"
           Case 300: s = "Trescientos"
           Case 400: s = "Cuatrocientos"
           Case 500: s = "Quinientos"
           Case 600: s = "Seiscientos"
           Case 700: s = "Setecientos"
           Case 800: s = "Ochocientos"
           Case 900: s = "Novecientos"
           Case 1000: s = "Mil"
           Case 1000000: s = "Millón"
    End Select
    If m_FeminineGenerous Then
       ReplaceAll s, "tos", "tas"
       If s = "Un" Then s = "Una"
    End If
Return

EngPart: '//E+00...
    Select Case i
           Case 0: s = Void
           Case 1: s = " Mil"
           Case 2: s = " Millones"
           Case 3: s = " Billones"
    End Select
Return

End Function