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','VON','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