Visual Basic Foro
Programación => Visual Basic 6 => Mensaje iniciado por: javierjava en Noviembre 11, 2011, 08:46:33 pm
-
Que tal disculpen la molestia entre esta funcion del amigo wolf_kof para convertir numero a letra
Option Explicit
Const glbSubS = "CENTAVO"
Const glbSubP = "CENTAVOS"
Const glbSubS2 = "cent�simo"
Const glbSubP2 = "cent�simos"
Function WordNum(ByVal Numero As String, Optional TipoCambioSingular As String, Optional TipoCambioPlural As String, Optional xInternal As Long) As String
Dim sNum As String, vNum() As String, X As Long, Y As Long, Z As Long, sTmp As String
Dim D1 As String, D2 As String, D3 As String, DFinal As String
Dim tNum As String, B1 As Boolean, B2 As Boolean, B3 As Boolean
Dim wNum() As String, Nombres() As String
'**********************************************************************************************
'* Esta funci�n convierte n�meros en palabras, sin importar el contexto donde se encuentren *
'* Es capaz de procesar n�meros de 123 d�gitos (Vigintillones) :-O *
'* Solo se procesan 2 decimales si los hay *
'**********************************************************************************************
'Convierte el valor en un string
sNum = Trim(Replace(CStr(Numero), ",", "."))
'Procesa cada n�mero que exista en la variable por separado
If xInternal = 0 Then
'Separa los n�meros limpios de las palabras y los procesa por separado (no incluye n�meros con letras)
wNum = Split(sNum, Space(1))
For X = 0 To UBound(wNum)
'Concatena los strings o n�meros seg�n corresponda
If IsNumeric(wNum(X)) Then
'Separa los enteros de los decimales para procesarlos por separado
If InStr(1, wNum(X), ".", vbTextCompare) > 0 Then
'Proceso los enteros
D1 = Left(wNum(X), InStrRev(wNum(X), ".", , vbTextCompare) - 1)
DFinal = DFinal & IIf(D1 < 0, "menos ", "") & WordNum(D1, TipoCambioSingular, TipoCambioPlural, 1)
'Proceso 2 decimales
D2 = Mid(Mid(wNum(X), InStrRev(wNum(X), ".", , vbTextCompare) + 1), 1, 2)
If Val(D2) > 0 Then
If Left(D2, 1) = "0" Then DFinal = DFinal & " CON " & WordNum(D2, glbSubS2, glbSubP2, 1) & Space(1) Else DFinal = DFinal & " CON " & WordNum(D2, glbSubS, glbSubP, 1) & Space(1)
End If
Else
DFinal = DFinal & IIf(wNum(X) < 0, "MENOS ", "") & WordNum(wNum(X), TipoCambioSingular, TipoCambioPlural, 1) & Space(1)
End If
Else
DFinal = DFinal & wNum(X) & Space(1)
End If
Next
Else
'Elimina el signo
If Not IsNumeric(Left(sNum, 1)) Then
sNum = Mid(sNum, 2)
End If
'Elimina cualquier formato posible (incluye valores cient�ficos)
'sNum = Format(sNum, "0")
If sNum = vbNullString Then sNum = "0"
'Completa con ceros a la izquierda hasta obtener una longitud m�ltiplo de 3
Do While Len(sNum) Mod 3 <> 0
sNum = "0" & sNum
Loop
'Dimenciona un arreglo con espacio para cada una de las centenas
ReDim vNum(Len(sNum) / 3 - 1)
'Carga el arreglo con las centenas que corresponda
For X = 0 To UBound(vNum, 1)
vNum(X) = Mid(sNum, (X + 1) * 3 - 2, 3)
Next
'Si el arreglo contiene una sola centena, la convierte en palabras
If UBound(vNum, 1) = 0 Then
'Asigna los d�gitos de la centena y recuerda si son mayores que cero
D3 = Left(sNum, 1): B3 = Val(D3) > 0
D2 = Mid(sNum, 2, 1): B2 = Val(D2) > 0
D1 = Right(sNum, 1): B1 = Val(D1) > 0
'Procesa las unidades
Select Case D1
Case "1": DFinal = "UN"
Case "2": DFinal = "DOS"
Case "3": DFinal = "TRES"
Case "4": DFinal = "CUATRO"
Case "5": DFinal = "CINCO"
Case "6": DFinal = "SEIS"
Case "7": DFinal = "SIETE"
Case "8": DFinal = "OCHO"
Case "9": DFinal = "NUEVE"
End Select
'Procesa las decenas
Select Case D2
Case "1"
'Maneja l�gica del retrasado mental que puso nombres il�gicos a algunos n�meros.
Select Case D1
Case "0": DFinal = "DIEZ"
Case "1": DFinal = "ONCE" 'dieciuno
Case "2": DFinal = "DOCE" 'diecidos
Case "3": DFinal = "TRECE" 'diecitres
Case "4": DFinal = "CATORCE" 'diecicuatro
Case "5": DFinal = "QUINCE" 'diecicinco
Case "6": DFinal = "DIECISEIS" 'acento :(
Case Else
DFinal = "DIECI" & DFinal
End Select
Case "2"
If B1 Then
If D1 = "2" Then DFinal = "DOS"
If D1 = "3" Then DFinal = "TRES"
DFinal = "VEINTI" & DFinal
Else
DFinal = "VEINTE"
End If
Case "3": If B1 Then DFinal = "TREINTA Y " & DFinal Else DFinal = "TREINTA"
Case "4": If B1 Then DFinal = "CUARENTA Y " & DFinal Else DFinal = "CUARENTA"
Case "5": If B1 Then DFinal = "CINCUENTA Y " & DFinal Else DFinal = "CINCUENTA"
Case "6": If B1 Then DFinal = "SESENTA Y " & DFinal Else DFinal = "SESENTA"
Case "7": If B1 Then DFinal = "SETENTA Y " & DFinal Else DFinal = "SETENTA"
Case "8": If B1 Then DFinal = "OCHENTA Y " & DFinal Else DFinal = "OCHENTA"
Case "9": If B1 Then DFinal = "NOVENTA Y " & DFinal Else DFinal = "NOVENTA"
End Select
'Procesa las centenas
Select Case D3
Case "1": If B1 Or B2 Then DFinal = "CIENTO " & DFinal Else DFinal = "CIEN"
Case "2": If B1 Or B2 Then DFinal = "DOSCIENTOS " & DFinal Else DFinal = "DOSCIENTOS"
Case "3": If B1 Or B2 Then DFinal = "TRESCIENTOS " & DFinal Else DFinal = "TRESCIENTOS"
Case "4": If B1 Or B2 Then DFinal = "CUATROCIENTOS " & DFinal Else DFinal = "CUATROCIENTOS"
Case "5": If B1 Or B2 Then DFinal = "QUINIENTOS " & DFinal Else DFinal = "QUINIENTOS"
Case "6": If B1 Or B2 Then DFinal = "SEISCIENTOS " & DFinal Else DFinal = "SEISCIENTOS"
Case "7": If B1 Or B2 Then DFinal = "SETECINETOS " & DFinal Else DFinal = "SETECIENTOS"
Case "8": If B1 Or B2 Then DFinal = "OCHOCIENTOS " & DFinal Else DFinal = "OCHOCIENTOS"
Case "9": If B1 Or B2 Then DFinal = "NOVECIENTOS " & DFinal Else DFinal = "NOVECIENTOS"
End Select
'Si es la ejecuci�n principal efectua algunos arreglines
If xInternal = 1 Then
'Validaci�n del cero
If Trim(DFinal) = 0 Then DFinal = "CERO"
'Validaci�n de terminados en "un"
If Right(DFinal, 2) = "UN" And Len(TipoCambioSingular) = 0 Then DFinal = DFinal & "O"
End If
Else 'Si es m�s de una centena, las separa y procesa independientemente
Y = -1
Z = 1
For X = UBound(vNum) To 0 Step -1
Y = Y + 1
'Convierte la centena en palabras
tNum = WordNum(vNum(X), xInternal:=2)
'Arregla la terminaci�n "uno" cuando corresponde
If Y = 0 And Right(tNum, 2) = "UN" And TipoCambioSingular & TipoCambioPlural = "" Then tNum = tNum + "O"
'Genera un valor temporal para poder modificar
sTmp = tNum
'Asigna los nombres gen�ricos principales
Nombres = Split(" MIL , MILL�N , MILLONES , Bill�n , Billones , Trill�n , Trillones , Cuatrill�n , cuatrillones , quintill�n , quintillones , sextill�n , sextillones , septill�n , septillones , octill�n , octillones , nonill�n , nonillones , decill�n , decillones , undecill�n , undecillones , duodecill�n , duodecillones , tredecill�n , tredecillones , cuatordecill�n , cuatordecillones , quindecill�n , quindecillones , sexdecill�n , sexdecillones , septendecill�n , septendecillones , octodecill�n , octodecillones , novendecill�n , novendecillones , vigintill�n , vigintillones ", ",")
'Controla que el �ndice de nombres no salga de los l�mites
If Y > UBound(Nombres) Then
WordNum = "?"
Exit Function
End If
'Asigna los nombres correspondientes
If Y Mod 2 > 0 Then
D1 = Nombres(0)
D2 = Nombres(Y - 1)
ElseIf Y > 0 Then
D1 = Nombres(Y - 1)
D2 = Nombres(Y)
Else
D1 = "": D2 = ""
End If
'Actualiza el nombre del n�mero
Select Case Y Mod 2
Case 0: If sTmp = "UN" Then sTmp = sTmp & D1 Else sTmp = sTmp & IIf(tNum = "", "", D2)
Case Else
If sTmp = "UN" Then sTmp = ""
sTmp = sTmp & IIf(tNum = "", "", D1)
If X = 0 And Y > 1 Then
If InStr(1, DFinal, D2, vbTextCompare) = 0 Then sTmp = sTmp & Mid(D2, 2)
End If
End Select
DFinal = sTmp & DFinal
Next
End If
End If
'Aplica el tipo de moneda cuando corresponda
If xInternal = 1 Then DFinal = DFinal & Space(1) & IIf(Format(sNum, "#0") = "1", TipoCambioSingular, TipoCambioPlural)
'Asigna el n�mero en palabras
WordNum = Trim(DFinal)
End Function
Text1.Text = WordNum(Text2.Text, "QUETZAL", "QUETZALES")funciona bien cuando uso esta cantidad 1500.00 pero cuando uso la coma para separ los miles no los conviete a texto solo copia la cantidad de esta forma 1.500.00, no solo con esta cantidad, lo hace con cualquier cantidad que este separado por una "," ya busque donde esta el error pero no di :-[ alguien seria tan amable para ayudarme.
Gracias
-
Hola:
Si el problema lo tienes en que cuando pones 1,500.00 en lugar de 1500.00 es muy facil una 'chapuza' pero evidentemente va a funcionar, si en tu llamada lo haces en lugar de así:
Text1.Text = WordNum(Text2.Text, "QUETZAL", "QUETZALES")
Con el Replace, que sólo actuará si la coma existe sustituyendo la coma por nulo
Text1.Text = WordNum(Replace(Text2.Text,",","") , "QUETZAL", "QUETZALES")
Fíjate que su funcion lo que hace es sNum = Trim(Replace(CStr(Numero), ",", ".")) con lo cual convierte tu 1,500.00 en 1.500.00
Saludos
-
Woo que bien muchas gracias funciona rebien
Gracias ;D
-
En la primera linea del Modulo:
sNum = Trim(Replace(CStr(Numero), ",", "."))
Modificala a esta:
sNum = Trim(Replace(CStr(Numero), ",", ""))
y asunto arreglado, a sí no tienes que hacer nada más para el
Label1.Caption = WordNum(Text1.Text, "Quetzal", "Quetzales")
;)