filtro inteligente

[[coso]]

Hola, os pongo aqui una unit que uso para crear un filtro SQL. La form correspondiente usa un TEdit y 3 TMemos (no visibles, y que pueden sustituirse por TStringList perfectamente). Lo que hace esta form es:

- filtra por el texto puesto
- filtra por fechas : si incluyes una fecha, filtra por esa fecha, si incluyes varias (con operadores) filtra entre esas. Si pones hoy / ayer, te filtra los q tienen campos datetime en hoy/ayer
- por numeros : con operadores...(para buscar igualdad en campo numerico, poniendo antes #)
- campos boolean, los cuales pueden tener sinonimos (p.ej, nombre de campo : cobrada; sinonimos->pagada, pagado, cobrado, cbr,etc...)

Código Delphi [-]
unit edSQL;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,ExtCtrls, StdCtrls, dbtables;

type
  T_edsql = class(TForm)
    Panel1: TPanel;
    Edit1: TEdit;
    Memo1: TMemo;
    Memo2: TMemo;
    Memo3: TMemo;
    procedure FormActivate(Sender: TObject);
    procedure Sustituir_sinonims;
    procedure Enllazos(sql : PString;cap : PString);
    procedure Aplicar_Proc_Ordenar;
    procedure Fer_Cadena_SQL;
    function  Fer_Cadena_Texte: string;
    function  Fer_Cadena_Nombres: string;
    function  Fer_Cadena_Dates : string;
    function  Fer_cadena_Boolean : string;
    procedure Edit1KeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure Requerir_filtre(q : TQuery; t, id : string);
    procedure Discriminar_texte;
    function  FormatejaData(dt: string): string;
    function  Camps_de_(s : string; q : TQuery) : TStringList;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);

  private
    { Private declarations }
  public
    { Public declarations }
    texte_del_edit : string;
    sinonims : TStringList;
    taula : string;
    query : TQuery;
    id_comp : string;
    SQL_Texte : string;
    proc_ordenar : procedure of object;
    extern_sql_txt : Pstring;
    extern_caption_txt : PString;
    fmt_dates_SQL : string;
    Comod_SQL     : string;
  end;

var
  _edsql: T_edsql;

implementation

uses db;

{$R *.DFM}

procedure T_edsql.Enllazos(sql : PString;cap : PString);
begin
        extern_sql_txt := sql;
        extern_caption_txt := cap;
end;

procedure T_edsql.Requerir_filtre(q : TQuery; t : string; id : string);
begin
        query   := q;
        taula   := t;
        id_comp := id;

        _Filtresql.Show;
end;

procedure T_edsql.FormActivate(Sender: TObject);
begin
        Edit1.Text := '';
        comod_SQL := '%';
        fmt_dates_SQL := '"#"mm"/"dd"/"yyyy"#"';
        Edit1.Top := (Panel1.Height - Edit1.height) div 2;
        Edit1.Left := (Panel1.Width - Edit1.Width) div 2;
        caption := 'Filtrar ' + Lowercase(taula);
end;

procedure T_edsql.Edit1KeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
        if Key = 27 then begin Edit1.Text := ''; close; end;
        if (Key = 13) then
        begin
                Sustituir_sinonims;
                Discriminar_texte;
                Fer_Cadena_SQL;
                Aplicar_Proc_Ordenar;

                Edit1.SelectAll;
                Edit1.SetFocus;
        end;
end;

procedure T_edsql.Aplicar_Proc_Ordenar;
begin
        extern_caption_txt^ := texte_del_edit;
        extern_sql_txt^ := SQL_texte;
        Proc_ordenar;
end;

procedure T_edsql.Sustituir_sinonims;
var
        i,r : integer;
        j,p : integer;
        cmp : TStringList;
        txt : string;
begin
        cmp := TStringList.Create;
        txt := ' ' + Edit1.Text + ' ';
        txt := StringReplace(txt,'  ',' ',[rfReplaceAll]);

        r := sinonims.Count;
        for i := 0 to r - 1 do
        begin
                cmp.CommaText := sinonims[i];
                p := cmp.Count;

                for j := 1 to p - 1 do
                        txt := StringReplace(txt,' '+cmp[j]+' ',' '+cmp[0]+' ',[rfReplaceAll,rfIgnoreCase]);
        end;

        txt := StringReplace(txt,'  ',' ',[rfReplaceAll]);
        texte_del_edit := txt;

        cmp.Free;
end;

procedure T_edsql.Fer_Cadena_SQL;
var
        cadena_txt : string;
        cadena_num : string;
        cadena_dat : string;
        cadena_bol : string;
begin
        SQL_texte := '';

        cadena_bol := Fer_Cadena_Boolean;
        cadena_num := Fer_Cadena_Nombres;
        cadena_txt := Fer_Cadena_texte;
        cadena_dat := Fer_Cadena_Dates;

        if cadena_num <> '' then SQL_texte := SQL_texte + cadena_num;

        if cadena_txt <> '' then
        begin
                if SQL_texte <> '' then SQL_texte := SQL_texte + ' or ';
                SQL_texte := SQL_texte + cadena_txt;
        end;
        if cadena_dat <> '' then
        begin
                if SQL_texte <> '' then SQL_texte := SQL_texte + ' and ';
                SQL_texte := SQL_texte + cadena_dat;
        end;

        if cadena_bol <> '' then
        begin
                if SQL_texte <> '' then SQL_texte := SQL_texte + ' and ';
                SQL_texte := SQL_texte + cadena_bol;
        end;

        if SQL_texte <> '' then SQL_texte := ' where ' + SQL_Texte;
end;

function T_edsql.Fer_cadena_Boolean : string;
var
        i,r : integer;
        camps_de_boolean : TStringList;
        txt : string;
        s   : string;
begin
        txt := '';

        camps_de_boolean := Camps_de_('boolean',query);

        if camps_de_boolean.Count = 0 then
        begin
                camps_de_boolean.Free;
                Fer_cadena_boolean := '';
                exit;
        end;

        r := Memo1.Lines.Count;
        for i := 0 to r - 1 do
        begin
                s := uppercase(Memo1.Lines[i]);
                if StrPos(PChar(Uppercase(camps_de_boolean.Text)),PChar(s)) <> nil then
                begin
                   if txt = '' then txt := Uppercase(s) + ' = true' else txt := txt + ' and ' + UpperCase(s) + ' = true';
                   Memo1.Lines.Delete(i);
                end;
        end;

        camps_de_boolean.Free;

        Fer_cadena_boolean := txt;
end;

function T_edsql.Fer_Cadena_Dates : string;
var
        i,r : integer;
        txt : string;
        camps_de_dates : TStringList;
        en_valors : string;
        operadors : string;
        val_s : string;
        val_min : TDateTime;
        val_max : TDateTime;
        val : TDateTime;
begin
        txt := '';
        r := memo3.Lines.Count;
        val_min := strtodate('1/1/1899');
        val_max := strtodate('31/12/9999');
        camps_de_dates := Camps_de_('datetime',query);

        if camps_de_dates.Count = 0 then
        begin
                camps_de_dates.Free;
                Fer_Cadena_Dates := '';
                exit;
        end;

        for i := 0 to r - 1 do
        begin
             val_s := StringReplace(Memo3.Lines[i],'<','',[rfReplaceAll,rfIgnoreCase]);
             val_s := StringReplace(val_s,'>','',[rfReplaceAll,rfIgnoreCase]);
             val   := strtodate(val_s);

             if (StrPos(PChar(memo3.lines[i]),'<')<> nil) then
             begin
                  if val < val_max then val_max := val;
             end
             else
             if (StrPos(PChar(memo3.lines[i]),'>') <> nil) then
             begin
                  if val > val_min then val_min := val;
             end
             else
             begin
                  if en_valors <> '' then en_valors := en_valors + ',' + FormatejaData(datetostr(val)) else
                  en_valors := '(' + FormatejaData(datetostr(Val));
             end;
        end;

        operadors := '';

        if (val_min > strtodate('1/1/1899')) and (val_max < strtodate('31/12/9999')) then
        begin
                operadors := ' between ' + FormatejaData(datetostr(val_min)) + ' and ' + FormatejaData(datetostr(val_max));
        end
        else
        begin
               if val_min > strtodate('1/1/1899') then
                  operadors := ' >' + FormatejaData(datetostr(val_min));

               if val_max < strtodate('31/12/9999') then
                  operadors := ' <' + FormatejaData(datetostr(val_max));
        end;

        if en_valors <> '' then en_valors := en_valors + ')';

        txt := '';
        r := camps_de_dates.Count;
        for i := 0 to r - 1 do
        begin
                if en_valors <> '' then
                begin
                    if txt <> '' then txt := txt + ' or ';
                    txt := txt + '(' + camps_de_dates[i] + ' in ' + en_valors + ')';
                end;

                if operadors <> '' then
                begin
                    if txt <> '' then txt := txt + ' or ';
                    txt := txt + '(' + camps_de_dates[i] + operadors + ')';
                end;
        end;

        camps_de_dates.Free;
        Fer_cadena_dates := txt;
end;

function T_edsql.FormatejaData(dt: string): string;
begin
     fmt_dates_SQL := '"#"mm"/"dd"/"yyyy"#"';
     FormatejaData := FormatDateTime(fmt_dates_SQL, strtodate(dt));
end;

function T_edsql.Fer_Cadena_nombres : string;
var
        i,r : integer;
        txt : string;
        camps_de_nombres : TStringList;
        en_valors : string;
        operadors : string;
        val_s : string;
        val_min : double;
        val_max : double;
        val : double;
begin
        txt := '';
        r := memo2.Lines.Count;
        val_min := -99999999;
        val_max :=  99999999;
        camps_de_nombres := Camps_de_('nombres',query);

        if camps_de_nombres.Count = 0 then
        begin
                camps_de_nombres.Free;
                Fer_cadena_nombres := '';
                exit;
        end;

        for i := 0 to r - 1 do
        begin
             val_s := StringReplace(Memo2.Lines[i],'<','',[rfReplaceAll,rfIgnoreCase]);
             val_s := StringReplace(val_s,'>','',[rfReplaceAll,rfIgnoreCase]);
             val   := strtofloat(val_s);

             if (StrPos(PChar(memo2.lines[i]),'<')<> nil) then
             begin
                  if val < val_max then val_max := val;
             end
             else
             if (StrPos(PChar(memo2.lines[i]),'>') <> nil) then
             begin
                  if val > val_min then val_min := val;
             end
             else
             begin
                  if en_valors <> '' then en_valors := en_valors + ',' + Memo2.Lines[i] else
                  en_valors := '(' + Memo2.Lines[i];
             end;
        end;

        operadors := '';

        if (val_min > -99999999) and (val_max < 99999999) then
        begin
                operadors := ' between ' + inttostr(Round(val_min)) + ' and ' + inttostr(Round(val_max));
        end
        else
        begin
               if val_min > -99999999 then
                  operadors := ' >' + inttostr(Round(val_min));

               if val_max < 99999999 then
                  operadors := ' <' + inttostr(Round(val_max));
        end;

        if en_valors <> '' then en_valors := en_valors + ')';

        txt := '';
        r := camps_de_nombres.Count;
        for i := 0 to r - 1 do
        begin
                if en_valors <> '' then
                begin
                    if txt <> '' then txt := txt + ' or ';
                    txt := txt + '(' + camps_de_nombres[i] + ' in ' + en_valors + ')';
                end;

                if operadors <> '' then
                begin
                    if txt <> '' then txt := txt + ' or ';
                    txt := txt + '(' + camps_de_nombres[i] + operadors + ')';
                end;
        end;

        Fer_cadena_nombres := txt;
        camps_de_nombres.Free;
end;

function T_edsql.Fer_Cadena_Texte : string;
var
        i,r : integer;
        txt : string;
        camps_txt : string;
        camps_de_texte : TStringList;
begin
        txt := '';
        camps_txt := '(';
        camps_de_texte := Camps_de_('texte',Query);

        if camps_de_texte.Count = 0 then
        begin
                camps_de_texte.Free;
                Fer_cadena_texte := '';
                exit;
        end;

        r := camps_de_texte.Count;
        for i := 0 to r - 1 do
        begin
             if camps_txt <> '(' then camps_txt := camps_txt + '+'' ''+';
             camps_txt := camps_txt + 'IIF('+Camps_de_texte[i] + ',' + Camps_de_texte[i] + ',''0'')';
        end;

        r := Memo1.Lines.Count;
        for i := 0 to r - 1 do
        begin
             if txt <> '' then txt := txt + ' and ';
             txt := txt + camps_txt + ' like '''+Comod_SQL +Memo1.Lines[i]+Comod_SQL + ''')';
        end;

        Camps_de_texte.Free;
        Fer_cadena_texte := txt;
end;

function T_edsql.Camps_de_(s : string; q : TQuery) : TStringList;
var
        i,r : integer;
        camp_data_type : TFieldType;
        ret : TStringList;
        no_buscar_a_id : boolean;
begin
        s := Lowercase(s);
        r := Query.FieldCount;
        ret := TStringList.Create;    // S'ha d'alliberar exteriorment!

        if (id_comp = 'nomes id') and ((s = 'nombres') or (s = 'enters')) then
        begin
             ret.Add('id');
             camps_de_ := ret;
             exit;
        end;

        no_buscar_a_id := lowercase(id_comp) = 'no id';

        for i := 0 to r-1 do
        begin
                if (no_buscar_a_id) and (Query.Fields[i].FieldName = 'id') then continue;

                camp_data_type := Query.Fields[i].DataType;
                if s = 'texte' then
                begin
                  if (camp_data_type = ftString) or
                     (camp_data_type = ftMemo) or
                     (camp_data_type = ftFmtMemo) or
                     (camp_data_type = ftFixedChar) or
                     (camp_data_type = ftWideString) then
                     ret.Add(Query.Fields[i].FieldName);
                end
                else
                if (s = 'nombres') then
                begin
                  if (camp_data_type = ftSmallInt) or
                     (camp_data_type = ftInteger) or
                     (camp_data_type = ftWord) or
                     (camp_data_type = ftAutoInc) or
                     (camp_data_type = ftLargeInt) or
                     (camp_data_type = ftFloat) or
                     (camp_data_type = ftCurrency) then
                     ret.Add(Query.Fields[i].FieldName);
                end
                else
                if (s = 'enters') then
                begin
                  if (camp_data_type = ftSmallInt) or
                     (camp_data_type = ftInteger) or
                     (camp_data_type = ftWord) or
                     (camp_data_type = ftAutoInc) or
                     (camp_data_type = ftLargeInt) then
                     ret.Add(Query.Fields[i].FieldName);
                end
                else
                if (s = 'floats') then
                begin
                  if (camp_data_type = ftFloat) or
                     (camp_data_type = ftCurrency) then
                     ret.Add(Query.Fields[i].FieldName);
                end
                else
                if (s = 'datetime') then
                begin
                  if (camp_data_type = ftDateTime) or
                     (camp_data_type = ftDate) or
                     (camp_data_type = ftTime) then
                     ret.Add(Query.Fields[i].FieldName);
                end
                else
                if (s = 'memos') then
                begin
                  if (camp_data_type = ftMemo) or
                     (camp_data_type = ftFmtMemo) then
                     ret.Add(Query.Fields[i].FieldName);
                end
                else
                if (s = 'boolean') then
                begin
                  if (camp_data_type = ftBoolean) then
                     ret.Add(Query.Fields[i].FieldName);
                end;
        end;

        Camps_de_ := ret;      // Pasem punter...s'allibera desde fora.
end;


procedure T_edsql.Discriminar_texte;
var
        i,cnt : integer;
        txt,txt_s : string;
begin

     Memo1.Lines.Commatext := Uppercase(texte_del_edit);
     memo2.Lines.Clear;
     Memo3.Lines.Clear;

     cnt := Memo1.Lines.Count;

     i := 0;
     while (i < cnt) do
     begin
          // Cadena
          txt := Memo1.Lines[i];
          // Cadena sense operador (per conversions)
          txt_s := StringReplace(txt,'<','',[rfReplaceAll,rfIgnoreCase]);
          txt_s := StringReplace(txt_s,'>','',[rfReplaceAll,rfIgnoreCase]);
          txt_s := StringReplace(txt_s,'#','',[rfReplaceAll,rfIgnoreCase]);

          // Numero
          if (txt <> txt_s) then
          try
               strtofloat(txt_s);
               txt := StringReplace(txt,'#','',[rfReplaceAll,rfIgnoreCase]);
               Memo2.Lines.Add(txt);
               Memo1.Lines.Delete(i);
               cnt := cnt - 1;
               dec(i);
          except
          end;

          //Data
          try
               strtodate(txt_s);
               Memo3.Lines.Add(txt);
               Memo1.Lines.Delete(i);
               cnt := cnt - 1;
               dec(i);
          except
          end;

          txt_s := uppercase(txt);
          if (txt_s = 'AVUI') or
              (txt_s = 'HOY') then
          begin
               Memo3.Lines.Add(datetostr(Date));
               Memo1.Lines.Delete(i);
               cnt := cnt - 1;
               dec(i);
          end
          else
          if (txt_s = 'AHIR') or
             (txt_s = 'AYER') then
          begin
               Memo3.Lines.Add(datetostr(Date - 1));
               Memo1.Lines.Delete(i);
               cnt := cnt - 1;
               dec(i);
          end;
          
          inc(i);
     end;
end;

procedure T_edsql.FormCreate(Sender: TObject);
begin
        Sinonims := TStringList.Create;
        getmem(extern_sql_txt,sizeof(PString));
        getmem(extern_caption_txt,sizeof(PString));
end;

procedure T_edsql.FormDestroy(Sender: TObject);
begin
        Sinonims.Free;
end;

end.

un pequeño ejemplo.

Código Delphi [-]
procedure T_lfact.Filtrar1Click(Sender : TObject);
begin
     _edSQL.Sinonims.Clear;
     _edSQL.Sinonims.Add('COBRADA PAGADA COBRADO PAGADO'); // el primero es el nombre del campo
     _edSQL.Proc_ordenar := Ordenar; // Procedimiento a llamar para ejecutar el SQL
     _edSQL.Enllazos(@SQL_Texte, @Caption_Texte); // string destino del SQL y otro string donde se mostrara lo del edit de _edSQL
     _edSQL.Requerir_filtre(dm.qFCT, 'FACTURES', 'no id'); 
// query destino; caption de _edSQL;filtro para campos numericos
end;

procedure T_lfact.Ordenar;
var
     id        : longint;
begin
     id := dm.qFCT.FieldByName('id').Asinteger;
     dm.qFCT.SQL.Text := 'select * from tFACT ' + SQL_texte + ' order by ' +
          Panel1.Caption;
     dm.qFCT.ExecSQL;
     dm.qFCT.Active := true;
     dm.qFCT.Locate('id', id, []);
     Posa_caption;
end;

[[coso]]

si bien no creo que os sirva asi tal cual, es facilmente customizalbe y os puede dar ideas o resolver alguna que otra duda.

saludos.

[[coso]]

customizable ^

[[coso]]

PD: _filtresql es una instancia de _edsql. X)

[ingabraham]

sera filtro bien largo, jeje

[[coso]]

la verdad es que si X) se puede optimizar (y asi lo uso ahora, mas optimizado) pero bueno, ya lo dejo como faena para quien lo quiera usar