Calculo del RFC Buen dia, aqui les dejo una pequeña funcion para calcular el RFC por si a alguien le sirve... trabajando en la de la CURP, Saludos Primera Parte: Friend Function Calcula_RFC(ByVal Nombres As String, ByVal APaterno As String, ByVal AMaterno As String, ByVal FNacimiento As Date) As String '-------------------------------------------------------------------------------------------------- 'Algoritmo para el calculo del RFC, by: Edgar Uranda Estrada 18/11/2009 -------------------------- '-------------------------------------------------------------------------------------------------- Dim NombresNulos As String = "JOSE,MARIA,MA.,MA,DE,LA,LAS,MC,VON,DEL,LOS,Y, MAC, VAN" '-------------------------------------------------------------------------------------------------- 'Quitando caracteres especiales Dim ExpresionRegular As RegularExpressions.Regex = New RegularExpressions.Regex("[^a-zA-Z0-9 ]") Dim StringNormalizada As String 'Nombres sin caracteres StringNormalizada = Nombres.Normalize(NormalizationForm.FormD) Nombres = ExpresionRegular.Replace(StringNormalizada, "") 'Apellido Paterno sin caracteres If APaterno <> "" Then StringNormalizada = APaterno.Normalize(NormalizationForm.FormD) APaterno = ExpresionRegular.Replace(StringNormalizada, "") End If 'Apellido Materno sin caracteres If AMaterno <> "" Then StringNormalizada = AMaterno.Normalize(NormalizationForm.FormD) AMaterno = ExpresionRegular.Replace(StringNormalizada, "") End If '------------------------------------------------------------------------------------------------- Dim RFC As String 'Procesando Nombres y quitando nulos Dim ArrayNombres() As String = Split(Nombres) Dim Nombre As String For Each NombreValida As String In ArrayNombres If InStr(NombresNulos, NombreValida, CompareMethod.Text) = 0 And ArrayNombres.Count > 1 Then Nombre = NombreValida Exit For Else Nombre = NombreValida End If Next 'ASIGNANDO LETRAS '------------------------------------------------------------------------------------------------------------ Dim Primeraletra As String Dim SegundaLetra As String Dim TerceraLetra As String Dim CuartaLetra As String Dim ApellidoPat As String Dim ApellidoMat As String If APaterno <> "" And AMaterno <> "" Then 'En el Caso de que tenga los dos Apelldios 'Procesando Apellido Paterno Dim ArrayApellidoPat() As String = Split(APaterno) For Each ApellidoPatValida As String In ArrayApellidoPat If InStr(NombresNulos, ApellidoPatValida, CompareMethod.Text) = 0 And ArrayApellidoPat.Count > 1 Then ApellidoPat = ApellidoPatValida Exit For Else ApellidoPat = ApellidoPatValida End If Next Primeraletra = Mid(ApellidoPat, 1, 1) 'Procesando Apellido Materno Dim ArrayApellidoMat() As String = Split(AMaterno) For Each ApellidoMatValida As String In ArrayApellidoMat If InStr(NombresNulos, ApellidoMatValida, CompareMethod.Text) = 0 And ArrayApellidoMat.Count > 1 Then ApellidoMat = ApellidoMatValida Exit For Else ApellidoMat = ApellidoMatValida End If Next 'Extrayendo la primera letra del Apellido Paterno y la primera vocal(si aplica) Dim StrVocales As String = "A,E,I,O,U" Primeraletra = Mid(ApellidoPat, 1, 1) If Len(ApellidoPat) > 2 Then 'En el Caso que el Apellido Paterno sea Mayor de dos letras 'Procesando Vocal For i = 2 To Len(ApellidoPat) If InStr(StrVocales, Mid(ApellidoPat, i, 1), CompareMethod.Text) > 0 Then SegundaLetra = Mid(ApellidoPat, i, 1) Exit For End If Next TerceraLetra = Mid(ApellidoMat, 1, 1) CuartaLetra = Mid(Nombre, 1, 1) Else 'Aplicando Regla "En los casos en que el apellido paterno de la persona física se componga 'de una o dos letras, la clave se formará de la siguiente manera: '1. La primera letra del apellido paterno. '2. La primera letra del apellido materno. '3. La primera y segunda letra del nombre." SegundaLetra = Mid(ApellidoMat, 1, 1) TerceraLetra = Mid(Nombre, 1, 1) CuartaLetra = Mid(Nombre, 2, 1) End If Else '-> En el caso de que no cuente con alguno de los dos Apellidos 'Aplicando Regla "En los casos en que la persona física tenga un solo apellido, se conformará 'con la primera y segunda letras del apellido paterno o materno, según figure en el acta de nacimiento, 'más la primera y segunda letras del nombre If APaterno = "" Then Dim ArrayApellidoMat() As String = Split(AMaterno) For Each ApellidoMatValida As String In ArrayApellidoMat If InStr(NombresNulos, ApellidoMatValida, CompareMethod.Text) = 0 And ArrayApellidoMat.Count > 1 Then ApellidoMat = ApellidoMatValida Exit For Else ApellidoMat = ApellidoMatValida End If Next Primeraletra = Mid(ApellidoMat, 1, 1) SegundaLetra = Mid(ApellidoMat, 2, 1) Else Dim ArrayApellidoPat() As String = Split(APaterno) For Each ApellidoPatValida As String In ArrayApellidoPat If InStr(NombresNulos, ApellidoPatValida, CompareMethod.Text) = 0 And ArrayApellidoPat.Count > 1 Then ApellidoPat = ApellidoPatValida Exit For Else ApellidoPat = ApellidoPatValida End If Next Primeraletra = Mid(ApellidoPat, 1, 1) SegundaLetra = Mid(ApellidoPat, 2, 1) End If TerceraLetra = Mid(Nombre, 1, 1) CuartaLetra = Mid(Nombre, 2, 1) End If |
Respuesta: Calculo del RFC 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 |
Respuesta: Calculo del RFC Gracias por el aporte solo hay que pedirle a algun moderador que lo cambie a los FAQ's |
Respuesta: Calculo del RFC Gracias Peterpay, me olvidaba esta en Visual Basic .Net. Saludos. |
La zona horaria es GMT -6. Ahora son las 22:17. |
Desarrollado por vBulletin® Versión 3.8.7
Derechos de Autor ©2000 - 2024, Jelsoft Enterprises Ltd.