cCambio y cNum2Text

Una clase para efectuar cambios de divisas y otra para
convertir números en letras (o números a texto)

Publicado el 13/Ene/99
Revisión del 01/Jul/2000


Como puedes comprobar por el título, en esta página te hablaré de dos clases:

cCambio        Para efectuar cambios y

cNum2Text    Para convertir números a letras,
(ya estaba antes publicado, al menos eso creía yo)

Nota del 01/Jul/2000: Este es el link a la versión del 30/Jun/2000 de cNum2Text.cls

Nota: Estas dos clases están incluidas en la librería gsAxDLL


cCambio

Esta clase la he hecho para "atacar" el tema del Euro, que es el que está ahora empezando a dar quebraderos de cabeza al personal, (al menos en España y algunos paises de Europa).

Realmente la clase vale para cualquier tipo de moneda, no sólo para el Euro, pero...

Vamos a dejar a un lado los motivos de la creación de esta clase y vamos a ver que es lo que puede hacer, para que así evalues si te puede ser útil o no.

La clase contiene una colección de Monedas, cada moneda (o elemento de la colección), tiene estas propiedades:
Nombre    Nombre en singular de la moneda
Cambio    Cambio con respecto a la moneda base de la clase, en esta implementación es el Euro.
Simbolo    Símbolo usado para representar a la moneda
Sexo        Sexo de la moneda, esto es útil si se usa para mostrar el número en letras.

Al iniciarse la clase, se crean una serie de monedas con sus respectivos cambios, la fecha de cotización es la del viernes 8 de Enero de 1999, por tanto para las monedas que no estén dentro de la Zona Euro, se deberían ajustar al cambio actual, ya que las monedas de la Zona Euro, tendrán ese valor fijo hasta que desaparezcan el 1 de Julio del 2002.

Además de la colección Monedas, existe un método que es el que se encarga de realizar el cambio y como podrás imaginarte, el nombre de ese método se llama Cambio.

Ahora veremos un ejemplo de cómo usarla, pero antes vamos a ver el listado de las tres clases que son necesarias para la clase cCambio: la propia clase cCambio, cMoneda y cMonedas:

cMoneda es la clase base de la colección cMonedas y tiene las propiedades que se mencionaron más arriba.

'----------------------------------------------------------------------------------
'cMoneda    Clase básica para la colección Monedas                      (10/Ene/99)
'
'©Guillermo 'guille' Som, 1999
'----------------------------------------------------------------------------------
Option Explicit

Private m_Nombre As String
Public Cambio As Double
Public Simbolo As String
Public Sexo As eCambioSexo  ' Añadido el 13/Ene/99 para usarlo con cNum2Text

'Esta enumeración está también en Num2Text
'pero tiene otro nombre para que no de problemas de "ambigüedad",
'aunque los valores son los mismos
Public Enum eCambioSexo
    Female  '= 0
    Male    '= 1
End Enum

Public Property Get Nombre() As String
    Nombre = m_Nombre
End Property

Public Property Let Nombre(ByVal NewValue As String)
    'No permitir que se modifique una vez asignada
    Static bYaEstoy As Boolean
    
    If Not bYaEstoy Then
        bYaEstoy = True
        m_Nombre = NewValue
    End If
End Property

Private Sub Class_Initialize()
    Sexo = Female
End Sub

cMonedas: Esta clase es realmente una colección del tipo cMoneda y es la que se encarga de mantener la colección, los métodos que dispone son los habituales en una colección, además del método Clear que sirve para borrar el contenido de la colección y Find que busca un elemento en la colección y permite crearlo si así se le especifica.

Nota: Te recomiendo que "estudies" un poco cómo funcionan los métodos Item, Add y Find, sobre todo Add.

Veamos el código:

'----------------------------------------------------------------------------------
'cMonedas, colección del tipo cMoneda                                   (10/Ene/99)
'
'©Guillermo Som, 1999
'----------------------------------------------------------------------------------
Option Explicit

Private m_col As Collection

Public Sub Clear()
    'Borrar el contenido de la colección
    Set m_col = Nothing
    Set m_col = New Collection
End Sub

Public Function NewEnum() As IUnknown
    'Debe ser un miembro oculto y
    'el id del procedimiento debe ser -4
    '
    Set NewEnum = m_col.[_NewEnum]
End Function

Public Sub Remove(ByVal Index As Variant)
    'Método Remove de una colección
    
    On Local Error Resume Next
    
    m_col.Remove Index
    
    Err = 0
End Sub

Public Function Item(ByVal Index As Variant) As cMoneda
    'Método Item de una colección.
    'Asignarlo como método predeterminado
    Dim tMoneda As cMoneda
    
    'Iniciamos la detección de errores
    On Local Error Resume Next
    
    Set Item = m_col.Item(Index)
    If Err Then
        'no existe ese elemento
        Err = 0
        'Creamos una nueva referencia
        Set tMoneda = New cMoneda
        tMoneda.Nombre = Index
        'lo añadimos a la colección
        m_col.Add tMoneda, tMoneda.Nombre
        Set Item = tMoneda
        'Eliminamos el objeto
        Set tMoneda = Nothing
    End If
    'Dejamos de capturar los errores
    Err = 0
    On Error GoTo 0
End Function

Public Function Count() As Long
    'Método Count de las colección
    Count = m_col.Count
End Function

Public Sub Add(ByVal Item As Variant, _
                Optional ByVal Key As Variant, _
                Optional ByVal Before As Variant, _
                Optional ByVal After As Variant)
    'Añadir un nuevo elemento a la colección
    'Si ese elemento ya existe se sustituye por el valor indicado       (10/Ene/99)
    Dim tMoneda As cMoneda
    
    On Local Error Resume Next
    
    'Si el parámetro Item es del tipo cMoneda
    If TypeOf Item Is cMoneda Then
        'Asignar ese elemento a tMoneda
        Set tMoneda = Item
    Else
        'Crear una nueva
        Set tMoneda = New cMoneda
        'Si no se especifica el key
        If IsMissing(Key) Then
            'Asignar el Item al Nombre
            tMoneda.Nombre = Item
        Else
            tMoneda.Nombre = Key
            tMoneda.Cambio = Item
        End If
    End If
    
    'Usar siempre el Nombre como clave de este elemento
    m_col.Add tMoneda, tMoneda.Nombre, Before, After
    If Err Then
        'ya existe
        'borrarla y añadirla de nuevo
        m_col.Remove tMoneda.Nombre
        m_col.Add tMoneda, tMoneda.Nombre, Before, After
    End If
    
    Set tMoneda = Nothing
    
    Err = 0
    On Error GoTo 0
End Sub

Private Sub Class_Initialize()
    Set m_col = New Collection
End Sub

Private Sub Class_Terminate()
    Set m_col = Nothing
End Sub

Public Function Find(ByVal Nombre As String, _
                    Optional ByVal Crear As Boolean = False) As cMoneda
    'Busca un Moneda con el Nombre indicado
    'si lo encuentra devuelve el objeto del tipo cMoneda,
    'si no lo encuentra:
    '   si se especifica Crear, devuelve un nuevo elemento
    '   si no se especifica Crear devuelve Nothing
    Dim tMonedaHallada As cMoneda
    
    On Local Error Resume Next
        
    Set tMonedaHallada = m_col(Nombre)
    If Err Then
        If Crear Then
            'crearlo
            Set tMonedaHallada = New cMoneda
            With tMonedaHallada
                .Nombre = Nombre
            End With
            m_col.Add tMonedaHallada, tMonedaHallada.Nombre
        End If
    End If
    
    Set Find = tMonedaHallada
    
    Err = 0
    On Local Error GoTo 0
End Function

cCambio: esta es la clase "expuesta", o sea que es la que se debe crear para poder efectuar el cambio y acceder a la colección Monedas.
Esta clase tiene una colección Monedas del tipo cMonedas y una propiedad MonedaBase que es de sólo lectura y nos informa del nombre de la moneda base; el método Cambio es el que se encarga de efectuar el cambio de una moneda a otra. Por supuesto, las monedas que intervienen en el cambio deben estar contenidas en la colección Monedas.
Veamos el código:

'----------------------------------------------------------------------------------
'cCambio     Clase para efectar cambios de una moneda a otra            (10/Ene/99)
'
'©Guillermo 'guille' Som, 1999
'
'Esta clase servirá para efectuar cálculos sobre cambios de una moneda a otra.
'Todos los cambios se basarán en la moneda base, por defecto el Euro.
'Existirá una colección de Monedas con el nombre y el cambio con respecto a la
'moneda base.
'
'Propiedades y métodos:
'   MonedaBase  Devuelve el nombre de la moneda base (Euro)
'   Monedas     Colección de monedas con las siguientes propiedades:
'               .Nombre     Nombre de la moneda
'               .Simbolo    Símbolo usado para representarla
'               .Cambio     Cambio con respecto a la moneda base
'               .Sexo       Sexo de la moneda (para usar con Num2Text)
'   Cambio      Efectúa un cambio de una moneda a otra
'----------------------------------------------------------------------------------
Option Explicit

Private colMonedas As cMonedas

Const cMonedaBase = "Euro"
Const cPeseta = "Peseta"

Public Property Get MonedaBase() As String
    'Devuelve el nombre de la moneda base (por defecto Euro)
    MonedaBase = cMonedaBase
End Property

Public Function Monedas() As cMonedas
    'Devuelve la colección Monedas
    Set Monedas = colMonedas
End Function

Private Sub Class_Initialize()
    Set colMonedas = New cMonedas
    
    'Esta moneda debe estar en la colección
    With Monedas(cMonedaBase)
        .Simbolo = "€"  'se consigue pulsando AltGr+E o Ctrl+Alt+5
        .Cambio = 1
        .Sexo = Male
    End With

    'Algunos cambios de las monedas de la Zona Euro
    'Estos cambios ya son fijos
    With Monedas(cPeseta)
        .Cambio = 166.386   'El importe de un Euro
        .Simbolo = "Pta"
        .Sexo = Female
    End With

    With Monedas("Marco")
        .Cambio = 1.95583
        .Simbolo = "DM"
        .Sexo = Male
    End With

    With Monedas("Escudo")
        .Cambio = 200.482
        .Simbolo = "Es"
        .Sexo = Male
    End With

    With Monedas("Franco")
        .Cambio = 6.55957
        .Simbolo = "Fr"
        .Sexo = Male
    End With

    With Monedas("Lira")
        .Cambio = 1936.27
        .Simbolo = "L"
        .Sexo = Female
    End With
    'Otros cambios de la Zona Euro:
    'Franco Belga:      40.3399
    'Florin Holandés:   2.20371
    'Chelin Austriaco:  13.7603
    'Marco Finlandés:   5.94573
    'Libra Irlandesa:   0.787564
    '
    'Algunos cambios de monedas que no están en la Zona Euro a fecha 08/Ene/99
    With Monedas("Dolar")
        .Cambio = 1.1632
        .Simbolo = "$"
        .Sexo = Male
    End With
    '
    With Monedas("Libra")
        .Cambio = 0.70585
        .Simbolo = "£"
        .Sexo = Female
    End With
End Sub

Private Sub Class_Terminate()
    Set colMonedas = Nothing
End Sub

Public Function Cambio(ByVal Importe As String, _
                       Optional ByVal Moneda_De As String = cPeseta, _
                       Optional ByVal Moneda_A As String = cMonedaBase) As Double
    'Los parámetros son:
    '   Importe     Importe de la moneda a convertir
    '   Moneda_De   Moneda que se quiere convertir
    '               Por defecto la Peseta
    '   Moneda_A    Moneda a la que se quiere convertir
    '               Por defecto el Euro
    'Devuelve el importe resultante en la Moneda_A
    '
    Dim dblCambio1 As Double
    Dim dblCambio2 As Double
    Dim sTmp As String
        
    On Local Error Resume Next
    
    sTmp = ""
    dblCambio1 = Me.Monedas.Find(Moneda_De).Cambio
    If Err Then
        sTmp = "No existe la moneda '" & Moneda_De & "'" & vbCrLf
        Err = 0
    End If
    dblCambio2 = Me.Monedas.Find(Moneda_A).Cambio
    If Err Then
        sTmp = sTmp & "No existe la moneda '" & Moneda_A & "'"
    End If
        
    If Len(sTmp) Then
        On Local Error GoTo 0
        Err.Raise 5, "cCambio", sTmp
    Else
        dblCambio1 = Importe / dblCambio1
        'Para que devuelva tres decimales
        Cambio = CDbl(Format$(dblCambio1 * dblCambio2, "#,###.###"))
    End If
    
    Err = 0
    On Local Error GoTo 0
End Function

Bien, estas son las clases que componen cCambio.
Ahora veamos un ejemplo de cómo usarla.

Y este es el código de este programilla de prueba:

'
'Fornmulario de prueba para cCambio                                     (13/Ene/99)
Option Explicit

Private m_Cambio As cCambio

Private Sub cmdCambio_Click()
    Dim sMonedaDe As String
    Dim sMonedaA As String
    Dim dblImporte As String
    Dim dblCambio As Double
    Dim i As Long
    Dim tNum2Text As cNum2Text
    Dim sTmp As String
    
    Set tNum2Text = New cNum2Text
    ' Convertir de forma correcta el tipo de decimal
    ' corrige algunos errores e incongruencias, aunque no todos...
    dblImporte = tNum2Text.ConvDecimal(txtCambio)
    
    With cboMoneda(0)
        i = .ListIndex
        sMonedaDe = .List(i)
    End With
    With cboMoneda(1)
        i = .ListIndex
        sMonedaA = .List(i)
    End With
        
    ' El método Cambio es el métodor por defecto
    'dblCambio = m_Cambio(dblImporte, sMonedaDe, sMonedaA)
    dblCambio = m_Cambio.Cambio(dblImporte, sMonedaDe, sMonedaA)
    lblCambio(0) = dblImporte & " " & m_Cambio.Monedas(sMonedaDe).Simbolo & " son " & _
		dblCambio & " " & m_Cambio.Monedas(sMonedaA).Simbolo
    
    With m_Cambio.Monedas(sMonedaDe)
        sTmp = tNum2Text.Numero2Letra(dblImporte, 0, 4, .Nombre, , .Sexo) & " son " & vbCrLf
    End With
    With m_Cambio.Monedas(sMonedaA)
        sTmp = sTmp & tNum2Text.Numero2Letra(dblCambio, 0, 4, .Nombre, , .Sexo)
    End With
    lblCambio(5) = sTmp
    
    Set tNum2Text = Nothing
End Sub

Private Sub Form_Load()
    Dim tMoneda As cMoneda      ' Variable del tipo moneda para usar en el bucle
    Dim sNombre As String
    
    ' Crear el objeto
    Set m_Cambio = New cCambio
    
    ' Limpiar los combos y el listbox
    cboMoneda(0).Clear
    cboMoneda(1).Clear
    List1.Clear
    
    ' Si se quieren añadir algunas monedas, hacerlo ahora
    ' el Cambio siempre es referente al Euro
    '
    With m_Cambio.Monedas("Dolar Canadiense")
        .Simbolo = "$"
        .Cambio = 1.7602
	.Sexo = Male
    End With
    ' De esta forma se sustituye, pero se pierde el Símbolo
    'm_Cambio.Monedas.Add 1.7602, "Dolar Canadiense"
    
    ' Añadir las monedas a los combos y el ListBox
    sNombre = Space$(12) '12 caracteres para el nombre a mostrar en el ListBox
    
    ' Recorrer todas las monedas de la colección
    For Each tMoneda In m_Cambio.Monedas
        With tMoneda
            cboMoneda(0).AddItem .Nombre
            cboMoneda(1).AddItem .Nombre
            LSet sNombre = .Nombre
            List1.AddItem sNombre & vbTab & .Cambio
        End With
    Next
    
    ' Para probar la devolución de error
    'cboMoneda(0).AddItem "Lira"
    cboMoneda(0).ListIndex = 0
    cboMoneda(1).ListIndex = 1
    
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set m_Cambio = Nothing
    Set frmCambio = Nothing
End Sub

Private Sub txtCambio_GotFocus()
    With txtCambio
        .SelStart = 0
        .SelLength = Len(.Text)
    End With
End Sub

Espero que los listados estén lo suficientemente claros como para no necesitar más explicación, aunque debería darla, pero eso lo dejo para "el cursillo", que sino, ¿que voy a escribir en él?

Ahora le toca el turno a:

La clase cNum2Text  

Nota del 01/Jul/2000: Sigue este link para ver el código actualizado al 30/Jun/2000

Como te comenté antes, está basada en la función que ya publiqué en su día, pero además de estar "encapsulada" en un módulo de clase, tiene algunas mejoras:
Reconoce el sexo de la moneda (realmente no lo reconoce, sino que usa el que le digamos)
Se le pude indicar cuantos decimales queremos usar, antes sólo eran dos.
Si se quiere, se le puede indicar también el sexo de los céntimos, aunque no se si en estos hay cambio de sexo como en el nombre de la moneda, pero... ahí está.


ConvDecimal es un método/función de "chequeo" de decimales, para que maneje de forma correcta tanto los números con comas como con puntos. El valor del signo decimal, lo toma según la configuración regional, pero en las pruebas que he hecho, si se cambia el signo en el panel de control, la función Format$ no se aclara y por tanto hace que falle esa función.
En el código de ese método están los ejemplos de las cosas que puede manejar y las que no.
Si te parece una chorrada, lo he hecho para que al introducir decimales reconozca tanto la coma como el punto, siempre y cuando no se especifiquen separadores de miles.
Por ejemplo:
Esto funcionaría bien:
1.250,25 y 1250,25 y también 1250.25 pero no: 1,250.25

 

Por supuesto que se puede usar sin indicar el nombre de la moneda ni de los céntimos ni el sexo ni nada de nada, pero si no se hace, funciona como la anterior, es decir: usa el sexo femenino y dos decimales.
Esto lo he dejado así, para que la forma de llamar a la función que se encarga de hacer la conversión, sea compatible con la función que había en el módulo BAS.

Nota: Si quieres ver algunos ejemplo de cómo usar la clase, además de los que hay en la aplicación de cambio de moneda, puedes ver los que hay en los ejemplos y en la ayuda de la librería gsAxDLL

Vamos a ver el código de cNum2Text:

'----------------------------------------------------------------------------------
'cNumero2Letra   clase para convertir números a letras                    4/Ene/99)
'
'Versión original para MS-DOS:                      ( 1/Mar/91)
'Versión para Windows                               (25/Oct/96)
'Última revisión:                                   (10/Jul/97)
'Para manejar el sexo de la moneda y los céntimos   ( 6/Ene/99)
'Añado la función ConvDecimal                       (10/Ene/99)
'Quitados los ceros a la derecha de los decimales   (13/Ene/99)
'
'©Guillermo 'guille' Som, 1991-99
'----------------------------------------------------------------------------------
Option Explicit
Option Compare Text

'Declaradas a nivel de módulo
Dim unidad(0 To 9) As String
Dim decena(0 To 9) As String
Dim centena(0 To 10) As String
Dim deci(0 To 9) As String
Dim otros(0 To 15) As String

Private m_Sexo1 As String
Private m_Sexo2 As String
Private m_LenSexo1 As Long

Public Enum eSexo
    Femenino '= 0
    Masculino '= 1
End Enum

Public Function Numero2Letra(ByVal strNum As String, _
                            Optional ByVal Lo As Long = 0&, _
                            Optional ByVal NumDecimales As Long = 2&, _
                            Optional ByVal sMoneda As String = "", _
                            Optional ByVal sCentimos As String = "", _
                            Optional ByVal SexoMoneda As eSexo = Femenino, _
                            Optional ByVal SexoCentimos As eSexo = Masculino) As String
    '----------------------------------------------------------
    ' Convierte el número strNum en letras          (28/Feb/91)
    ' Versión para Windows                          (25/Oct/96)
    ' Variables estáticas                           (15/May/97)
    ' Parche de "Esteve" <[email protected]>       (20/May/97)
    ' Revisión para decimales                       (10/Jul/97)
    ' Permite indicar el sexo de la moneda          ( 6/Ene/99)
    ' y de los centimos... nunca se sabe...
    ' Corregido fallo de los decimales cuando       (13/Ene/99)
    ' tienen ceros a la derecha.
    '
    ' La moneda debe especificarse en singular, ya que la función
    ' se encarga de convertirla en plural.
    ' Se puede indicar el número de decimales a devolver
    ' por defecto son dos.
    '----------------------------------------------------------
    Dim i As Long
    Dim iHayDecimal As Long             'Posición del signo decimal
    Dim sDecimal As String              'Signo decimal a usar
    Dim sDecimalNo As String            'Signo no decimal
    Dim sEntero As String
    Dim sFraccion As String
    Dim fFraccion As Single
    Dim sNumero As String
    Static SexoAntMoneda As eSexo
    Static SexoAntCentimos As eSexo
    '
    'Dependiendo del "sexo" indicado, usar las terminaciones
    If SexoMoneda = Femenino Then
        m_Sexo1 = "a"
        m_Sexo2 = "as"
    Else
        m_Sexo1 = ""
        m_Sexo2 = "os"
    End If
    'por si se cambia en el trascurso el sexo de la moneda
    If SexoMoneda <> SexoAntMoneda Then
        unidad(2) = ""
        SexoAntMoneda = SexoMoneda
    End If
    m_LenSexo1 = Len(m_Sexo1)
    
    'Si se especifica, se usarán
    sMoneda = Trim$(sMoneda)
    If Len(Trim$(sMoneda)) Then
        sMoneda = " " & sMoneda & " "
    Else
        sMoneda = " "
    End If
    
    sCentimos = Trim$(sCentimos)
    If Len(Trim$(sCentimos)) Then
        sCentimos = " " & sCentimos & " "
    Else
        sCentimos = " "
    End If
    
    'Si no se especifica el ancho...
    '
    If Lo Then
        sNumero = Space$(Lo)
    Else
        sNumero = ""
    End If
    
    'Comprobar el signo decimal y devolver los adecuados a la config. regional
    strNum = ConvDecimal(strNum, sDecimal, sDecimalNo)
    
    'Comprobar si tiene decimales
    iHayDecimal = InStr(strNum, sDecimal)
    If iHayDecimal Then
        sEntero = Left$(strNum, iHayDecimal - 1)
        sFraccion = Mid$(strNum, iHayDecimal + 1) & String$(NumDecimales, "0")
        'obligar a que tenga dos cifras
        '
        'pero habría que redondear el resto...
        'por ejemplo:
        '   .256 sería .26 y
        '   .254 sería .25
        'Pero esto otro no se haría:
        '.25499 no pasaría a .255 y después a .26
        '
        sFraccion = Left$(sFraccion, NumDecimales + 1)
        fFraccion = Int((Val(sFraccion) / 100) * 10 + 0.5) * 10
        sFraccion = Left$(CStr(fFraccion), NumDecimales)
        'En las fracciones los ceros a la derecha no tienen significado
        Do While Right$(sFraccion, 1) = "0"
            sFraccion = Left$(sFraccion, Len(sFraccion) - 1)
        Loop
        fFraccion = Val(sFraccion)
        'Si no hay decimales... no agregar nada...
        If fFraccion < 1 Then
            If Len(Trim$(sMoneda)) Then
                sMoneda = Pluralizar(sNumero, sMoneda)
            End If
            strNum = RTrim$(UnNumero(sEntero, m_Sexo1) & sMoneda)
            If Lo Then
                LSet sNumero = strNum
            Else
                sNumero = strNum
            End If
            Numero2Letra = sNumero
            Exit Function
        End If
        
        If Len(Trim$(sMoneda)) Then
            sMoneda = Pluralizar(sEntero, sMoneda)
        End If
        
        sEntero = UnNumero(sEntero, m_Sexo1)
        
        If Len(Trim$(sCentimos)) Then
            sCentimos = Pluralizar(sFraccion, sCentimos)
        End If
        
        'Para el sexo de los decimales
        'no se si esto puede cambiar, pero por si ocurre...
        If SexoCentimos = Masculino Then
            sFraccion = UnNumero(sFraccion, "")
        Else
            sFraccion = UnNumero(sFraccion, "a")
        End If
        '
        strNum = sEntero & sMoneda & "con " & sFraccion & sCentimos
        If Lo Then
            LSet sNumero = RTrim$(strNum)
        Else
            sNumero = RTrim$(strNum)
        End If
        Numero2Letra = sNumero
    Else
        If Len(Trim$(sMoneda)) Then
            sMoneda = Pluralizar(strNum, sMoneda)
        End If
        strNum = RTrim$(UnNumero(strNum, m_Sexo1) & sMoneda)
        If Lo Then
            LSet sNumero = strNum
        Else
            sNumero = strNum
        End If
        Numero2Letra = sNumero
    End If
End Function


Private Function UnNumero(ByVal strNum As String, ByVal Sexo1 As String) As String
    '----------------------------------------------------------
    'Esta es la rutina principal                    (10/Jul/97)
    'Está separada para poder actuar con decimales
    '----------------------------------------------------------
    Dim dblNumero As Double
    
    Dim Negativo As Boolean
    Dim L As Integer
    Dim Una As Boolean
    Dim Millon As Boolean
    Dim Millones As Boolean
    Dim vez As Long
    Dim MaxVez As Long
    Dim k As Long
    Dim strQ As String
    Dim strB As String
    Dim strU As String
    Dim strD As String
    Dim strC As String
    Dim iA As Long
    '
    Dim strN() As String
    Dim Sexo1Ant As String
    
    'Si se amplia este valor... no se manipularán bien los números
    Const cAncho = 12
    Const cGrupos = cAncho \ 3
    
    'Por si se especifica el sexo, para el caso de los decimales
    'que siempre será masculino
    Sexo1Ant = m_Sexo1
    m_Sexo1 = Sexo1
    
    If m_Sexo1 <> Sexo1Ant Then
        unidad(2) = ""
    End If
    
    m_LenSexo1 = Len(m_Sexo1)
    
    '
    'idea aportada por Harvey Triana
    'para no tener que estar reinicializando continuamente los arrays
    If unidad(2) <> "dos" Then
        InicializarArrays
    End If
    
    'Si se produce un error que se pare el mundo!!!
    On Local Error GoTo 0
    
    If Len(strNum) = 0 Then
        strNum = "0"
    End If
    
    dblNumero = Abs(CDbl(strNum))
    Negativo = (dblNumero <> CDbl(strNum))
    strNum = LTrim$(RTrim$(Str$(dblNumero)))
    L = Len(strNum)
    
    If dblNumero < 1 Then
        UnNumero = "cero"
        Exit Function
    End If
    '
    Una = True
    Millon = False
    Millones = False
    If L < 4 Then Una = False
    If dblNumero > 999999 Then Millon = True
    If dblNumero > 1999999 Then Millones = True
    strB = ""
    strQ = strNum
    vez = 0
    
    ReDim strN(1 To cGrupos)
    strQ = Right$(String$(cAncho, "0") & strNum, cAncho)
    For k = Len(strQ) To 1 Step -3
        vez = vez + 1
        strN(vez) = Mid$(strQ, k - 2, 3)
    Next
    MaxVez = cGrupos
    For k = cGrupos To 1 Step -1
        If strN(k) = "000" Then
            MaxVez = MaxVez - 1
        Else
            Exit For
        End If
    Next
    For vez = 1 To MaxVez
        strU = ""
        strD = ""
        strC = ""
        strNum = strN(vez)
        L = Len(strNum)
        k = Val(Right$(strNum, 2))
        If Right$(strNum, 1) = "0" Then
            k = k \ 10
            strD = decena(k)
        ElseIf k > 10 And k < 16 Then
            k = Val(Mid$(strNum, L - 1, 2))
            strD = otros(k)
        Else
            strU = unidad(Val(Right$(strNum, 1)))
            If L - 1 > 0 Then
                k = Val(Mid$(strNum, L - 1, 1))
                strD = deci(k)
            End If
        End If
        '---Parche de Esteve
        If L - 2 > 0 Then
            k = Val(Mid$(strNum, L - 2, 1))
            'Con esto funcionará bien el 100100, por ejemplo...
            If k = 1 Then                       'Parche
                If Val(strNum) = 100 Then       'Parche
                    k = 10                      'Parche
                End If                          'Parche
            End If
            strC = centena(k) & " "
        End If
        '------
        If strU = "uno" And Left$(strB, 4) = " mil" Then strU = ""
        strB = strC & strD & strU & " " & strB
    
        If (vez = 1 Or vez = 3) Then
            If strN(vez + 1) <> "000" Then strB = " mil " & strB
        End If
        If vez = 2 And Millon Then
            If Millones Then
                strB = " millones " & strB
            Else
                strB = "un millón " & strB
            End If
        End If
    Next
    strB = Trim$(strB)
    If Right$(strB, 3) = "uno" Then
        strB = Left$(strB, Len(strB) - 1) & m_Sexo1 '"a"
    End If
    Do                              'Quitar los espacios que haya por medio
        iA = InStr(strB, "  ")
        If iA = 0 Then Exit Do
        strB = Left$(strB, iA - 1) & Mid$(strB, iA + 1)
    Loop

    If Left$(strB, 5 + m_LenSexo1) = "un" & m_Sexo1 & " un" Then
        strB = Mid$(strB, 4 + m_LenSexo1)
    End If

    If Left$(strB, 6 + m_LenSexo1) = "un" & m_Sexo1 & " mil" Then
        strB = Mid$(strB, 4 + m_LenSexo1)
    End If

    If Right$(strB, 15 + m_LenSexo1) <> "millones mil un" & m_Sexo1 Then
        iA = InStr(strB, "millones mil un" & m_Sexo1)
        If iA Then strB = Left$(strB, iA + 8) & Mid$(strB, iA + 13)
    End If

    If Right$(strB, 6) = "ciento" Then
        strB = Left$(strB, Len(strB) - 2)
    End If

    If Negativo Then strB = "menos " & strB
    
    UnNumero = Trim$(strB)
    
    'Restablecer el valor anterior
    m_Sexo1 = Sexo1Ant
    m_LenSexo1 = Len(m_Sexo1)
End Function


Private Sub InicializarArrays()
    'Asignar los valores
    unidad(1) = "un" & m_Sexo1
    unidad(2) = "dos"
    unidad(3) = "tres"
    unidad(4) = "cuatro"
    unidad(5) = "cinco"
    unidad(6) = "seis"
    unidad(7) = "siete"
    unidad(8) = "ocho"
    unidad(9) = "nueve"
    '
    decena(1) = "diez"
    decena(2) = "veinte"
    decena(3) = "treinta"
    decena(4) = "cuarenta"
    decena(5) = "cincuenta"
    decena(6) = "sesenta"
    decena(7) = "setenta"
    decena(8) = "ochenta"
    decena(9) = "noventa"
    '
    centena(1) = "ciento"
    centena(2) = "doscient" & m_Sexo2
    centena(3) = "trescient" & m_Sexo2
    centena(4) = "cuatrocient" & m_Sexo2
    centena(5) = "quinient" & m_Sexo2
    centena(6) = "seiscient" & m_Sexo2
    centena(7) = "setecient" & m_Sexo2
    centena(8) = "ochocient" & m_Sexo2
    centena(9) = "novecient" & m_Sexo2
    centena(10) = "cien"                'Parche
    '
    deci(1) = "dieci"
    deci(2) = "veinti"
    deci(3) = "treinta y "
    deci(4) = "cuarenta y "
    deci(5) = "cincuenta y "
    deci(6) = "sesenta y "
    deci(7) = "setenta y "
    deci(8) = "ochenta y "
    deci(9) = "noventa y "
    '
    otros(1) = "1"
    otros(2) = "2"
    otros(3) = "3"
    otros(4) = "4"
    otros(5) = "5"
    otros(6) = "6"
    otros(7) = "7"
    otros(8) = "8"
    otros(9) = "9"
    otros(10) = "10"
    otros(11) = "once"
    otros(12) = "doce"
    otros(13) = "trece"
    otros(14) = "catorce"
    otros(15) = "quince"
End Sub


Private Sub Class_Initialize()
    m_Sexo1 = "a"
    m_Sexo2 = "as"
End Sub


Private Function Pluralizar(ByVal sNumero As String, ByVal sMoneda As String) As String
    Dim dblTotal As Double
    
    If Len(Trim$(sMoneda)) Then
        dblTotal = Val(sNumero)
        If dblTotal <> 1# Then
            sMoneda = Trim$(sMoneda)
            If InStr("aeiou", Right$(sMoneda, 1)) Then
                sMoneda = " " & sMoneda & "s "
            Else
                sMoneda = " " & sMoneda & "es "
            End If
        End If
    End If
    Pluralizar = sMoneda
End Function


Public Function ConvDecimal(ByVal strNum As String, _
                            Optional ByRef sDecimal As String = ",", _
                            Optional ByRef sDecimalNo As String = ".") As String
    'Asigna el signo decimal adecuado (o lo intenta)                    (10/Ene/99)
    'Devuelve una cadena con el signo decimal del sistema
    Dim sNumero As String
    Dim i As Long
    Dim j As Long
    
    'Averiguar el signo decimal
    sNumero = Format$(25.5, "#.#")
    If InStr(sNumero, ".") Then
        sDecimal = "."
        sDecimalNo = ","
    Else
        sDecimal = ","
        sDecimalNo = "."
    End If
    
    strNum = Trim$(strNum)
    If Left$(strNum, 1) = sDecimalNo Then
        Mid$(strNum, 1, 1) = sDecimal
    End If
    
    'Si el número introducido contiene signos no decimales
    j = 0
    i = 1
    Do
        i = InStr(i, strNum, sDecimalNo)
        If i Then
            j = j + 1
            i = i + 1
        End If
    Loop While i
    
    If j = 1 Then
        'cambiar ese símbolo por un espacio, si sólo hay uno de esos signos
        i = InStr(strNum, sDecimalNo)
        If i Then
            If InStr(strNum, sDecimal) Then
                Mid$(strNum, i, 1) = " "
            Else
                Mid$(strNum, i, 1) = sDecimal
            End If
        End If
    Else
        'En caso de que tenga más de uno de estos símbolos
        'convertirlos de manera adecuada.
        'Por ejemplo:
        'si el signo decimal es la coma:
        '   1,250.45 sería 1.250,45 y quedaría en 1250,45
        'si el signo decimal es el punto:
        '   1.250,45 sería 1,250.45 y quedaría en 1250.45
        '
        'Aunque no se arreglará un número erróneo:
        'si el signo decimal es la coma:
        '   1,250,45 será lo mismo que 1,25
        '   12,500.25 será lo mismo que 12,50
        'si el signo decimal es el punto:
        '   1.250.45 será lo mismo que 1.25
        '   12.500,25 será lo mismo que 12.50
        '
        i = 1
        Do
            i = InStr(i, strNum, sDecimalNo)
            If i Then
                j = j - 1
                If j = 0 Then
                    Mid$(strNum, i, 1) = sDecimal
                Else
                    Mid$(strNum, i, 1) = " "
                End If
                i = i + 1
            End If
        Loop While i
    End If
    
    j = 0
    'Quitar los espacios que haya por medio
    Do
        i = InStr(strNum, " ")
        If i = 0 Then Exit Do
        strNum = Left$(strNum, i - 1) & Mid$(strNum, i + 1)
    Loop
    
    ConvDecimal = strNum
End Function

Hasta aquí hemos llegado, creo que no te quejarás de código, pero si quieres, puedes bajartelo todo, incluido el del programa de pruebam, en un solo fichero.
Pulsa este link para bajarte cCambio.zip (11.0 KB)

Nos vemos.
Guillermo


ir al índice