Programa Que Genere Rfc En Vb 6.0

[Eric Gonzalez]

HOLA MUCHACHOS, COMO ESTAN' OIGAN ESTOY EN UN GRAN APURO, LO K PASSA ES QUE NECESITO HACER UN PROGRAMA EN VB6.0 DONDE EL USUARIO DEBA DE INGREASR SU NOMBRE COMPLETO Y FECHA DE NACIMIENTO, Y A PARTIR DE ESO ME GENERE AUTOMATICAMENTE EL RFC (SIN HOMOCLAVE) MIREN TENGO ESTO:
Function calcular_rfc(NOMBRES_AUX As String, _
APATERNO_AUX As String, _
AMATERNO_AUX As String, _
FECHANACIMIENTO As Date) As String

Dim NOMBRES As String
Dim APATERNO As String
Dim AMATERNO As String
Dim T_NOMTOT As String
Dim NOMBRE1 As String 'PRIMER NOMBRE
Dim NOMBRE2 As String 'DEMAS NOMBRES
Dim NOMBRES_LONGITUD As Integer 'LONGITUD DE TODOS NOMBRES
Dim NOMBRE1_LONGITUD As Integer 'LONGITUD DEL PRIMER NOMBRE(MAS UNO,EL QUE SOBRA ES UN ESPACIO EN BLANCO)
Dim APATERNO1 As String 'PRIMER NOMBRE
Dim APATERNO2 As String 'DEMAS NOMBRES
Dim APATERNO_LONGITUD As Integer 'LONGITUD DE TODOS NOMBRES
Dim APATERNO1_LONGITUD As Integer 'LONGITUD DEL PRIMER NOMBRE(MAS UNO,EL QUE SOBRA ES UN ESPACIO EN BLANCO)
Dim AMATERNO1 As String 'PRIMER NOMBRE
Dim AMATERNO2 As String 'DEMAS NOMBRES
Dim AMATERNO_LONGITUD As Integer 'LONGITUD DE TODOS NOMBRES
Dim AMATERNO1_LONGITUD As Integer 'LONGITUD DEL PRIMER NOMBRE(MAS UNO,EL QUE SOBRA ES UN ESPACIO EN BLANCO)
Dim VARLOOPS As Integer 'VARIABLE PARA LOS LOOPS, SE INICIALIZA AL INICIR UN LOOP
Dim RFC As String
Dim T_NOMNUM As String 'Nombre numerico
Dim T_SUMA As Integer
Dim T_DIVID As Integer ' Dividendo
Dim T_MOD As Integer ' MOD de la division
Dim T_HOMOCLV As String ' Homoclave
Dim T_NUMERO As Integer ' Numero ASC asignado a un caracter
Dim T_PARCIAL As Integer ' Acumulado de la suma de los caracteres del RFC
Dim strAuxBusqueda00 As String ' se agrega variable para poder quitar los nombre de JOSE, MARIA,MA,etc.
Dim strAuxBusqueda01 As String ' se agrega variable para poder quitar los nombre de JOSE, MARIA,MA,etc.
Dim strAuxBusqueda02 As String ' se agrega variable para poder buscar A,E,I,O,U
Dim strChar00 As String ' se agrega variable para manejar substrings
Dim strChar01 As String ' se agrega variable para manejar substrings

'INICIALZA VARIABLES
NOMBRES = UCase(LTrim(RTrim(NOMBRES_AUX)))
APATERNO = UCase(LTrim(RTrim(APATERNO_AUX)))
AMATERNO = UCase(LTrim(RTrim(AMATERNO_AUX)))
T_NOMTOT = APATERNO + " " + AMATERNO + " " + NOMBRES
strAuxBusqueda00 = "JOSE,MARIA,MA.,MA,DE,LA,LAS,MC,VON,DEL,LOS,Y,MAC, VAN"
strAuxBusqueda01 = "DE,LA,LAS,MC,VON,DEL,LOS,Y,MAC,VAN"
strAuxBusqueda02 = "A,E,I,O,U"

'PROCESAR NOMBRES DE PILA
VARLOOPS = 0
While VARLOOPS <> 1
NOMBRES_LONGITUD = Len(NOMBRES)
NOMBRE1_LONGITUD = InStr(NOMBRES, " ")

If NOMBRE1_LONGITUD = 0 Then
NOMBRE1_LONGITUD = NOMBRES_LONGITUD
End If

NOMBRE1 = RTrim(Left$(NOMBRES, NOMBRE1_LONGITUD))
NOMBRE2 = LTrim(Right$(NOMBRES, NOMBRES_LONGITUD - NOMBRE1_LONGITUD))

'SE QUINTAN LOS NOMBRES DE JOSE, MARIA,MA,MA.
'IF NOMBRE1 IN ('JOSE','MARIA','MA.','MA','DE','LA','LAS','MC','V ON','DEL','LOS','Y','MAC','VAN') AND NOMBRE2 <> ''
'comparacion original y se cambio por instr
If InStr(strAuxBusqueda00, NOMBRE1) <> 0 And Len(NOMBRE2) <> 0 Then
NOMBRES = NOMBRE2
Else
VARLOOPS = 1
End If
Wend

'PROCESAMOS APELLIDOS, PATERNO EN UN LOOP
VARLOOPS = 0
While VARLOOPS <> 1
APATERNO_LONGITUD = Len(APATERNO)
APATERNO1_LONGITUD = InStr(APATERNO, " ")

If PATERNO1_LONGITUD = 0 Then
APATERNO1_LONGITUD = APATERNO_LONGITUD
End If

APATERNO1 = RTrim(Left$(APATERNO, APATERNO1_LONGITUD))
APATERNO2 = LTrim(Right$(APATERNO, APATERNO_LONGITUD - APATERNO1_LONGITUD))

'SE QUINTAN LOS SUFIJOS
'IF APATERNO1 IN ('DE','LA','LAS','MC','VON','DEL','LOS','Y','MAC', 'VAN') AND APATERNO2 <> ''
If InStr(strAuxBusqueda01, APATERNO1) <> 0 And Len(APATERNO2) <> 0 Then
APATERNO = APATERNO2
Else
VARLOOPS = 1
End If
Wend

'PROCESAMOS APELLIDOS, MATERNO EN UN LOOP
VARLOOPS = 0
While VARLOOPS <> 1
AMATERNO_LONGITUD = Len(AMATERNO)
AMATERNO1_LONGITUD = InStr(AMATERNO, " ")

If AMATERNO1_LONGITUD = 0 Then
AMATERNO1_LONGITUD = AMATERNO_LONGITUD
End If

AMATERNO1 = RTrim(Left$(AMATERNO, AMATERNO1_LONGITUD))
AMATERNO2 = LTrim(Right$(AMATERNO, AMATERNO_LONGITUD - AMATERNO1_LONGITUD))

'SE QUINTAN LOS SUFIJOS
'IF AMATERNO1 IN ('DE','LA','LAS','MC','VON','DEL','LOS','Y','MAC', 'VAN') AND AMATERNO2 <> ''
If InStr(strAuxBusqueda01, AMATERNO1) <> 0 And Len(AMATERNO2) <> 0 Then
AMATERNO = AMATERNO2
Else
VARLOOPS = 1
End If
Wend

'SE OBTIENE DEL PRIMER APELLIDO LA PRIMER LETRA Y LA PRIMER VOCAL INTERNA
RFC = Left$(APATERNO1, 1)
APATERNO1_LONGITUD = Len(APATERNO1)
VARLOOPS = 1 'EMPIEZA EN UNO POR LA PRIMERA LETRA SE LA VA A SALTAR

While APATERNO1_LONGITUD > VARLOOPS
VARLOOPS = VARLOOPS + 1

strChar00 = Mid$(APATERNO1, VARLOOPS, 1)
'IF SUBSTRING(APATERNO1,VARLOOPS,1) IN ('A','E','I','O','U')
If InStr(strAuxBusqueda02, strChar00) > 0 Then
RFC = RTrim(RFC) + strChar00
VARLOOPS = APATERNO1_LONGITUD
End If
Wend

'SE OBTIENE LA PRIMER LETRA DEL APELLIDO MATERNO SI NO TIENE APELLIDO MATERNO SE PONE UNA X
'DICE QUE SI NO TIENE APELLIDO MATERNO LE PONGAS LA PRIMER LETRA DEL APELLIDO PATERNO EN EL RFX

If Len(AMATERNO1) = 0 Then
RFC = RTrim(RFC) + Mid$(APATERNO1, 1, 1)
Else
RFC = RTrim(RFC) + Mid$(AMATERNO1, 1, 1)
End If

'SE LE AGREGA LA PRIMER LETRA DEL NOMBRE
RFC = RTrim(RFC) + Mid$(NOMBRE1, 1, 1)

'CHECAS QUE NO SEA UNA PALARA INCONVENIENTE
'
'IF EXISTS ( SELECT INC_PALINC FROM NINCO WHERE INC_PALINC = RFC )
'BEGIN
'SELECT RFC = LTRIM(RTRIM (SUBSTRING (RFC , 1 , 3))) + 'X'
'END

'SE LE AGREGA LA FECHA DE NACIMIENTO

Set RFC = RTrim(RFC) + CONVERT(Char, FECHANACIMIENTO, 12)
RFC = RTrim(RFC) + Format(FECHANACIMIENTO, "yymmdd")

calcular_rfc = RFC

End Function
---------------------------------------------------------

PERO NO SE COMO MANDAR LLAMAR LA FUNCION O CUALES BOTONES SON LOS QUE TENGO QUE AGREGAR AL FORMULARIO

ESPERO RESPUESTAS
SALUDOS

[manuelmarca17]

sii sabes yo tengo el mismo problema y tu codigo sta correcto solo me mete un error en la parte final :
Set RFC = RTrim(RFC) + CONVERT(Char, FECHANACIMIENTO, 12)
RFC = RTrim(RFC) + Format(FECHANACIMIENTO, "yymmdd")

calcular_rfc = RFC

en la parte de CONVERT y solo me toma la primira letra del apellido paterno no me sta agarrando la primer vocal despues de la letra inicial del apellido paterno y tmb si no tengo el apellido materno no me da x me duplica la letra del apellido paterno y por ultimo en RFC en las que se forman palabras extrañas como lo es caca se debe de poner en la ultima a una x en lugar de la a

bno y si puedes resolverlo staria genial ya intente y no puedo corregir
lo que a ti te hace falta es enlazar todas las cajas de texto a te recomiendo que sigas los nombres que trae tu codigo asi no batallaras tanto

[pkj]

Si aún no ha conseguido que funcione es que no ha puesto mucho interes.
¿has mirado la fecha del mensaje?

En fin, te daré mi opinión por si te sirve de algo.

El problema de no haber apellido materno lo solucionas añadiendo esta línea al comienzo de la función:

If Trim$(AMATERNO_AUX) = "" Then AMATERNO_AUX = "X"

no me he parado a buscar el fallo, si lo hay.

El problema de CONVERT es que el código está traducido de otro lenguaje al VB y esa línea es del lenguaje anterior, que no ha sido anulada. Anúlala y ya está.

Lo de que no te tome la segunda letra del primer apellido, a mi no me ha pasado.

Lo de las palabras inconvenientes está anulado pero no traducido a VB.

Como dices, la función se llamaría enlazando los valores.
Lo suyo sería poner 4 textbox y un botón y un código como:

Código :

Private Sub Command1_Click()
  MsgBox "RFC = " & calcular_rfc(Text1.Text, Text2.Text, Text3.Text, Text4.Text)
End Sub
 

Que se dé bien.