Tecsitel_FactuGES2/Database/udfs/funciones.pas

unit funciones;

interface

function RtfToText(Cadena: PChar): PChar; cdecl; export;

implementation

uses
  Forms, Classes, SysUtils, StdCtrls, ComCtrls;


// Esta funci<63>n falla cuando hay caracteres especiales en el texto (<28>, por ejemplo).
// Mejor la de abajo.

function RtfToText2(Cadena: PChar): PChar;
var
  i: integer;
  CadenaAux1: String;

begin
  //Si no tiene ninguna llave no esta guardado como rtf
  if (Pos('{', Cadena) = 0) then
     Result := Cadena
  else
  //Esta guardado con rtf
  begin
    //Quitamos todo lo que est<73> antes de \fs1x
    i := Pos('\fs', Cadena);
    CadenaAux1 := Copy(Cadena, i, StrLen(Cadena)-1);

    //Quitamos la parte de delante \fs1x
    i:= Pos(' ', CadenaAux1);
    CadenaAux1 := Copy(PChar(CadenaAux1), i+1, StrLen(PChar(CadenaAux1))-1);

    //Quitamos todo lo de la parte de atras a partir de la primera barra \ que tengamos
    i:= Pos('\', CadenaAux1);
    CadenaAux1 := Copy(PChar(CadenaAux1), 0, i-1);

    Result := PChar(CadenaAux1);
  end;
end;


{
  Convert RTF enabled text to plain.
  http://www.delphipraxis.net/topic45179.html
}

// HAY QUE LIMPIAR LA CADENA DE ENTRADA DE SALTOS DE L<>NEA (#$D#$A) POR QUE
// SI NO, NO ES UNA CADENA CON TEXTO RTF V<>LIDO

function RtfToText(Cadena: PChar): PChar;
const
  SaltoLinea = #13#10; //--> #$D#$A
var
  aSource: string; // <- Para almacenar la cadena de entrada sin saltos de l<>nea
  Source: string;
  NChar: Integer;

  function ProcessGroupRecursevly: string;

  function HexToInt(HexStr: String): Integer;
  begin
    result := StrToInt('$' + HexStr);
  end;

  procedure SkipStar;
  var
     BracesOpened: Integer;
     Escaped: Boolean;
  begin
       BracesOpened:=1;
       Escaped:=false;
       while BracesOpened>0
             do begin
                Inc (NChar);
                case Source [NChar] of
                     '{': if Escaped
                             then Escaped:=false
                             else Inc (BracesOpened);
                     '}': if Escaped
                             then Escaped:=false
                             else Dec (BracesOpened);
                     '\': Escaped:=not Escaped;
                     else Escaped:=false;
                end;
             end;
  end;

  function UnicodeCharCode2ANSIChar (aCode: LongInt): Char;
  type
      TUnicode2ANSITable=array [$0410..$044f] of Char;
  const
       Unicode2ANSITable: TUnicode2AnsiTable=('<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>',
                                               '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>');
  begin
       if (Low (Unicode2ANSITable)<=aCode) and (aCode<=High (Unicode2ANSITable)) then
        UnicodeCharCode2ANSIChar:=Unicode2ANSITable [aCode]
       else UnicodeCharCode2ANSIChar:='?';
  end;

  var
     Control, NumericValue, TextValue: string;
  begin
       Result:='';
       Inc (NChar);
       while NChar<=Length (Source)
             do case Source [NChar] of
                     '{': Result:=Result+ProcessGroupRecursevly;
                     '}': begin
                               Inc (NChar);
                               Break;
                          end;
                     '\': begin
                               Inc (NChar);
                               case Source [NChar] of
                                    '''': begin
                                               Result:=Result+Chr (HexToInt (Copy (Source, NChar+1, 2)));
                                               Inc (NChar, 3);
                                          end;
                                    '~': Result:=Result+#$20;
                                    '*': SkipStar;
                                    'a'..'z': begin
                                                   Control:='';
                                                   while Source [NChar] in ['a'..'z']
                                                         do begin
                                                            Control:=Control+Source [NChar];
                                                            Inc (NChar);
                                                         end;
                                                   if Source [NChar]='-'
                                                      then begin
                                                           NumericValue:=Source [NChar];
                                                           Inc (NChar);
                                                      end
                                                      else NumericValue:='';
                                                    while Source [NChar] in ['0'..'9']
                                                          do begin
                                                             NumericValue:=NumericValue+Source [NChar];
                                                             Inc (NChar);
                                                          end;
                                                    if Source [NChar]='{'
                                                       then ProcessGroupRecursevly;
                                                    TextValue:='';
                                                    if not (Source [NChar] in ['a'..'z', '{', '}', '\'])
                                                       then begin
                                                            Inc (NChar);
                                                            while not (Source [NChar] in ['{', '}', '\'])
                                                                  do begin
                                                                     TextValue:=TextValue+Source [NChar];
                                                                     Inc (NChar);
                                                                  end;
                                                       end;
                                                    if (Control='line') or (Control='par')
                                                       then Result:=Result+#$0D#$0A
                                                       else if Control='tab'
                                                               then Result:=Result+#$09
                                                               else if Control='u'
                                                                       then Result:=Result+UnicodeCharCode2ANSIChar (StrToInt (NumericValue))
                                                                       else if Control='colortbl'
                                                                               then TextValue:='';
                                                   if Length (TextValue)>0
                                                      then if (not ((TextValue [Length (TextValue)]=';') and (Source [NChar]='}')))
                                                              then begin
                                                                   Result:=Result+TextValue;
                                                                   TextValue:='';
                                                              end;
                                              end;
                                    else begin
                                         Result:=Result+Source [NChar];
                                         Inc (NChar);
                                    end;
                               end;
                     end;
                     else begin
                          Result:=Result+Source [NChar];
                          Inc (NChar);
                     end;
             end;
  end;

  function InitSource: Boolean;
  var
     BracesCount: Integer;
     Escaped: Boolean;
  begin
       if Copy (aSource, 1, 5) <> '{\rtf' then
        InitSource:=false
       else begin
               Source:='';
               BracesCount:=0;
               Escaped:=false;
               NChar:=1;
               while (NChar<=Length (aSource)) and (BracesCount>=0)
                     do begin
                        if not (aSource [NChar] in [#$0D, #$0A])
                           then begin
                                Source:=Source+aSource [NChar];
                                case aSource [NChar] of
                                     '{': if not Escaped
                                             then Inc (BracesCount)
                                             else Escaped:=false;
                                     '}': if not Escaped
                                             then Dec (BracesCount)
                                             else Escaped:=false;
                                     '\': Escaped:=true;
                                     else Escaped:=false;
                                end;
                           end;
                        Inc (NChar);
                     end;
               InitSource:=BracesCount=0;
          end;
  end;

begin
  // Hay que quitar el salto de l<>nea al final de la aSource RTF
  aSource := StringReplace(Cadena, SaltoLinea, '', [rfreplaceall]);

  // o bien:
  //
  //aSource := Copy( cLinea, 1, length(cLinea)-2) );
  
  if InitSource then
  begin
    NChar:=1;
    Result:= PChar(ProcessGroupRecursevly);
  end
  else
    Result := PChar(aSource);
end;

end.