encontre este codigo para calcular el Registro Federal de Causantes (Contribuyentes) para personas fisicas... solo que no
se como aplicarlo, se que es un archivos *.pas pero no se como hacer el llamado para ver si funciona....
aqui les dejo es codigo en delphi:
Código Delphi
[-]
unit U_curp;
interface
uses SysUtils;
var
VLET, VPASO, VAPL1, VAPL11, VAPL2,VAPL21, VNOM, VNOM1, VRAIZ : STRING;
VFEC_ANIO, VFEC_MES, VFEC_DIA, VSEXO, VENT : STRING;
VLEN, VI: INTEGER ;
ATAB1 : array[0..18] of string = ('DA ','DAS ','DE ','DEL ','DER ','DI ','DIE ',
'DD ','EL ' ,'LA ','LOS ','LAS ','LE ','LES ',
'MAC ','MC ','VAN ','VON ','Y ');
ATAB2 : array[0..74] of string = ( 'BUEI','BUEY','CACA','CACO','CAGA','CAGO','CAKA',
'CAKO','COGE', 'COGI', 'COJA', 'COJE', 'COJI', 'COJO',
'COLA', 'CULO', 'FALO', 'FETO', 'GETA', 'GUEI', 'GUEY',
'JETA', 'JOTO', 'KACA', 'KACO', 'KAGA', 'KAGO', 'KAKA',
'KAKO', 'KOGE', 'KOGI', 'KOJA', 'KOJE', 'KOJI', 'KOJO',
'KOLA', 'KULO', 'LILO', 'LOCA', 'LOCO', 'LOKA', 'LOKO',
'MAME', 'MAMO', 'MEAR', 'MEAS', 'MEON', 'MIAR', 'MION',
'MOCO', 'MOKO', 'MULA', 'MULO', 'NACA', 'NACO', 'PEDA',
'PEDO', 'PENE', 'PIPI', 'PITO', 'POPO', 'PUTA', 'PUTO',
'QULO', 'RATA', 'ROBA', 'ROBE', 'ROBO', 'RUIN', 'SENO',
'TETA', 'VUEI', 'VUEY', 'WUEI', 'WUEY');
Procedure curp ;
Procedure P7;
Procedure P8;
Procedure P9;
Procedure P10;
Procedure P11;
Procedure P12;
implementation
uses
Dialogs;
Procedure curp ;
VAR VI : INTEGER;
begin
VPASO := TRIM(VAPL1) ; P8() ; VAPL11 := VPASO ;
VPASO := TRIM(VAPL2) ; P8() ; VAPL21 := VPASO ;
VPASO := TRIM(VNOM ) ; P8() ; VNOM1 := VPASO ;
VPASO := VAPL11 ; P7() ; VAPL11 := VPASO ;
VPASO := VAPL21 ; P7() ; VAPL21 := VPASO ;
VPASO := VNOM1 ; P7() ; VNOM1 := VPASO ;
VPASO := VNOM1 ; P9() ; VNOM1 := VPASO ;
VPASO := VAPL11 ; P10() ; VAPL11 := VPASO ;
VPASO := VAPL21 ; P10() ; VAPL21 := VPASO ;
VPASO := VNOM1 ; P10() ; VNOM1 := VPASO ;
VPASO := VAPL11 ; P11() ; VAPL11 := VPASO ;
VPASO := VAPL21 ; P11() ; VAPL21 := VPASO ;
VPASO := VNOM1 ; P11() ; VNOM1 := VPASO ;
IF LENGTH(VAPL11) = 0 THEN VRAIZ := 'XX'
ELSE
BEGIN
VRAIZ := COPY(VAPL11,1,1);
VLET := 'X' ;
FOR VI := 2 TO LENGTH(VAPL11) DO
begin
IF Pos(copy(VAPL11,VI,1),'AEIOU') >0 then
begin
VLET := copy(VAPL11,VI,1);
Break ; end;
end; VRAIZ := VRAIZ+VLET ;
END;
IF LENGTh(VAPL21) = 0 THEN VRAIZ := VRAIZ+'X'
ELSE VRAIZ := VRAIZ+COPY(VAPL21,1,1);
IF LENgth(VNOM1) = 0 then VRAIZ := VRAIZ+'X'
ELSE VRAIZ := VRAIZ+copy(VNOM1 ,1,1);
FOR VI := 1 TO 75 do
begin
IF VRAIZ = ATAB2[VI] then
begin
VRAIZ := copy(VRAIZ,1,1)+'X'+copy(VRAIZ,LENGTH(VRAIZ)-1,2); Break; end;
end;
VRAIZ := VRAIZ+VFEC_ANIO+VFEC_MES+VFEC_DIA+VSEXO+VENT ;
VPASO := VAPL11 ; P12();
VPASO := VAPL21 ; P12();
VPASO := VNOM1 ; P12();
end;
Procedure P7;
VAR VI : INTEGER;
VLETRA : CHAR;
begin
FOR VI := 1 TO LENGTH(VPASO) DO
BEGIN VLETRA := VPASO[VI];
IF ((ord(VLETRA) < 65) OR (ord(VLETRA) > 90)) AND (copy(VPASO,VI,1) <> ' ') THEN
VPASO := COPY(VPASO,1,VI-1)+'X'+COPY(VPASO,LENGTH(VPASO)-(LENGTH(VPASO)-VI)+1,LENGTH(VPASO)-VI) ;
END;
end;
Procedure P8;
VAR VI : INTEGER ;
begin
FOR VI := 1 TO LENGTH(VPASO) DO
BEGIN
IF (COPY(VPASO,VI,1) = '/') OR (COPY(VPASO,VI,1) = #39) OR (COPY(VPASO,VI,1) = '.') THEN
BEGIN
VPASO := COPY(VPASO,1,VI-1)+' '+ COPY(VPASO,LENGTH(VPASO)-(LENGTH(VPASO)-VI)+1,LENGTH(VPASO)-VI) ;
END;
END;
VPASO := TRIM(VPASO);
end;
Procedure P9;
begin
IF (COPY(VPASO,1,4) = 'JOSE' ) AND (LENGTH(VPASO) = 4) THEN EXIT ;
IF (COPY(VPASO,1,1) = 'J' ) AND (LENGTH(VPASO) = 1) THEN EXIT ;
IF (COPY(VPASO,1,2) = 'J ' ) AND (LENGTH(VPASO) = 2) THEN EXIT ;
IF (COPY(VPASO,1,5) = 'MARIA') AND (LENGTH(VPASO) = 5) THEN EXIT ;
IF (COPY(VPASO,1,1) = 'M' ) AND (LENGTH(VPASO) = 1) THEN EXIT ;
IF (COPY(VPASO,1,2) = 'M ' ) AND (LENGTH(VPASO) = 2) THEN EXIT ;
IF (COPY(VPASO,1,2) = 'MA' ) AND (LENGTH(VPASO) = 2) THEN EXIT ;
IF (COPY(VPASO,1,3) = 'MA ' ) AND (LENGTH(VPASO) = 3) THEN EXIT ;
IF COPY(VPASO,1,5) = 'JOSE ' THEN BEGIN VPASO := COPY(VPASO,LENGTH(VPASO)-(LENGTH(VPASO)-5)+1, LENGTH(VPASO)-5); EXIT ; END;
IF COPY(VPASO,1,3) = 'J ' THEN BEGIN VPASO := COPY(VPASO,LENGTH(VPASO)-(LENGTH(VPASO)-3)+1, LENGTH(VPASO)-3); EXIT ; END;
IF COPY(VPASO,1,2) = 'J ' THEN BEGIN VPASO := COPY(VPASO,LENGTH(VPASO)-(LENGTH(VPASO)-2)+1, LENGTH(VPASO)-2); EXIT ; END;
IF COPY(VPASO,1,6) = 'MARIA ' THEN BEGIN VPASO := COPY(VPASO,LENGTH(VPASO)-(LENGTH(VPASO)-6)+1, LENGTH(VPASO)-6); EXIT ; END;
IF COPY(VPASO,1,3) = 'M ' THEN BEGIN VPASO := COPY(VPASO,LENGTH(VPASO)-(LENGTH(VPASO)-3)+1, LENGTH(VPASO)-3); EXIT ; END;
IF COPY(VPASO,1,2) = 'M ' THEN BEGIN VPASO := COPY(VPASO,LENGTH(VPASO)-(LENGTH(VPASO)-2)+1, LENGTH(VPASO)-2); EXIT ; END;
IF COPY(VPASO,1,4) = 'MA ' THEN BEGIN VPASO := COPY(VPASO,LENGTH(VPASO)-(LENGTH(VPASO)-4)+1, LENGTH(VPASO)-4); EXIT ; END;
IF COPY(VPASO,1,3) = 'MA ' THEN BEGIN VPASO := COPY(VPASO,LENGTH(VPASO)-(LENGTH(VPASO)-3)+1, LENGTH(VPASO)-3); EXIT ; END;
end;
Procedure P10;
VAR VI : INTEGER ;
begin
VI := 0;
WHILE VI < 20 DO
BEGIN
VI := VI+1 ;
IF COPY(VPASO,1,LENGTH(ATAB1[VI])) = ATAB1[VI] THEN
BEGIN
VPASO := TRIM(COPY(VPASO, LENGTH(VPASO)-(LENGTH(VPASO)-LENGTH(ATAB1[VI]))+1,LENGTH(VPASO)-LENGTH(ATAB1[VI])));
VI := 1 ;
END;
END;
end;
Procedure P11;
VAR VI : INTEGER;
begin
FOR VI := 1 TO LENGTH(VPASO) DO
BEGIN
IF COPY(VPASO,VI,1) = ' ' THEN
BEGIN
VPASO := COPY(VPASO,1,VI-1);
EXIT;
END;
END;
end;
Procedure P12;
VAR VLET : STRING;
VI : INTEGER;
begin
IF LENGTH(VPASO) = 0 THEN VRAIZ := VRAIZ+'X'
ELSE
BEGIN
VLET := 'X' ;
FOR VI := 2 TO LENGTH(VPASO) DO
BEGIN
IF POS(COPY(VPASO,VI,1),'BCDFGHJKLMNPQRSTVWXYZ')>0 THEN
BEGIN
VLET := COPY(VPASO,VI,1) ;
VRAIZ := VRAIZ+VLET ;
EXIT ;
END;
END;
END;
end;
end.
... si alguien lo puede implementar, favor de notificarlo... gracias