'***********************************
'          © Eduardo Olaz
'           Enero / 2001
'***********************************
Public Enum SexoNumeracion
   snFemenino
   snMasculino
   snNeutro
End Enum

Public Enum TipoMoneda
   tmPeseta
   tmEuro
   tmDolar
End Enum

Private curNumero As Currency

Private strNombreEntero As String
Private strNombreEnteros As String
Private snSexoEnteros As SexoNumeracion
Private strSeparador As String
Private lngDecimales As Long
Private blnCeroDecimales As Boolean
Private strNombreDecimal As String
Private strNombreDecimales As String
Private snSexoDecimales As SexoNumeracion
Private strCadenaNegativo As String
Private blnClaseInicializada As Boolean

'Estos eventos se generarán en el momento
'en el que se produzca algún cambio de las propiedades
'devolviendo el valor previo al cambio
Public Event CambiadoParametro()
Public Event CambiadoNumero(Numero As Currency)
Public Event CambiadoNombreEntero(Cadena As String)
Public Event CambiadoNombreEnteros(Cadena As String)
Public Event CambiadoSexoEnteros(Sexo As SexoNumeracion)
Public Event CambiadoSeparador(Separador As String)
Public Event CambiadoDecimales(Decimales As Long)
Public Event CambiadoNombreDecimal(Cadena As String)
Public Event CambiadoNombreDecimales(Cadena As String)
Public Event CambiadoSexoDecimales(Sexo As SexoNumeracion)
Public Event CambiadoCadenaNegativo(Cadena As String)
Public Event CambiadoFormatoMoneda(Moneda As TipoMoneda)

Private Sub Class_Initialize()
   curNumero = 0
   FormatearMoneda tmEuro
   blnClaseInicializada = True
End Sub

Public Property Let Numero(ByVal Cantidad As Currency)
   Dim curAnterior As Currency
   If Cantidad = curNumero Then
      Exit Property
   Else
      curAnterior = curNumero
      curNumero = Cantidad
      RaiseEvent CambiadoParametro
      RaiseEvent CambiadoNumero(curAnterior)
   End If
End Property

Public Property Get Numero() As Currency
   Numero = curNumero
End Property

Public Property Let NombreEntero(ByVal Nombre As String)
   Dim strAnterior As String
   If Nombre = strNombreEntero Then
      Exit Property
   Else
      strAnterior = strNombreEntero
      strNombreEntero = Nombre
      RaiseEvent CambiadoParametro
      RaiseEvent CambiadoNombreEntero(strAnterior)
   End If
End Property

Public Property Get NombreEntero() As String
   NombreEntero = strNombreEntero
End Property

Public Property Let NombreEnteros(ByVal Nombre As String)
   Dim strAnterior As String
   If Nombre = strNombreEnteros Then
      Exit Property
   Else
      strAnterior = strNombreEnteros
      strNombreEnteros = Nombre
      RaiseEvent CambiadoParametro
      RaiseEvent CambiadoNombreEnteros(strAnterior)
   End If
End Property

Public Property Get NombreEnteros() As String
   NombreEnteros = strNombreEnteros
End Property

Public Property Let SexoEnteros(ByVal Sexo As SexoNumeracion)
   Dim snAnterior As SexoNumeracion
   Select Case Sexo
   'Sólo se cambia si es válido y diferente al anterior
   Case snFemenino To snNeutro
      If Sexo = snSexoEnteros Then
         Exit Property
      Else
         snAnterior = snSexoEnteros
         snSexoEnteros = Sexo
         RaiseEvent CambiadoParametro
         RaiseEvent CambiadoSexoEnteros(snAnterior)
      End If
   End Select
End Property

Public Property Get SexoEnteros() As SexoNumeracion
   SexoEnteros = snSexoEnteros
End Property

Public Property Let CadenaSeparacion(ByVal Separador As String)
   Dim strAnterior As String
   If Separador = strSeparador Then
      Exit Property
   Else
      strAnterior = strSeparador
      strSeparador = Separador
      RaiseEvent CambiadoParametro
      RaiseEvent CambiadoSeparador(strAnterior)
   End If
End Property

Public Property Get CadenaSeparacion() As String
   CadenaSeparacion = strSeparador
End Property

Public Property Let Decimales(ByVal Numero As Long)
   Dim lngAnterior As Long
   Select Case Numero
      Case Is < 0
         Exit Property
      Case Is > 4
         Exit Property
      Case Is = lngDecimales
         Exit Property
      Case Else
         lngAnterior = lngDecimales
         lngDecimales = Numero
         RaiseEvent CambiadoParametro
         RaiseEvent CambiadoDecimales(lngAnterior)
   End Select
End Property

Public Property Get Decimales() As Long
   Decimales = lngDecimales
End Property

Public Property Let NombreDecimal(ByVal Nombre As String)
   Dim strAnterior As String
   If Nombre = strNombreDecimal Then
      Exit Property
   Else
      strAnterior = strNombreDecimal
      strNombreDecimal = Nombre
      RaiseEvent CambiadoParametro
      RaiseEvent CambiadoNombreDecimal(strAnterior)
   End If
End Property

Public Property Get NombreDecimal() As String
   NombreDecimal = strNombreDecimal
End Property

Public Property Let NombreDecimales(ByVal Nombre As String)
   Dim strAnterior As String
   If Nombre = strNombreDecimales Then
      Exit Property
   Else
      strAnterior = strNombreDecimales
      strNombreDecimales = Nombre
      RaiseEvent CambiadoParametro
      RaiseEvent CambiadoNombreDecimales(strAnterior)
   End If
End Property

Public Property Get NombreDecimales() As String
   NombreDecimales = strNombreDecimales
End Property

Public Property Let SexoDecimales(ByVal Sexo As SexoNumeracion)
   Dim snAnterior As SexoNumeracion
   Select Case Sexo
   'Sólo se cambia si es válido y diferente al anterior
   Case snFemenino To snNeutro
      If Sexo = snSexoDecimales Then
         Exit Property
      Else
         snAnterior = snSexoDecimales
         snSexoDecimales = Sexo
         RaiseEvent CambiadoParametro
         RaiseEvent CambiadoSexoDecimales(snAnterior)
      End If
   End Select
End Property

Public Property Get SexoDecimales() As SexoNumeracion
   SexoDecimales = snSexoDecimales
End Property

Public Property Let CadenaNegativo(ByVal Negativo As String)
   Dim strAnterior As String
   If Negativo = strCadenaNegativo Then
      Exit Property
   Else
      strAnterior = strCadenaNegativo
      strCadenaNegativo = Negativo
      RaiseEvent CambiadoParametro
      RaiseEvent CambiadoCadenaNegativo(strAnterior)
   End If
End Property

Public Property Get CadenaNegativo() As String
   CadenaNegativo = strCadenaNegativo
End Property

Public Property Get Texto() As String
   Texto = ExtraerTexto()
End Property

Public Sub FormatearMoneda(Moneda As TipoMoneda)
   Select Case Moneda
   Case tmPeseta
      strNombreEntero = "peseta"
      strNombreEnteros = "pesetas"
      snSexoEnteros = snFemenino
      lngDecimales = 0
      blnCeroDecimales = False
      strNombreDecimal = "céntimo"
      strNombreDecimales = "céntimos"
      snSexoDecimales = snNeutro
      strCadenaNegativo = "menos"
   Case tmEuro
      strNombreEntero = "euro"
      strNombreEnteros = "euros"
      snSexoEnteros = snNeutro
      strSeparador = ", con"
      lngDecimales = 2
      blnCeroDecimales = False
      strNombreDecimal = "céntimo"
      strNombreDecimales = "céntimos"
      snSexoDecimales = snNeutro
      strCadenaNegativo = "menos"
   Case tmDolar
      strNombreEntero = "dólar"
      strNombreEnteros = "dólares"
      snSexoEnteros = snNeutro
      strSeparador = ", con"
      lngDecimales = 2
      blnCeroDecimales = False
      strNombreDecimal = "centavo"
      strNombreDecimales = "centavos"
      snSexoDecimales = snNeutro
      strCadenaNegativo = "menos"
   Case Else
      Exit Sub
   End Select
   If blnClaseInicializada Then
      RaiseEvent CambiadoFormatoMoneda(Moneda)
   End If
End Sub

Private Function ExtraerTexto() As String
   Dim strTextoParteEntera As String
   Dim strTextoSeparador As String
   Dim strTextoParteDecimal As String

   strTextoParteEntera = TextoParteEntera()

   If lngDecimales > 0 Then
      strTextoParteDecimal = TextoParteDecimal()
      If Len(Trim(strTextoParteDecimal)) > 0 Then
         strTextoSeparador = strSeparador & " "
      Else
         strTextoSeparador = ""
      End If
   Else
      strTextoSeparador = ""
      strTextoParteDecimal = ""
   End If
   ExtraerTexto = strTextoParteEntera _
                  & strTextoSeparador _
                  & strTextoParteDecimal
End Function

Private Function TextoParteEntera() As String
   Dim strParteEntera As String
   Dim curParteEntera As Currency
   curParteEntera = ParteEntera()

   strParteEntera = NumeroALetra(curParteEntera, snSexoEnteros)

   If curParteEntera < 0 Then
      strParteEntera = strCadenaNegativo & " " & strParteEntera
   End If

   Select Case Fix(ParteEntera())
      Case 1, -1
         If Len(strNombreEntero) > 0 Then
            strParteEntera = strParteEntera & strNombreEntero
         End If
      Case Else
      If Len(strNombreEnteros) > 0 Then
            strParteEntera = strParteEntera & strNombreEnteros
         End If
   End Select

   TextoParteEntera = strParteEntera
End Function

Private Function TextoParteDecimal() As String
   Dim strParteDecimal As String
   Dim curParteDecimal As Currency
   curParteDecimal = ParteDecimal()

   strParteDecimal = NumeroALetra(curParteDecimal, snSexoDecimales)

   Select Case Fix(ParteDecimal())
      Case 0
         If Not blnCeroDecimales Then
            TextoParteDecimal = ""
            Exit Function
         Else
            strParteDecimal = strParteDecimal & strNombreDecimales
         End If
      Case 1, -1
         If Len(strNombreDecimal) > 0 Then
            strParteDecimal = strParteDecimal & strNombreDecimal
         End If
      Case Else
      If Len(strNombreDecimales) > 0 Then
            strParteDecimal = strParteDecimal & strNombreDecimales
         End If
   End Select

   TextoParteDecimal = strParteDecimal
End Function

Public Function ParteEntera() As Currency
   ParteEntera = Fix(Redondear(curNumero, lngDecimales))
End Function

Public Function ParteDecimal() As Currency
   ParteDecimal = Redondear((curNumero - ParteEntera) * 10 ^ lngDecimales,
0)
End Function


Private Function SustituirCadena(ByVal Cadena As String, _
                                ByVal Buscar As String, _
                                ByVal Sustituir As String) _
                                As String
   Dim strIzquierda As String
   Dim strDerecha As String
   Dim lngCadena As Long
   Dim lngPosicion As Long
   Dim lngBuscar As Long
   Dim lngSustituir As Long

   If Buscar = Sustituir Or Buscar = "" Then
      SustituirCadena = Cadena
      Exit Function
   End If

   lngCadena = Len(Cadena)
   lngBuscar = Len(Buscar)
   lngSustituir = Len(Sustituir)
   lngPosicion = InStr(Cadena, Buscar)
   Select Case lngPosicion
      Case 0
         SustituirCadena = Cadena
      Case 1
         SustituirCadena = Sustituir _
                           & Mid(Cadena, _
                           lngBuscar + 1)
      Case Else
         strIzquierda = Left(Cadena, _
                           lngPosicion - 1)
         strDerecha = Right(Cadena, _
                           lngCadena - lngPosicion - lngBuscar + 1)

         SustituirCadena = strIzquierda _
                           & Sustituir _
                           & strDerecha
   End Select

End Function

Private Function Unidades(ByVal Unidad As Integer, _
                           ByVal Decena As Integer) _
                           As String
If Not Decena = 1 And Unidad < 6 Then
   Select Case Unidad
      Case 1
         Unidades = "un "
      Case 2
         Unidades = "dos "
      Case 3
         Unidades = "tres "
      Case 4
         Unidades = "cuatro "
      Case 5
         Unidades = "cinco "
   End Select
End If

If Unidad > 5 Then
   Select Case Unidad
         Case 6
         Unidades = "seis "
      Case 7
         Unidades = "siete "
      Case 8
         Unidades = "ocho "
      Case 9
         Unidades = "nueve "
   End Select
End If

End Function

Private Function Decenas(ByVal Unidad As Integer, _
                        ByVal Decena As Integer) _
                        As String
If Unidad = 0 Then
   Select Case Decena
      Case 1
         Decenas = "diez "
      Case 2
         Decenas = "veinte "
      Case 3
         Decenas = "treinta "
      Case 4
         Decenas = "cuarenta "
      Case 5
         Decenas = "cincuenta "
      Case 6
         Decenas = "sesenta "
      Case 7
         Decenas = "setenta "
      Case 8
         Decenas = "ochenta "
      Case 9
         Decenas = "noventa "
   End Select
Else
   If Decena = 1 And Unidad < 6 Then
      Select Case Unidad
         Case 0
            Decenas = "diez "
         Case 1
            Decenas = "once "
         Case 2
            Decenas = "doce "
         Case 3
            Decenas = "trece "
         Case 4
            Decenas = "catorce "
         Case 5
            Decenas = "quince "
      End Select
   Else
      Select Case Decena
      Case 1
         Decenas = "dieci"
      Case 2
         Decenas = "veinti"
      Case 3
         Decenas = "treinta y "
      Case 4
         Decenas = "cuarenta y "
      Case 5
         Decenas = "cincuenta y "
      Case 6
         Decenas = "sesenta y "
      Case 7
         Decenas = "setenta y "
      Case 8
         Decenas = "ochenta y "
      Case 9
         Decenas = "noventa y "
      End Select
   End If
End If

End Function

Private Function Centenas(ByVal Unidad As Integer, _
                        ByVal Decena As Integer, _
                        ByVal Centena As Integer) _
                        As String

If Centena = 1 And Decena = 0 And Unidad = 0 Then
      Centenas = "cien "
Else
   Select Case Centena
      Case 1
         Centenas = "ciento "
      Case 2
         Centenas = "doscientos "
      Case 3
         Centenas = "trescientos "
      Case 4
         Centenas = "cuatrocientos "
      Case 5
         Centenas = "quinientos "
      Case 6
         Centenas = "seiscientos "
      Case 7
         Centenas = "setecientos "
      Case 8
         Centenas = "ochocientos "
      Case 9
         Centenas = "novecientos "
   End Select
End If
End Function

Private Function TernaALetra(Numero As Long) As String
   Dim Centena As Long
   Dim Decena As Long
   Dim Unidad As Long

   If Not Numero > 0 Or Numero > 999 Then
      TernaALetra = ""
      Exit Function
   End If

   Centena = Numero \ 100
   Decena = (Numero - Centena * 100) \ 10
   Unidad = Numero Mod 10

   TernaALetra = Centenas(Unidad, Decena, Centena) _
               & Decenas(Unidad, Decena) _
               & Unidades(Unidad, Decena)
End Function

Private Function NumeroALetra( _
                     ByVal Numero As Currency, _
                     Optional Sexo As SexoNumeracion = snMasculino) _
                     As String

   Const constrFormato As String = "000000000000000"
   Dim strNumero As String
   Dim strNumeroInicial As String
   Dim strTerna As String
   Dim strCadenaDobleTerna As String
   Dim strCadenaTerna As String
   Dim lngDobleTerna As Long
   Dim lngPosicion As Long
   Dim lngTerna As Long
   Dim lngGrupo As Long

   If Sexo < snFemenino Or Sexo > snNeutro Then
      MsgBox "Sexo fuera de rango" _
             & vbCrLf & vbCrLf _
             & "El sexo debe ser: " & vbCrLf _
             & Space(4) & "snFemenino   (0)" & vbCrLf _
             & Space(4) & "snMasculino  (1)" & vbCrLf _
             & Space(4) & "snNeutro       (2)", _
              vbExclamation, _
             " Error en parámetro de NumeroALetra ( )"

             Exit Function
   End If

   Numero = Abs(Numero)
   If Numero = 0 Then
      NumeroALetra = "cero "
      Exit Function
   End If

   strNumeroInicial = Format(Numero, constrFormato)
   '************** Billones *****************
   strTerna = Left(strNumeroInicial, 3)
   lngTerna = Val(strTerna)
   strNumero = TernaALetra(lngTerna)
   Select Case lngTerna
      Case 1
         strNumero = strNumero & "billón "
      Case Is > 1
         strNumero = strNumero & "billones "
   End Select

   '*********** Miles de Millones ***********
   strTerna = Mid(strNumeroInicial, 4, 3)
   lngTerna = Val(strTerna)
   strNumero = strNumero & TernaALetra(lngTerna)

   If lngTerna > 0 Then
      strNumero = strNumero & "mil "
      If strNumero = "un mil " Then
         If Left(strNumeroInicial, 3) = "000" Then
            strNumero = "mil "
         End If
      End If
   End If
   '***************  Millones  **************
   strTerna = Mid(strNumeroInicial, 7, 3)
   lngTerna = Val(strTerna)
   strNumero = strNumero & TernaALetra(lngTerna)
   lngDobleTerna = Mid(strNumeroInicial, 4, 6)
   Select Case lngDobleTerna
      Case 1
         strNumero = strNumero & "millón "
      Case Is > 1
         strNumero = strNumero & "millones "
   End Select
   '**********  Millones "redondos" **********
   If Val(Right(strNumeroInicial, 6)) = 0 And _
      Val(Left(strNumeroInicial, 9)) > 0 Then
      If Len(strNombreEnteros) > 0 Then
         strNumero = strNumero & "de "
      End If
   End If
   '*****************  Miles  ****************
   strTerna = Mid(strNumeroInicial, 10, 3)
   lngTerna = Val(strTerna)
   strCadenaDobleTerna = TernaALetra(lngTerna)
   Select Case lngTerna
      Case 1
         strCadenaDobleTerna = "mil "
      Case Is > 1
         strCadenaDobleTerna = strCadenaDobleTerna & "mil "
   End Select
   strCadenaDobleTerna = AjustarGenero(strCadenaDobleTerna, Sexo)
   '****************  Unidades  ***************
   strTerna = Mid(strNumeroInicial, 13, 3)
   lngTerna = Val(strTerna)
   strCadenaTerna = TernaALetra(lngTerna)
   strCadenaTerna = AjustarGenero(strCadenaTerna, Sexo)
   strCadenaDobleTerna = strCadenaDobleTerna & strCadenaTerna

   lngDobleTerna = Mid(strNumeroInicial, 10, 6)

   strNumero = strNumero & strCadenaDobleTerna

   NumeroALetra = strNumero

End Function

Private Function AjustarGenero( _
                        ByVal CadenaNumerica As String, _
                        ByVal Sexo As SexoNumeracion) _
                        As String

   Select Case Sexo

      Case snFemenino

         CadenaNumerica = SustituirCadena( _
                              CadenaNumerica, _
                              "cientos", _
                              "cientas")
         AjustarGenero = SustituirCadena( _
                              CadenaNumerica, _
                              "un", _
                              "una")
      Case snMasculino
         AjustarGenero = SustituirCadena( _
                              CadenaNumerica, _
                              "un", _
                              "uno")
      Case Else
         AjustarGenero = CadenaNumerica
      End Select
End Function

Private Function Redondear(ByVal Valor As Currency, _
               Optional ByVal NumeroDecimales As Long = 0) _
               As Currency

   Dim lngDivisor As Long
   Dim curParteDecimal As Currency
   Dim curParteEntera As Currency

   Select Case NumeroDecimales
   Case Is < 0
      Redondear = Valor
   Case 0
      curParteEntera = Fix(Valor)
      curParteDecimal = Valor - curParteEntera
      Select Case curParteDecimal
         Case Is >= 0.5
            Redondear = curParteEntera + 1
         Case Is <= -0.5
            Redondear = curParteEntera - 1
         Case Else
            Redondear = curParteEntera
      End Select
   Case 1 To 4
      curParteEntera = Fix(Valor)
      curParteDecimal = Valor - curParteEntera
      lngDivisor = 10 ^ NumeroDecimales
      curParteDecimal = CInt(curParteDecimal * lngDivisor) / lngDivisor
      Redondear = curParteEntera + curParteDecimal
   Case Is > 4
      Redondear = Valor
   End Select

End Function
____________________________