Asunto: Calcular RFC (Registro Federal del Contribuyente) México
Estimados,
Derivado a la necesidad de implementar el calculo de RFC en mis sistemas y no encontrar el código en la red para Delphi, me tuve que poner a trabajar y al fin quedo. No es un código muy estético pero funciona, y lo subo aquí para compartirlo con ustedes y a este sitio que tanto me ha ayudado. Agradeceré mucho a los expertos que puedan ir mejorando este código.
Código:
function rfc(Paterno,Materno,Nombre:string;fecha:TDateTime):string;
var apaterno,amaterno,anombre,afecha,completo,cliente,vale,vale2,numeros:string;
coef,resi,resultado,total,i,formulados:Integer;
begin
//OBTENER LA PRIMERA LETRA DEL APELLIDO PATERNO Y LA PRIMERA VOCAL
for i:=1 to Length(Paterno) do
begin
vale2 := Copy(Paterno,i,1);
case vale2[1] of
'A','a': begin
apaterno := Copy(Paterno,1,1) + 'A';
Break;
end;
'E','e': begin
apaterno :=Copy(Paterno,1,1) + 'E';
Break;
end;
'I','i': begin
apaterno :=Copy(Paterno,1,1) + 'I';
Break;
end;
'O','o': begin
apaterno :=Copy(Paterno,1,1) + 'O';
Break;
end;
'U','u': begin
apaterno :=Copy(Paterno,1,1) + 'U';
Break;
end;
end;
end;
if Materno = '' THEN
begin
amaterno := UpperCase(Nombre);
SetLength (amaterno,1);
Result := amaterno;
aNombre := StringReplace(UpperCase(Nombre), 'JOSE ','',[rfReplaceAll]);
aNombre := StringReplace(UpperCase(anombre), 'MARIA ','',[rfReplaceAll]);
for i:=1 to Length(aNombre) do
begin
vale2 := Copy(Nombre,i,1);
case vale2[1] of
'A','a': begin
anombre := 'A';
Break;
end;
'E','e': begin
anombre :='E';
Break;
end;
'I','i': begin
apaterno := 'I';
Break;
end;
'O','o': begin
apaterno := 'O';
Break;
end;
'U','u': begin
apaterno := 'U';
Break;
end;
end;
end;
completo := apaterno + anombre + amaterno;
Result := UpperCase(completo);
end
else
begin
amaterno := Materno;
SetLength(aMaterno,1);
Result := aMaterno;
anombre := StringReplace(UpperCase(Nombre), 'JOSE ','',[rfReplaceAll]);
anombre := StringReplace(UpperCase(anombre), 'MARIA ','',[rfReplaceAll]);
Result := anombre;
SetLength(aNombre,1);
Result := anombre;
completo := UpperCase(apaterno + amaterno + anombre);
END;
if AnsiIndexText( completo, ['BUEI','BUEY','CACA','CACO','CAGA','CAGO',
'CAKA','COGE','COJA','COJE','COJI','COJO','CULO','FETO','GUEY','JOTO','KACA','KACO','KAGA',
'KAGO','KOGE','KOGO','KAKA','KULO','MAME','MAMO','MEAR','MEON','MION','MOCO','MULA','PEDA',
'PEDO','PENE','PUTO','PUTA','QULO','RATA','RUIN']) >=0 then
begin
afecha := FormatDateTime('YYMMDD',fecha);
SetLength ( afecha, 6);
Result := afecha;
anombre := 'X';
completo:= apaterno + amaterno + aNombre + afecha;
Result := UpperCase(completo);
end
else
begin
afecha := FormatDateTime('YYMMDD',fecha);
SetLength ( afecha, 6);
Result := afecha;
//sE TOMAN GRUPOS DE DOS CARACTERES NUMERICOS Y SE MULTIPLICA
//POR EL SEGUNDO CARACTER, SE REPETIRA ESTE PROCESO HASTA TERMINAR CON LA SERIE
for i:=1 to Length(numeros) do
begin
vale := Copy(numeros,i,2);
vale2 := Copy(numeros,i+1,1);
if vale2 = '' then
else
begin
total := StrToInt(vale) * StrToInt(vale2);
resultado := resultado + total;
end;
end;
cliente := completo + vale2;
numeros := '';
//OBTENEMOS LA SERIE DE NUMEROS CORRESPONDIENTES A NUESTRO NOMBRE
//TOMANDO ESTOS VALORES DEL ANEXO III
for i:=1 to Length(cliente) do
begin
vale := Copy(cliente,i,1);
case vale[1] of
'0': numeros := numeros + '00';
'1': numeros := numeros + '01';
'2': numeros := numeros + '02';
'3': numeros := numeros + '03';
'4': numeros := numeros + '04';
'5': numeros := numeros + '05';
'6': numeros := numeros + '06';
'7': numeros := numeros + '07';
'8': numeros := numeros + '08';
'9': numeros := numeros + '09';
'A','a': numeros := numeros + '10';
'B','b': numeros := numeros + '11';
'C','c': numeros := numeros + '12';
'D','d': numeros := numeros + '13';
'E','e': numeros := numeros + '14';
'F','f': numeros := numeros + '15';
'G','g': numeros := numeros + '16';
'H','h': numeros := numeros + '17';
'I','i': numeros := numeros + '18';
'J','j': numeros := numeros + '19';
'K','k': numeros := numeros + '20';
'L','l': numeros := numeros + '21';
'M','m': numeros := numeros + '22';
'N','n': numeros := numeros + '23';
'&': numeros := numeros + '24';
'O','o': numeros := numeros + '25';
'P','p': numeros := numeros + '26';
'Q','q': numeros := numeros + '27';
'R','r': numeros := numeros + '28';
'S','s': numeros := numeros + '29';
'T','t': numeros := numeros + '30';
'U','u': numeros := numeros + '31';
'V','v': numeros := numeros + '32';
'W','w': numeros := numeros + '33';
'X','x': numeros := numeros + '34';
'Y','y': numeros := numeros + '35';
'Z','z': numeros := numeros + '36';
' ': numeros := numeros + '37';
'Ñ','ñ': numeros := numeros + '38';
end;
end;
//SE TOMA EL VALO DE CADA LETRA SEGUN EL VALOR DEL ANEXO III Y SE APLICA EN LA FORMULA
//EN FORMA DESCENDENTE DESDE LA POSICION NUMERO 13
formulados := ((StrToInt(copy(numeros,1,2))*13)+ (StrToInt(copy(numeros,3,2))*12) + (StrToInt(copy(numeros,5,2))*11) +
(StrToInt(copy(numeros,7,2))*10) + (StrToInt(copy(numeros,9,2))*9) + (StrToInt(copy(numeros,11,2))*8) +
(StrToInt(copy(numeros,13,2))*7) + (StrToInt(copy(numeros,15,2))*6) + (StrToInt(copy(numeros,17,2))*5) +
(StrToInt(copy(numeros,19,2))*4) + (StrToInt(copy(numeros,21,2))*3) + (StrToInt(copy(numeros,23,2))*2));
//Obtener el residuo de la formula entre 11
formulados := formulados mod 11;
//SI EL RESIDUO ES MAYOR A 0 SE RESTARA 11 - EL RESIDIO Y EL RESULTADO SERÁ EL DIGITO VERIFICADOR.
if formulados > 0 then
cliente := cliente + IntToStr(11 - formulados)
else
cliente := cliente + IntToStr(formulados);
Result := UpperCase(cliente);
end;
Se añadieron algunos comentarios, y reconstrucción del RFC cuando no tienen apellido Materno.
Publicado:
Lun Jul 21, 2014 11:04 pm
alonsojpd Administrador/Moderador
Registrado: Sep 16, 2003 Mensajes: 2687
Asunto: Re: Calcular RFC (Registro Federal del Contribuyente) México
Puede publicar nuevos temas en este foro No puede responder a temas en este foro No puede editar sus mensajes en este foro No puede borrar sus mensajes en este foro No puede votar en encuestas en este foro
Visita nuestro nuevo sitio web con programas y contenidos actualizados: Proyecto A