This paste brought to you by # Comparte Código . View Raw

  1. Option Explicit
  2. '*************************************************************************************************
  3. '       FUNCION PARA CONVERTIR NUMEROS A LETRAS
  4. '
  5. '       Copyright (C) 2005 Mauricio Baeza Servin
  6. '       Este programa es software libre. Puede redistribuirlo y/o modificarlo bajo los términos de la
  7. '       Licencia Pública General de GNU según es publicada por la Free Software Foundation, bien de la
  8. '       versión 2 de dicha Licencia o bien (según su elección) de cualquier versión posterior.
  9. '
  10. '       Este programa se distribuye con la esperanza de que sea útil, pero SIN NINGUNA GARANTÍA, incluso
  11. '       sin la garantía MERCANTIL implícita o sin garantizar la CONVENIENCIA PARA UN PROPÓSITO PARTICULAR.
  12. '       Véase la Licencia Pública General de GNU para más detalles.
  13. '
  14. '       Debería haber recibido una copia de la Licencia Pública General junto con este programa. Si no ha
  15. '       sido así, escriba a la Free Software Foundation, Inc., en 675 Mass Ave, Cambridge, MA 02139, EEUU.
  16. '
  17. '       Mauricio Baeza  -       mauricio@correolibre.net
  18. '
  19. '*************************************************************************************************
  20. 'Hago uso de variables bastante explicitas para facilitar la lectura del codigo
  21. 'Los comentarios cumplen y complementan la misma funcion
  22.  
  23. 'Ultima modificacion Octubre del 2002
  24. 'Argumentos:
  25. 'Numero = Valor que deseamos convertir en texto
  26. 'Moneda = es el nombre de la moneda a mostrar
  27. 'Fraccion_Letras = Verdadero para que la fraccion de la moneda
  28. '                 tambien la convierta a letras
  29. 'Fraccion = Es el nombre de la fraccion de la moneda
  30. 'Texto_Inicial = Cualquier texto que quieras al principio del resultado
  31. 'Texto_Final = Cualquier texto que quieras al finla del resultado
  32. 'Estilo = Formato de salida
  33. '           1 = MAYUSCULAS
  34. '           2 = minusculas
  35. '           3 = Tipo Titulo
  36. 'Los valores negativos los convierte a positivos
  37. 'El valor minimo en 0, el valor maximo es  9,999,999,999,999.99
  38.  
  39. Function Numeros_Letras(ByVal Numero As Double, _
  40.                     ByVal Moneda As String, _
  41.                     ByVal Fraccion_Letras As Boolean , _
  42.                     ByVal Fraccion As String, _
  43.                     ByVal Texto_Inicial As String, _
  44.                     ByVal Texto_Final As String, _
  45.                     ByVal Estilo As Integer) As String
  46. Dim strLetras As String
  47. Dim NumTmp As String
  48. Dim intFraccion As Integer
  49.  
  50.   strLetras = Texto_Inicial
  51.   'Convertimos a positivo si es negativo
  52.   Numero = Abs(Numero)
  53.   NumTmp = Format(Numero, "000000000000000.00")
  54.   If Numero < 1 Then
  55.     strLetras = strLetras & "cero " & Plural(Moneda) & " "
  56.   Else
  57.     strLetras = strLetras & NumLet(Val(Left(NumTmp, 15)))
  58.     If Val(NumTmp) = 1 Or Val(NumTmp) < 2 Then
  59.       strLetras = strLetras & Moneda & " "
  60.     ElseIf Val(Mid(NumTmp, 4, 12)) = 0 Or Val(Mid(NumTmp, 10, 6)) = 0 Then
  61.       strLetras = strLetras & "de " & Plural(Moneda) & " "
  62.     Else
  63.       strLetras = strLetras & Plural(Moneda) & " "
  64.     End If
  65.   End If
  66.   If Fraccion_Letras Then
  67.     intFraccion = Val(Right(NumTmp, 2))
  68.     Select Case intFraccion
  69.       Case 0
  70.         strLetras = strLetras & "con cero " & Plural(Fraccion)
  71.       Case 1
  72.         strLetras = strLetras & "con un " & Fraccion
  73.       Case Else
  74.         strLetras = strLetras & "con " & NumLet(Val(Right(NumTmp, 2))) & Plural(Fraccion)
  75.     End Select
  76.   Else
  77.     strLetras = strLetras & Right(NumTmp, 2)
  78.   End If
  79.   strLetras = strLetras & Texto_Final
  80.   Select Case Estilo
  81.     Case 1
  82.       strLetras = UCase(strLetras)
  83.     Case 2
  84.       strLetras = LCase(strLetras)
  85.     Case 3
  86.       strLetras = strLetras          'StrConv(strLetras, vbProperCase)
  87.   End Select
  88.    
  89.   Numeros_Letras = strLetras
  90.  
  91. End Function
  92.  
  93.  
  94. Function NumLet(ByVal Numero As Double) As String
  95.   Dim NumTmp As String
  96.   Dim co1 As Integer
  97.   Dim co2 As Integer
  98.   Dim pos As Integer
  99.   Dim dig As Integer
  100.   Dim cen As Integer
  101.   Dim dec As Integer
  102.   Dim uni As Integer
  103.   Dim letra1 As String
  104.   Dim letra2 As String
  105.   Dim letra3 As String
  106.   Dim Leyenda As String
  107.   Dim TFNumero As String
  108.        
  109.   NumTmp = Format(Numero, "000000000000000")        'Le da un formato fijo
  110.   co1 = 1
  111.   pos = 1
  112.   TFNumero = ""
  113.   'Para extraer tres digitos cada vez
  114.   Do While co1 <= 5
  115.     co2 = 1
  116.     Do While co2 <= 3
  117.       'Extrae un digito cada vez de izquierda a derecha
  118.       dig = Val(Mid(NumTmp, pos, 1))
  119.       Select Case co2
  120.         Case 1: cen = dig
  121.         Case 2: dec = dig
  122.         Case 3: uni = dig
  123.       End Select
  124.       co2 = co2 + 1
  125.       pos = pos + 1
  126.     Loop
  127.     letra3 = Centena(uni, dec, cen)
  128.     letra2 = Decena(uni, dec)
  129.     letra1 = Unidad(uni, dec)
  130.            
  131.     Select Case co1
  132.       Case 1
  133.         If cen + dec + uni = 1 Then
  134.           Leyenda = "billon "
  135.         ElseIf cen + dec + uni > 1 Then
  136.           Leyenda = "billones "
  137.         End If
  138.       Case 2
  139.         If cen + dec + uni >= 1 And Val(Mid(NumTmp, 7, 3)) = 0 Then
  140.           Leyenda = "mil millones "
  141.         ElseIf cen + dec + uni >= 1 Then
  142.           Leyenda = "mil "
  143.         End If
  144.       Case 3
  145.         If cen + dec = 0 And uni = 1 Then
  146.           Leyenda = "millon "
  147.         ElseIf cen > 0 Or dec > 0 Or uni > 1 Then
  148.           Leyenda = "millones "
  149.         End If
  150.       Case 4
  151.         If cen + dec + uni >= 1 Then
  152.           Leyenda = "mil "
  153.         End If
  154.       Case 5
  155.         If cen + dec + uni >= 1 Then
  156.           Leyenda = ""
  157.         End If
  158.       End Select
  159.            
  160.       co1 = co1 + 1
  161.       TFNumero = TFNumero + letra3 + letra2 + letra1 + Leyenda
  162.      
  163.       Leyenda = ""
  164.       letra1 = ""
  165.       letra2 = ""
  166.       letra3 = ""
  167.   Loop
  168.        
  169.   NumLet = TFNumero
  170.    
  171. End Function
  172.  
  173.  
  174. Function Centena(ByVal uni As Integer, ByVal dec As Integer, _
  175.                          ByVal cen As Integer) As String
  176. Dim cTexto As String
  177.  
  178.   Select Case cen
  179.     Case 1
  180.       If dec + uni = 0 Then
  181.         cTexto = "cien "
  182.       Else
  183.         cTexto = "ciento "
  184.       End If
  185.     Case 2: cTexto = "doscientos "
  186.     Case 3: cTexto = "trescientos "
  187.     Case 4: cTexto = "cuatrocientos "
  188.     Case 5: cTexto = "quinientos "
  189.     Case 6: cTexto = "seiscientos "
  190.     Case 7: cTexto = "setecientos "
  191.     Case 8: cTexto = "ochocientos "
  192.     Case 9: cTexto = "novecientos "
  193.     Case Else: cTexto = ""
  194.   End Select
  195.   Centena = cTexto
  196.    
  197. End Function
  198.  
  199.  
  200. Function Decena(ByVal uni As Integer, ByVal dec As Integer) As String
  201. Dim cTexto As String
  202.  
  203.   Select Case dec
  204.     Case 1:
  205.       Select Case uni
  206.         Case 0: cTexto = "diez "
  207.         Case 1: cTexto = "once "
  208.         Case 2: cTexto = "doce "
  209.         Case 3: cTexto = "trece "
  210.         Case 4: cTexto = "catorce "
  211.         Case 5: cTexto = "quince "
  212.         Case 6 To 9: cTexto = "dieci"
  213.       End Select
  214.     Case 2:
  215.       If uni = 0 Then
  216.         cTexto = "veinte "
  217.       ElseIf uni > 0 Then
  218.         cTexto = "veinti"
  219.       End If
  220.     Case 3: cTexto = "treinta "
  221.     Case 4: cTexto = "cuarenta "
  222.     Case 5: cTexto = "cincuenta "
  223.     Case 6: cTexto = "sesenta "
  224.     Case 7: cTexto = "setenta "
  225.     Case 8: cTexto = "ochenta "
  226.     Case 9: cTexto = "noventa "
  227.     Case Else: cTexto = ""
  228.   End Select
  229.  
  230.   If uni > 0 And dec > 2 Then cTexto = cTexto + "y "
  231.    
  232.   Decena = cTexto
  233.  
  234. End Function
  235.  
  236.  
  237. Function Unidad(ByVal uni As Integer, ByVal dec As Integer) As String
  238. Dim cTexto As String
  239.  
  240.   If dec <> 1 Then
  241.     Select Case uni
  242.       Case 1: cTexto = "un "
  243.       Case 2: cTexto = "dos "
  244.       Case 3: cTexto = "tres "
  245.       Case 4: cTexto = "cuatro "
  246.       Case 5: cTexto = "cinco "
  247.     End Select
  248.   End If
  249.   Select Case uni
  250.     Case 6: cTexto = "seis "
  251.     Case 7: cTexto = "siete "
  252.     Case 8: cTexto = "ocho "
  253.     Case 9: cTexto = "nueve "
  254.   End Select
  255.  
  256.   Unidad = cTexto
  257.  
  258. End Function
  259.  
  260.  
  261. 'Funcion que convierte al plural el argumento pasado
  262. Private Function Plural(ByVal Palabra As String) As String
  263. Dim pos As Integer
  264. Dim strPal As String
  265.  
  266.   If Len(Trim(Palabra)) > 0 Then
  267.     pos = InStr(1, "aeiou", Right(Palabra, 1), 1)
  268.     If pos > 0 Then
  269.       strPal = Palabra & "s"
  270.     Else
  271.       strPal = Palabra & "es"
  272.     End If
  273.   End If
  274.   Plural = strPal
  275.  
  276. End Function
  277.