Autor Tema: Aportando Código (Leído 1551 veces)

Castord · « **en:** Viernes 2 de Febrero de 2007, 21:49 »

Este ejemplo que desarrollé me sirvió bastante a la hora de imprimir en programas de facturación y demás... muy útil aquí y pienso que en otras partes del mundo..

Lée números y los imprime en su formato alfabetico(letras)

Código: Text

 
 
'===============================================
'  ALGORITMO DE LECTURA DE NUMEROS ENTEROS
'con un rango comprendido entre 1 y 999.999.999
'===============================================
'(C)Carlos Ruiz Díaz - Castord
'Asunción, 31-ENE-2007, Paraguay
'Todos los Derechos Reservados
'Carlos.RuizDiaz@gmail.com
'----------------------------------------------
'NO SE HACEN TODAS LAS VALIDACIONES NECESARIAS!
'       Código vb5, vb6 Win32 compatible
'               | CONTROLES |
'un text box, name=Text1
'un command button, name=Command1
'----------------------------------------------
'por favor, si encuentran bugs o realizan alguna
'clase de optimización, reportenmelo al mail
'adjunto, gracias.
'===============================================
 
Dim Unidades(1 To 9) As String
Dim Decenas(1 To 9) As String
Dim Especiales(11 To 19) As String
Dim Lect(1 To 3) As String
Dim nLect(1 To 3) As Integer
'---------------------------------
'Dim Millar As String
Dim Cent As String
'Dim Veinti As String
Dim Centenas(1 To 9) As String
Dim Grupo As Integer
'---------------------------------
 
Function Leer(Nro As String) As Boolean
'On Error GoTo Error
'On Error Resume Next
Dim Unidad As String, Decena As String, Centena As String
Dim Cifras As Integer
Dim Aux As String, Parte As String
 
Aux = vbNullString
 
Debug.Print Nro
 
If Val(Nro) = 0 Then 'si la cadena es por ej. '000' resultante del nro 1.000
    Grupo = Grupo + 1
    Lect(Grupo) = Aux
    Exit Function   'sale
End If
 
 
Cifras = Len(Nro)
 
Parte = Mid(Nro, 1, 1) 'extrae las centenas
If Parte &#62; 0 Then 'si es mayor a cero se consulta al vector y se asigna ya el texto respectivo
    Aux = Centenas(Parte)
End If
Parte = CInt(Right(Nro, 2)) 'extrae unidad y decena
 
Unidad = CInt(Right(Nro, 1))
Debug.Print Unidad
Decena = CInt(Mid(Nro, 2, 1))
Debug.Print Decena
Centena = CInt(Left(Nro, 1))
Debug.Print Centena
    
    '======se explicar por si solas algunas condicionales======
    
    If Centena = 0 And Decena = 0 And Unidad &#62; 0 Then 'para '001' por ej.
        Aux = Unidades(Unidad)
    ElseIf Unidad = 0 And Decena = 0 And Centena &#62; 0 Then '100' por ej.
        If Centena = 1 Then 'para cien
           Aux = &#34;cien&#34;
        Else '&#96;para versiones 'ciento'.. .ej. 101
            Aux = Centenas(Mid(Nro, 1, 1))
        End If
    ElseIf Decena = 0 And Unidad &#62; 0 Then '01' por ej.
        Aux = Aux & &#34; &#34; & Unidades(Unidad)
    ElseIf Unidad = 0 And Decena &#62; 0 Then '10' por ej.
        Decena = Mid(Nro, 2, 1)
        Aux = Aux & &#34; &#34; & Decenas(CInt(Decena))
    ElseIf Parte &#60; 20 Then 'para las versiones 'dieci', sin esto el resultado seria
                            'diez uno si el nro fuera 11
        Aux = Aux & &#34; &#34; & Especiales(Parte)
        
    ElseIf Parte &#62; 20 And Parte &#60; 30 Then 'para las versiones 'veinti', sin esto el resultado seria
                            'veinte uno si el nro fuera 21
        Parte = CInt(Mid(Nro, 3, 1))
        Aux = Aux & &#34; Veinti&#34; & Unidades(Parte)
    Else 'para nros, sin ceros &#62;30 y bla bla
        Parte = CInt(Mid(Nro, 2, 1))
        Aux = Aux & &#34; &#34; & Decenas(Parte)
        Parte = CInt(Mid(Nro, 3, 1))
        Aux = Aux & &#34; y &#34; & Unidades(Parte)
    End If
 
'LOS VALORES LLEGAN DE DERECHA A IZQUIERDA... En el nro. 1.000.123 se leerá 1ro.
'la porcion '123'
 
'el vector Lect(1)=CENTENAS
'el vector Lect(2)=MILLARES
'el vector Lect(3)=MILLONES
 
Grupo = Grupo + 1 'determina que parte se esta leyendo
Lect(Grupo) = Aux 'coloca aqui el texto
nLect(Grupo) = Val(Nro) 'coloca aqui el nro.
Nro = vbNullString
Leer = True
Exit Function
Error:
    Leer = False
    MsgBox Err.Description
End Function
 
Function SetearNro() As Boolean
On Error GoTo Error
Dim Nro As String, Parte As String, Limit As Integer
Nro = Text1.Text
If Val(Nro) &#62; 999999999 Or Val(Nro) &#60; 1 Then
    MsgBox &#34;Error en rango de lectura&#34;, vbInformation
    MsgBox &#34;1 al 999.999.999 nomás!&#34;
    SetearNro = False
    Exit Function
End If
'el programa toma los nros como cadenas de 3 caracteres por lo que esta sub es
'muy necesaria para que funcione
 
If Len(Nro) &#60; 3 Then 'si el nro fue por ej. '3' el resultado será '003'
                    ' para satisfacer la condicion
    Nro = String(3 - Len(Nro), &#34;0&#34;) & Nro
    'MsgBox Nro
End If
 
Parte = vbNullString
 
'los nros de descomponen al estilo notacional corriente... ej. 1.000.000
'donde el . (punto) es el separador de millares
 
'=====determinar el limite del bucle=======
'ej... el nro 100.000 tiene dos partes de 3 cifras por lo que
'de acuerdo el algoritmo de abajo el limite es 2. En el nro 1.100.123
'se tiene dos partes de 3 cifras y una de una cifra pero el bucle se debe ejecutar
'3 veces para poder tomar tb. el '1', ya que las porciones '100' y '123' cumplen
'con las condiciones de 3 cifras... para el caso del '1' se correrá el algoritmo
'correspondiente para comvertirlo a '001' y formar asi el nro 001.100.123 compatible
 
If (Len(Nro) / 3) &#62; (Round(Len(Nro) / 3)) Then
    Limit = Round(Len(Nro) / 3) + 1
Else
    Limit = Len(Nro) / 3
End If
 
For i = 1 To Limit
Debug.Print Nro
    If Len(Nro) &#60; 3 Then 'para nros de de longitud menor a 3, nunca debe entrar a la 1ra.
        Nro = String(3 - Len(Nro), &#34;0&#34;) & Nro
        'Nro = Right(Nro, Len(Nro))
        'MsgBox Nro
        Leer (Nro) 'pasa el arg. a la funcion de lectura
        Debug.Print Nro
    Else
        Parte = Right(Nro, 3) 'leer las ultimas 3 cifras del nro
        Debug.Print Parte
        Leer (Parte)
        Nro = Left(Nro, Len(Nro) - 3) 'extraer la parte leida de la cadena original
        Debug.Print Nro               'y reasignar a la var original el resto de la
                                      'cadena descompuesta
    End If
Next
SetearNro = True
Exit Function
Error:
    MsgBox Err.Description
    SetearNro = False
End Function
Private Sub Command1_Click()
Dim ok As Boolean
ok = SetearNro
If ok = False Then
    Exit Sub
End If
 
'==========================================
'diferenciar los millones, miles y centenas
'==========================================
Dim Texto As String
Texto = vbNullString
 
If Lect(3) &#60;&#62; vbNullString Then 'millones
    If nLect(3) = 1 Then
        Texto = &#34;Un millón &#34;
    Else
        Texto = Lect(3) & &#34; millones &#34;
    End If
End If
If Lect(2) &#60;&#62; vbNullString Then 'miles
    'If nLect(2) = 1 Then
     '   Texto = Texto & Lect(2) & &#34; mil &#34;
    'Else
        Texto = Texto & Lect(2) & &#34; mil &#34;
    'End If
End If
If Lect(1) &#60;&#62; vbNullString Then 'centenas
    Texto = Texto & Lect(1)
End If
 
Texto = Trim(Texto) 'sacar de la cadena los espacios en blanco en ambos lados
'MsgBox Texto, , &#34;TEXTO SIN FORMATO TITULO&#34;
MsgBox Estilo(Texto) 'texto en estilo titulo.
                        'Ej. &#34;ani reñembotavy nde tembo&#34; se verá
                        'como &#34;Ani Reñembotavy Nde Tembo&#34;
'================
' Reinicializar
'================
Grupo = 0
For i = 1 To UBound(Lect, 1)
    Lect(i) = vbNullString
    nLect(i) = 0
Next
End Sub
 
Function Estilo(Texto As String) As String
'On Error Resume Next
Dim i As Integer, Pos As String, SubStrPre As String, SubStrPos As String
Dim MayusChar As String
Dim Char As String
Dim n As String
For i = 1 To Len(Texto)
    Pos = InStr(i, Texto, &#34; &#34;) 'buscar espacios en blanco
    Debug.Print Pos
    Char = Mid(Texto, Pos + 1, 1) 'extraer el caracter luego del espacio en blaco
    Debug.Print Char
    SubStrPre = Left(Texto, Pos) 'extraer al cadena anterior al caracter
    Debug.Print SubStr
    SubStrPos = Right(Texto, Len(Texto) - (Pos + 1)) 'extraer la cadena posterior al char
    Debug.Print SubStrPos
    MayusChar = UCase(Char) 'convertir el char a su version muyuscula
    Texto = SubStrPre & MayusChar & SubStrPos 'concatenar la cadena anterior el caracter
                                            'y la cadena posterior en la var original
    Debug.Print Texto
Next
Estilo = Texto
 
 
End Function
 
Private Sub Command3_Click()
MsgBox Estilo(Text1.Text)
End Sub
 
Private Sub Form_Load()
'VECTORES DE CADENAS
Unidades(1) = &#34;uno&#34;
Unidades(2) = &#34;dos&#34;
Unidades(3) = &#34;tres&#34;
Unidades(4) = &#34;cuatro&#34;
Unidades(5) = &#34;cinco&#34;
Unidades(6) = &#34;seis&#34;
Unidades(7) = &#34;siete&#34;
Unidades(8) = &#34;ocho&#34;
Unidades(9) = &#34;nueve&#34;
 
Especiales(11) = &#34;once&#34;
Especiales(12) = &#34;doce&#34;
Especiales(13) = &#34;trece&#34;
Especiales(14) = &#34;catorce&#34;
Especiales(15) = &#34;quince&#34;
Especiales(16) = &#34;dieciseis&#34;
Especiales(17) = &#34;diecisiete&#34;
Especiales(18) = &#34;dieciocho&#34;
Especiales(19) = &#34;diecinueve&#34;
 
Decenas(1) = &#34;diez&#34;
Decenas(2) = &#34;veinte&#34;
Decenas(3) = &#34;treinta&#34;
Decenas(4) = &#34;cuarenta&#34;
Decenas(5) = &#34;cincuenta&#34;
Decenas(6) = &#34;sesenta&#34;
Decenas(7) = &#34;setenta&#34;
Decenas(8) = &#34;ochenta&#34;
Decenas(9) = &#34;noventa&#34;
 
Centenas(1) = &#34;ciento&#34;
Centenas(2) = &#34;doscientos&#34;
Centenas(3) = &#34;trescientos&#34;
Centenas(4) = &#34;cuatrocientos&#34;
Centenas(5) = &#34;quinientos&#34;
Centenas(6) = &#34;seiscientos&#34;
Centenas(7) = &#34;setecientos&#34;
Centenas(8) = &#34;ochocientos&#34;
Centenas(9) = &#34;novecientos&#34;
 
'Veinti = &#34;veinti&#34;
'Millar = &#34;mil&#34;
 
End Sub
 
 
 
 

Castord

ahhh...

fíjense y comenten

ElNapster

Al ingresar un valor fuera del rango te da una alerta, al querer yo ingresar otro valor permitido me siguie dando error ... me imagino que no se debe de estar limpiando una variable por ahi...
Pero esta interesante tu aporte ......

... va otra ingresa este valor 10g6 y veras el mensaje que te da ..

Castord

si... pasa que aclaré que no se verifican todas las variables ingresadas, puse eso como comentario...
fijate..

además... suprimí esa parte de validaciones porque la funcion que llamaba a escribir nros. siempre enviaba datos validos..

tb. se del 'error gramatical' al llamar a nros. como 1029... pasa que ignore eso debido a que las facturas aca siempre superan los millones...

SoloCodigo

Autor Tema: Aportando Código (Leído 1551 veces)

Castord

Aportando Código

Castord

Re: Aportando Código

ElNapster

Re: Aportando Código

Castord

Re: Aportando Código