Ver Mensaje Individual
  #10  
Antiguo 08-06-2007
Avatar de Goyo
Goyo Goyo is offline
Miembro
 
Registrado: feb 2006
Posts: 89
Reputación: 19
Goyo Va por buen camino
Question encontre este codigo para obtener el RFC

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
//   *** QUITA / ' .
   VPASO := TRIM(VAPL1) ;    P8()  ;  VAPL11 := VPASO ;
   VPASO := TRIM(VAPL2) ;    P8()  ;  VAPL21 := VPASO ;
   VPASO := TRIM(VNOM ) ;    P8()  ;  VNOM1  := VPASO ;
//** QUITA CARACTERES ESPECIALES
   VPASO := VAPL11      ;    P7()  ;  VAPL11 := VPASO ;
   VPASO := VAPL21      ;    P7()  ;  VAPL21 := VPASO ;
   VPASO := VNOM1       ;    P7()  ;  VNOM1  := VPASO ;
//** QUITA MARIA Y JOSE
   VPASO := VNOM1       ;    P9()  ;  VNOM1  := VPASO ;
//** QUITA PROPOSICIONES
   VPASO := VAPL11      ;   P10()  ;  VAPL11 := VPASO ;
   VPASO := VAPL21      ;   P10()  ;  VAPL21 := VPASO ;
   VPASO := VNOM1       ;   P10()  ;  VNOM1  := VPASO ;
//*** QUITO PALABRAS COMPUESTAS
   VPASO := VAPL11      ;   P11()  ;  VAPL11 := VPASO ;
   VPASO := VAPL21      ;   P11()  ;  VAPL21 := VPASO ;
   VPASO := VNOM1       ;   P11()  ;  VNOM1  := VPASO ;
//*** CREA LAS PRIMERAS 4 LETRAS DE LA RAIZ
//*** APELLIDO PATERNO
   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 ; //cancela el ciclo
            end;
        end; //NEXT;
       VRAIZ := VRAIZ+VLET ;
      END;

//   *** APELLIDO MATERNO
   IF LENGTh(VAPL21) = 0 THEN VRAIZ := VRAIZ+'X'
   ELSE                       VRAIZ := VRAIZ+COPY(VAPL21,1,1);
//   *** NOMBRE
   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);//           RIGHT(VRAIZ,2)
         Break; //EXIT
         end;
   end;

//   *** FECHA NACIMIENTO, SEXO Y E.F.
         VRAIZ := VRAIZ+VFEC_ANIO+VFEC_MES+VFEC_DIA+VSEXO+VENT ;
{         VRAIZ := VRAIZ+RIGHT(STR(VFEC_ANIO,4),2)+
         REPL('0',2-LEN(LTRIM(STR(VFEC_MES,2))))+ LTRIM(STR(VFEC_MES,2))+
         REPL('0',2-LEN(LTRIM(STR(VFEC_DIA,2))))+
         LTRIM(STR(VFEC_DIA,2))+
         VSEXO+
         VENT
 }
{   IF LEVEL1 = 2 .AND. LEVEL2 = 1
         VRAIZ = VRAIZ+RIGHT(STR(VFEC_ANIO,4),2)+REPL('0',2-LEN(LTRIM(STR(VFEC_MES,2))))+LTRIM(STR(VFEC_MES,2))+REPL('0',2-LEN(LTRIM(STR(VFEC_DIA,2))))+LTRIM(STR(VFEC_DIA,2))+VSEXO+VENT
   ELSE
      IF level1 = 1 .and. level2 = 3
         VRAIZ = VRAIZ+RIGHT(STR(VFEC_ANIO,4),2)+REPL('0',2-LEN(LTRIM(STR(VFEC_MES,2))))+LTRIM(STR(VFEC_MES,2))+REPL('0',2-LEN(LTRIM(STR(VFEC_DIA,2))))+LTRIM(STR(VFEC_DIA,2))+VSEXO+VENT
      ELSE
         VRAIZ = VRAIZ+RIGHT(STR(VFEC_ANIO,4),2)+REPL('0',2-LEN(LTRIM(STR(VFEC_MES,2))))+LTRIM(STR(VFEC_MES,2))+REPL('0',2-LEN(LTRIM(STR(VFEC_DIA,2))))+LTRIM(STR(VFEC_DIA,2))+VSEXO+VENT
      ENDIF
   ENDIF}
//   *** CONSONANTES INTERNAS
   VPASO := VAPL11   ; P12();
   VPASO := VAPL21   ; P12();
   VPASO := VNOM1    ; P12();
//   *** FIN DE RUTINAS
end;
Procedure P7;
VAR VI : INTEGER;
VLETRA : CHAR;
begin
//** SUSTITUYE CARACTERES ESPECIALES POR X
  FOR VI := 1 TO LENGTH(VPASO)  DO
                BEGIN  //ord devuelve el codigo ASCII
                   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
//** QUITA LAS / Y '
//  VLEN = LEN(VPASO)
  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
//        VLEFT  = LEFT(VPASO,VI-1)
//        VRIGHT = RIGHT(VPASO,VLEN-VI)
        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
//** QUITA JOSE Y MARIA
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
//** QUITA PREPOSICIONES
        VI := 0;
        WHILE VI < 20 DO
 //FOR VI := 1 TO 19 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
//** QUITA PALABRAS COMPUESTAS
 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
//** CONSONANTES INTERNAS
      //  MessageDlg('VPASO= '+VPASO , mtWarning, [mbOK], 0);
 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
Responder Con Cita