Calculo del RFC

[edgaruranda]

Segunda Parte:

'Procesando Fecha de Nacimiento------------------------------------------------------------------------------
Dim FechaNac As String
Dim AñoNac As String
Dim MesNac As String
Dim DiaNac As String

AñoNac = DatePart(DateInterval.Year, FNacimiento)
'Quitando los dos primeros caracteres del año
AñoNac = Mid(AñoNac, 3, 2).PadLeft(2, "0")
MesNac = DatePart(DateInterval.Month, FNacimiento)
MesNac = MesNac.PadLeft(2, "0")
DiaNac = DatePart(DateInterval.Day, FNacimiento)
DiaNac = DiaNac.PadLeft(2, "0")
FechaNac = AñoNac & MesNac & DiaNac

'Procesando Nombre Numerico ---------------------------------------------------------------------------------
Dim AnexoII As String = "&ABCDEFGHI_JKLMNOPQR__STUVWXYZÑ" 'Valores del Anexo II
Dim NombreCompleto As String
If APaterno <> "" And AMaterno <> "" Then
NombreCompleto = ApellidoPat & " " & ApellidoMat & " " & Nombres
Else
If APaterno = "" Then
NombreCompleto = ApellidoMat & " " & Nombres
Else
NombreCompleto = ApellidoPat & " " & Nombres
End If
End If
'convirtiendo nombre a numeros
Dim ValorAcumulado As String
For i = 1 To Len(NombreCompleto)
If InStr(AnexoII, Mid(NombreCompleto, i, 1), CompareMethod.Text) = 0 Then
ValorAcumulado = ValorAcumulado & "00"
Else
ValorAcumulado = ValorAcumulado & (InStr(AnexoII, Mid(NombreCompleto, i, 1), CompareMethod.Text) + 9)
End If
Next
'Se agrega un cero al valor de la primera letra para uniformar el criterio de los números a tomar de dos en dos
ValorAcumulado = "0" + ValorAcumulado
'Se efectuaran las multiplicaciones de los números tomados de dos en dos para la posición de la pareja
'Se suma el resultado de las multiplicaciones y del resultado obtenido, se tomaran las tres ultimas cifras
'y estas se dividen entre el factor 34, por que 34?, no lo se, si alguien lo sabe
'que me lo diga jeje, pero en fin, asi nos lo dicen nuestros amigos de la SHCP
Dim Suma As Double
Dim x As String
Dim y As String

For i = 1 To Len(ValorAcumulado) - 1
x = Mid(ValorAcumulado, i, 2)
y = Mid(x, 2, 1)
Suma = Suma + (x * y)
Next
'De la suma obtenemos los 3 últimos numeros
Suma = Right(Suma, 3)
'Obtenemos el cociente de la "Suma" dividiendo por el factor 34
Dim VarCociente As Double = Int(Suma / 34)
'Después calculamos el residuo
Dim VarResiduo As Double = Suma Mod 34
'Con el cociente y el residuo se asigna la homonimia
Dim AsignaHomonimas As String = "123456789ABCDEFGHIJKLMNPQRSTUVWXYZ"
Dim PrimeraHomonima As String = Mid(AsignaHomonimas, VarCociente + 1, 1)
Dim SegundaHomonimas As String = Mid(AsignaHomonimas, VarResiduo + 1, 1)
'Armando RFC
RFC = Primeraletra + SegundaLetra + TerceraLetra + CuartaLetra
'Verificamos si se forma alguna palablra "Inconveniente" con las 4 letras del RFC, digo a nadie nos gustaria que
'su RFC empieze con algunas de estas..
Dim STrInconvenientes As String = "BUEI,CACA,CAGA,CAKA,COGE,COJE,COJO,FETO,JOTO,KACO ,KAGO,KOJO,KULO,MAMO,MEAS,MION,MULA," & _
"PEDO,PUTA,QULO,RUIN,BUEY,CACO,CAGO,CAKO,COJA,COJI ,CULO,GUEY,KACA,KAGA,KOGE,KAKA,MAME," & _
"MEAR,MEON,MOCO,PEDA,PENE,PUTO,RATA"

If InStr(STrInconvenientes, RFC, CompareMethod.Text) > 0 Then
RFC = Primeraletra + SegundaLetra + TerceraLetra + "X" + FechaNac + PrimeraHomonima + SegundaHomonimas
Else
RFC = Primeraletra + SegundaLetra + TerceraLetra + CuartaLetra + FechaNac + PrimeraHomonima + SegundaHomonimas
End If
RFC = UCase(RFC)
'Procedimiento para calcular el digito verificador
'--------------------------------------------------------------------------------------------------------------------------------
'Se asignaran los valores del Anexo III a las letras y números del registro federal de contribuyentes formado a 12 posiciones
'Una vez asignados los valores se aplicara la siguiente forma tomando como base el factor 13 en orden descendente
'a cada letra y número del R.F.C. para su multiplicación, de acuerdo a la siguiente formula:
'(Vi * (Pi + 1)) + (Vi * (Pi + 1)) + ..............+ (Vi * (Pi + 1)) MOD 11
Dim Vi As Integer 'Valor asociado al carácter de acuerdo a la tabla del Anexo III.
Dim Pi As Integer 'Posición que ocupa el i-esimo carácter tomando de derecha a izquierda es decir P toma los valores de 1 a 12

Dim AnexoIII As String = "123456789ABCDEFGHIJKLMN&OPQRSTUVWXYZ Ñ" 'Valores del Anexo III
Dim SumaVerificador As Double
For i = 1 To 12
Pi = 14 - i
If InStr(AnexoIII, Mid(RFC, i, 1), CompareMethod.Text) = 0 Then
Vi = 0
Else
Vi = (InStr(AnexoIII, Mid(RFC, i, 1), CompareMethod.Text))
End If
SumaVerificador = SumaVerificador + (Vi * Pi)
Next

Dim ResiduoVerif As Double = SumaVerificador Mod 11
Dim DigitoVerif As String
'Si el residuo es igual a cero, este será el valor que se le asignara al dígito verificador.
'Si el residuo es mayor a cero se restara este al factor 11
'Si el residuo es igual a 10 el dígito verificador será “ A”.
Select Case ResiduoVerif
Case Is = 0
DigitoVerif = 0
Case Is > 0
DigitoVerif = 11 - ResiduoVerif
Case Is = 10
DigitoVerif = "A"
End Select

RFC = RFC & DigitoVerif

Calcula_RFC = RFC

End Function