Public Function NumLetra(ByVal UnNumero As Long) As
String
'---------------------------------------------------------------------------------------
' Procedure : NumLetra
' DateTime : 20/07/2007 12:43
' Author : ©
Ju@nK ®
' Purpose : Poner numeros en letra para fechas hasta el 31/12/2059 o
números
' con la
función de NumDobleLetra, devolviendo moneda en Euros
'---------------------------------------------------------------------------------------
' © Ju@nK
On Error GoTo NumLetra_Error
Dim PartLetra As String
unidades:
Select Case UnNumero
Case 0
If NumLetra = "" Then
NumLetra =
"cero"
End If
Case 1
NumLetra = NumLetra & "uno" &
PartLetra
Case 2
NumLetra = NumLetra & "dos" &
PartLetra
Case 3
NumLetra = NumLetra & "tres" &
PartLetra
Case 4
NumLetra = NumLetra & "cuatro" &
PartLetra
Case 5
NumLetra = NumLetra & "cinco" &
PartLetra
Case 6
NumLetra = NumLetra & "seis" &
PartLetra
Case 7
NumLetra = NumLetra & "siete" &
PartLetra
Case 8
NumLetra = NumLetra & "ocho" &
PartLetra
Case 9
NumLetra = NumLetra & "nueve" &
PartLetra
Case 10
NumLetra = NumLetra & "diez" &
PartLetra
Case 11
NumLetra = NumLetra & "once" &
PartLetra
Case 12
NumLetra = NumLetra & "doce" &
PartLetra
Case 13
NumLetra = NumLetra & "trece" &
PartLetra
Case 14
NumLetra = NumLetra & "catorce" &
PartLetra
Case 15
NumLetra = NumLetra & "quince" &
PartLetra
Case 16
NumLetra = NumLetra & "dieciseis" &
PartLetra
Case 17
NumLetra = NumLetra & "diecisiete" &
PartLetra
Case 18
NumLetra = NumLetra & "dieciocho" &
PartLetra
Case 19
NumLetra = NumLetra & "diecinueve" &
PartLetra
Case 20
NumLetra = NumLetra & "veinte" &
PartLetra
Case 21 To 29
NumLetra = NumLetra & "venti"
UnNumero = UnNumero - 20
GoTo unidades
Case 30 To 39
NumLetra = NumLetra & "treinta"
UnNumero = UnNumero - 30
If UnNumero
<> 0 Then
NumLetra = NumLetra & " y "
GoTo unidades
End If
Case 40 To 49
NumLetra = NumLetra & "cuarenta"
UnNumero = UnNumero - 40
If UnNumero
<> 0 Then
NumLetra = NumLetra & " y "
GoTo unidades
End If
Case 50 To 59
NumLetra = NumLetra & "cincuenta"
UnNumero = UnNumero - 50
If UnNumero
<> 0 Then
NumLetra = NumLetra & " y "
GoTo unidades
End If
Case 60 To 69
NumLetra = NumLetra & "sesenta"
UnNumero = UnNumero - 60
If UnNumero
<> 0 Then
NumLetra = NumLetra & " y "
GoTo unidades
End If
Case 70 To 79
NumLetra = NumLetra & "setenta"
UnNumero = UnNumero - 70
If UnNumero
<> 0 Then
NumLetra = NumLetra & " y "
GoTo unidades
End If
Case 80 To 89
NumLetra = NumLetra & "ochenta"
UnNumero = UnNumero - 80
If UnNumero
<> 0 Then
NumLetra = NumLetra & " y "
GoTo unidades
End If
Case 90 To 99
NumLetra = NumLetra & "noventa"
UnNumero = UnNumero - 90
If UnNumero
<> 0 Then
NumLetra = NumLetra & " y "
GoTo unidades
End If
Case 100 To 199
UnNumero = UnNumero - 100
If UnNumero
<> 0 Then
NumLetra = NumLetra & "ciento "
Else
NumLetra = NumLetra & "cien "
End If
GoTo unidades
Case 200 To 299
UnNumero = UnNumero - 200
NumLetra = NumLetra & "doscientos "
GoTo unidades
Case 300 To 399
UnNumero = UnNumero - 300
NumLetra = NumLetra & "trescientos "
GoTo unidades
Case 400 To 499
UnNumero = UnNumero - 400
NumLetra = NumLetra & "cuatrocientos "
GoTo unidades
Case 500 To 599
UnNumero = UnNumero - 500
NumLetra = NumLetra & "quinientos "
GoTo unidades
Case 600 To 699
UnNumero = UnNumero - 600
NumLetra = NumLetra & "seiscientos "
GoTo unidades
Case 700 To 799
UnNumero = UnNumero - 700
NumLetra = NumLetra & "setecientos "
GoTo unidades
Case 800 To 899
UnNumero = UnNumero - 800
NumLetra = NumLetra & "ochocientos "
GoTo unidades
Case 900 To 999
UnNumero = UnNumero - 900
NumLetra = NumLetra & "novecientos "
GoTo unidades
'Parte dejada para compatibilidad en fechas, hasta el año 2999 _
**************************************************************
Case 1000 To 1999 'no definido mas, no hace falta
NumLetra = NumLetra & "mil"
UnNumero = UnNumero - 1000
If UnNumero
<> 0 Then
NumLetra = NumLetra & " "
GoTo unidades
End If
Case 2000 To 2999 'no definido mas, no hace falta
NumLetra = NumLetra & "dos mil"
UnNumero = UnNumero - 2000
If UnNumero
<> 0 Then
NumLetra = NumLetra & " "
GoTo unidades
End If
'**************************************************************
Case Else
NumLetra = "No definido para este
número, llamar al programador :-)
Ju@nK"
Stop
End Select
On Error GoTo 0
Exit Function
NumLetra_Error:
MsgBox "Error " & Err.Number & "
(" & Err.Description & ") en procedimiento NumLetra de Módulo
Pasa_Numeros_A_Letras"
End Function
Public Function NumDobleLetra(ByVal elNum As Double,
_
Optional ByVal numDec As Long = 2) As String
'---------------------------------------------------------------------------------------
' Procedure : NumDobleLetra
' DateTime : 06/08/2007 13:09
' Author : ©
Ju@nK ®
' Purpose : Pasar numeros a letra hasta 1 billón menos un céntimo
'
Utiliza también la función Numletra para sus cálculos.
'---------------------------------------------------------------------------------------
' © Ju@nK 2007
Dim EntNum As Double
Dim DecNum As Double
Dim entLet As String
Dim decLet As String
Dim numCal As Double
Dim x As Long
On Error GoTo NumDobleLetra_Error
x = InStr(1, CStr(elNum), ",",
vbTextCompare) + 1
If x > 1 Then
DecNum = CLng(Mid(CStr(elNum), x,
numDec))
Else
DecNum = 0
End If
EntNum = Int(elNum)
calculos:
'Parte entera
enteros:
x = Len(CStr(EntNum))
Select Case x
Case 1 To 3
'1 a 999
entLet =
NumLetra(EntNum)
Case 4 To 6
'1000 a
999999
'parte
centenas
entLet = NumLetra(Right(EntNum, 3))
'miles
If Left(EntNum, x - 3) <> 1 Then
entLet = NumLetra(Left(EntNum, x - 3)) & " mil " & entLet
Else
entLet = "mil " & entLet
End If
Case 7 To 9
'millones 1 a
999
numCal = Mid(EntNum, 1, x - 6)
entLet = IIf(numCal = 1, "un", NumLetra(numCal)) & " millon" & _
IIf(numCal <> 1, "es ", " ")
EntNum = EntNum - (numCal * 10 ^ 6)
NumDobleLetra = NumDobleLetra & entLet
GoTo enteros
Case 10 To 12
'miles de
millones 1 a 999
numCal = Mid(EntNum, 1, x - 9)
entLet = LTrim(IIf(numCal = 1, "", NumLetra(numCal)) & " mil") & _
IIf(numCal <> 1, " ", " ")
EntNum = EntNum - (numCal * 10 ^ 9)
NumDobleLetra = NumDobleLetra & entLet
GoTo enteros
Case Else
'no previsto
End Select
NumDobleLetra = NumDobleLetra & entLet & " euro" & _
IIf(EntNum <> 1, "s", "")
'Parte decimal
decimales:
If DecNum = 1 Then
decLet = "un céntimo"
Else
decLet = NumLetra(DecNum) & IIf(DecNum
> 0, " con " & decLet & " céntimos", "")
End If
'numero completo
NumDobleLetra = NumDobleLetra & decLet
On Error GoTo 0
Exit Function
NumDobleLetra_Error:
MsgBox "Error " & Err.Number & "
(" & Err.Description & ") en procedimiento NumDobleLetra de Módulo
Pasa_Numeros_A_Letras"
End Function
Public Function FechaLetra(ByVal UnaFecha As Date, _
Optional ByVal Mayusculas As Boolean = True) As String
'---------------------------------------------------------------------------------------
' Procedure : FechaLetra
' DateTime : 20/07/2007 12:44
' Author : ©
Ju@nK ®
' Purpose : Poner Fechas en letra para fechas hasta el 31/12/2059
'---------------------------------------------------------------------------------------
' © Ju@nK
Dim d As Long
Dim m As Long
Dim y As Long
On Error GoTo FechaLetra_Error
d = Day(UnaFecha)
m = Month(UnaFecha)
y = Year(UnaFecha)
FechaLetra = NumLetra(d) & " de " & Format(UnaFecha,
"mmmm") & " de " & NumLetra(y)
'no hay
If Mayusculas Then
FechaLetra = UCase(FechaLetra)
End If
On Error GoTo 0
Exit Function
FechaLetra_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") en procedimiento FechaLetra de Módulo Pasa_Numeros_A_Letras"
End Function