afilter.pas

来自「delphi编程控件」· PAS 代码 · 共 921 行 · 第 1/2 页

unit afilter;
(*
 COPYRIGHT (c) RSD software 1997 - 98
 All Rights Reserved.
*)

interface

{$I aclver.inc}

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  DB, DBTables;

type
  TMacros = class;

  TMacroOption = (moSQL, moFilter);
  TMacroOptions  = set of TMacroOption;
  TMacrosFreeze = (mfAlways, mfDesigning, mfNever);

  TMacro = class(TObject)
  private
    FMacroList : TMacros;
    FName : String;
    FText: String;
  public
    MacroOptions : TMacroOptions;
    property Name: string read FName write FName;
    property Text : String read FText write FText;

    constructor Create(AMacroList: TMacros);
    destructor Destroy; override;

    procedure Assign(Macro: TMacro);
  end;

  TMacros = class(TPersistent)
  private
    FItems: TList;
    function GetMacro(Index: Word): TMacro;
    function GetMacroText(const MacroName: string): String;
    procedure SetMacroText(const MacroName: string; const Text: String);

    procedure ReadBinaryData(Stream: TStream);
    procedure WriteBinaryData(Stream: TStream);
  protected
    procedure AssignTo(Dest: TPersistent); override;
    procedure DefineProperties(Filer: TFiler); override;
  public
    constructor Create; virtual;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure AssignValues(Value: TMacros);
    procedure AddMacro(Value: TMacro);
    procedure RemoveMacro(Value: TMacro);
    function CreateMacro(const MacroName: string): TMacro;
    function Count: Integer;
    procedure Clear;
    function MacroByName(const Value: string): TMacro;
    property Items[Index: Word]: TMacro read GetMacro; default;
    property MacroText[const MacroName: string]: String read GetMacroText write SetMacroText;
  end;

  TAutoFilter = class;
  TFilterLink = class;

  EFilterLinkInvalidParam = class(Exception);

  TAutoComponentsRegister = class
  private
    List : TList;
    ComponentList : TList;
    FilterLinkList : TList;

    function GetAutoFilter(Index : Integer) : TAutoFilter;
    function GetFilterLink(Index : Integer) : TFilterLink;
    function GetComponent(Index : Integer) : TComponent;
  public
    constructor Create;
    destructor Destroy; override;

    procedure Add(AutoFilter : TAutoFilter);
    procedure AddFilterLink(FilterLink : TFilterLink);
    procedure Remove(AutoFilter : TAutoFilter);
    procedure RemoveFilterLink(FilterLink : TFilterLink);
    procedure GetAutoFilters(FList : TList; Component : TComponent);
    function Count : Integer;
    function ComponentCount : Integer;
    function FilterLinkCount : Integer;
    function ComponentIndexOf(Component : TComponent) : Integer;
    property Items[Index: Integer]: TAutoFilter read GetAutoFilter;  default;
    property FilterLinkItems[Index: Integer]: TFilterLink read GetFilterLink;
    property ComponentItems[Index: Integer]: TComponent read GetComponent;
  end;

  TAutoFilter = class(TPersistent)
  private
    FFilterLink : TList;
    FValue : String;
    FTextBefore : String;
    FTextAfter : String;
    FAssignEmpty : Boolean;

    function GetText : String;
    procedure SetTextBefore(Value : String);
    procedure SetTextAfter(Value : String);
    procedure SetValue(Value : String);
    procedure RefreshDataSets;
  public
    Owner : TComponent;
    OnBeforeChange: TNotifyEvent;
    OnAfterChange: TNotifyEvent;
    Name : String; 

    constructor Create(AOwner : TComponent);
    destructor Destroy; override;
    procedure Assign(Source : TPersistent); override;

    property Value : String read FValue write SetValue;
    property Text : String read GetText;
  published
    property AssignEmpty : Boolean read FAssignEmpty write FAssignEmpty;
    property TextBefore : String read FTextBefore write SetTextBefore;
    property TextAfter : String read FTextAfter write SetTextAfter;
  end;

  TFilterLink = class(TComponent)
  private
    FAutoRefresh : Boolean;
    FComponent : TComponent;
    FDataSet : TDataSet;
    FFilterName : String;
    FLoadFilterName : String;
    FMacro : String;
    FParam : String;
    List : TList;

    procedure SetDataSet(Value : TDataSet);
    procedure SetFilter(Value : TComponent);
    procedure SetFilterName(Value : String);
    procedure SetMacro(Value : String);
    procedure SetParam(Value : String);
  public
    AutoFilter : TAutoFilter;

    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Loaded; override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;

    function GetFilterComponent : TComponent;
    procedure RefreshDataSet;
  published
    property AutoRefresh : Boolean read FAutoRefresh write FAutoRefresh;  
    property DataSet : TDataSet read FDataSet write SetDataSet;
    property Filter : TComponent read FComponent write SetFilter;
    property FilterName : String read FFilterName write SetFilterName;
    property Macro : String read FMacro write SetMacro;
    property Param : String read FParam write SetParam;
  end;

Var
  AutoComponentsRegister : TAutoComponentsRegister;

function GetMacroText(DataSet : TDataSet; const MacroName : String) : String;  
procedure CreateMacros(List: TMacros; const Value: PChar; MacroOptions : TMacroOptions);

implementation

uses TypInfo, aclconst;

function GetMacroText(DataSet : TDataSet; const MacroName : String) : String;
Var
  i : Integer;
begin
  Result := '';
  if(AutoComponentsRegister = Nil) then exit;
  for i := 0 to AutoComponentsRegister.FilterLinkCount - 1 do
    if(AutoComponentsRegister.FilterLinkItems[i].DataSet = DataSet)
    And (CompareText(AutoComponentsRegister.FilterLinkItems[i].Macro, MacroName) = 0) then begin
      if(AutoComponentsRegister.FilterLinkItems[i].AutoFilter <> Nil) then
        Result := AutoComponentsRegister.FilterLinkItems[i].AutoFilter.Text;
      break;
    end;
end;

procedure CreateMacros(List: TMacros; const Value: PChar;MacroOptions : TMacroOptions);
var
  CurPos, StartPos: PChar;
  CurChar: Char;
  Literal: Boolean;
  EmbeddedLiteral: Boolean;
  Name: string;

  function NameDelimiter: Boolean;
  begin
    Result := CurChar in [' ', ',', ';', ')', #13, #10];
  end;

  function IsLiteral: Boolean;
  begin
    Result := CurChar in ['''', '"'];
  end;

  function StripLiterals(Buffer: PChar): string;
  var
    Len: Word;
    TempBuf: PChar;

    procedure StripChar(Value: Char);
    begin
      if TempBuf^ = Value then
        StrMove(TempBuf, TempBuf + 1, Len - 1);
      if TempBuf[StrLen(TempBuf) - 1] = Value then
        TempBuf[StrLen(TempBuf) - 1] := #0;
    end;

  begin
    Len := StrLen(Buffer) + 1;
    TempBuf := AllocMem(Len);
    Result := '';
    try
      StrCopy(TempBuf, Buffer);
      StripChar('''');
      StripChar('"');
      Result := StrPas(TempBuf);
    finally
      FreeMem(TempBuf, Len);
    end;
  end;

Var
 Macro : TMacro;
begin
  CurPos := Value;
  Literal := False;
  EmbeddedLiteral := False;
  repeat
    CurChar := CurPos^;
    if (CurChar = acMacrosChar) and not Literal and ((CurPos + 1)^ <> acMacrosChar) then
    begin
      StartPos := CurPos;
      while (CurChar <> #0) and (Literal or not NameDelimiter) do
      begin
        Inc(CurPos);
        CurChar := CurPos^;
        if IsLiteral then
        begin
          Literal := Literal xor True;
          if CurPos = StartPos + 1 then EmbeddedLiteral := True;
        end;
      end;
      CurPos^ := #0;
      if EmbeddedLiteral then
      begin
        Name := StripLiterals(StartPos + 1);
        EmbeddedLiteral := False;
      end
      else Name := StrPas(StartPos + 1);
      Macro := List.CreateMacro(Name );
      Macro.MacroOptions := Macro.MacroOptions + MacroOptions;
      CurPos^ := CurChar;
      StartPos^ := '?';
      Inc(StartPos);
      StrMove(StartPos, CurPos, StrLen(CurPos) + 1);
      CurPos := StartPos;
    end
    else if (CurChar = acMacrosChar) and not Literal and ((CurPos + 1)^ = acMacrosChar) then
      StrMove(CurPos, CurPos + 1, StrLen(CurPos) + 1)
    else if IsLiteral then Literal := Literal xor True;
    Inc(CurPos);
  until CurChar = #0;
end;

{ TMacros }
constructor TMacros.Create;
begin
  FItems := TList.Create;
end;

destructor TMacros.Destroy;
begin
  Clear;
  FItems.Free;
  inherited Destroy;
end;

procedure TMacros.DefineProperties(Filer: TFiler);
begin
  inherited DefineProperties(Filer);
  Filer.DefineBinaryProperty('Data', ReadBinaryData, WriteBinaryData, Count > 0);
end;

procedure TMacros.ReadBinaryData(Stream: TStream);
var
  I : Integer;
  NumItems, Temp : SmallInt;
  TempStr: string;
begin
  Clear;
  with Stream do
  begin
    ReadBuffer(NumItems, SizeOf(NumItems));
    for I := 0 to NumItems - 1 do
      with TMacro.Create(Self) do
      begin
        Temp := 0;
        ReadBuffer(Temp, 1);
        SetLength(TempStr, Temp);
        ReadBuffer(PChar(TempStr)^, Temp);
        Name := TempStr;
        Temp := 0;
        ReadBuffer(Temp, 1);
        SetLength(TempStr, Temp);
        ReadBuffer(PChar(TempStr)^, Temp);
        Text := TempStr;
        ReadBuffer(MacroOptions, Sizeof(MacroOptions));
      end;
  end;
end;

procedure TMacros.WriteBinaryData(Stream: TStream);
var
  I: Integer;
  Temp: SmallInt;
begin
  with Stream do
  begin
    Temp := Count;
    WriteBuffer(Temp, SizeOf(Temp));
    for I := 0 to Count - 1 do
      with Items[I] do
      begin
        Temp := Length(FName);
        WriteBuffer(Temp, 1);
        WriteBuffer(PChar(FName)^, Length(FName));
        Temp := Length(FText);
        WriteBuffer(Temp, 1);
        WriteBuffer(PChar(FText)^, Length(FText));
        WriteBuffer(MacroOptions, Sizeof(MacroOptions));
      end;
  end;
end;


procedure TMacros.Assign(Source: TPersistent);
var
  I: Integer;
begin
  if Source is TMacros then
  begin
    Clear;
    for I := 0 to TMacros(Source).Count - 1 do
      with TMacro.Create(Self) do
        Assign(TMacros(Source)[I]);
  end
  else inherited Assign(Source);
end;

procedure TMacros.AssignTo(Dest: TPersistent);
begin
  if Dest is TMacros then TMacros(Dest).Assign(Self)
  else inherited AssignTo(Dest);
end;

procedure TMacros.AssignValues(Value: TMacros);
var
  I, J: Integer;
begin
    for I := 0 to Count - 1 do
      for J := 0 to Value.Count - 1 do
        if Items[I].Name = Value[J].Name then
        begin
          Items[I].Text := Value[J].Text;
          Items[I].MacroOptions := Value[J].MacroOptions;
          Break;
        end;
end;


procedure TMacros.AddMacro(Value: TMacro);
begin
  FItems.Add(Value);
  Value.FMacroList := Self;
end;

procedure TMacros.RemoveMacro(Value: TMacro);
begin
  FItems.Remove(Value);
  Value.FMacroList := nil;
end;

function TMacros.CreateMacro(const MacroName: string): TMacro;
Var
  i : Integer;
begin
  for I := 0 to FItems.Count - 1 do
    if AnsiCompareText(TMacro(FItems[i]).Name, MacroName) = 0 then begin
      Result := FItems[i];
      Exit;
    end;
  Result := TMacro.Create(Self);
  Result.Name := MacroName;
end;

function TMacros.Count: Integer;
begin
  Result := FItems.Count;
end;

procedure TMacros.Clear;
begin
  while FItems.Count > 0 do TMacro(FItems.Last).Free;
end;

function TMacros.GetMacro(Index: Word): TMacro;
begin
  Result := MacroByName(TMacro(FItems[Index]).Name);
end;

function TMacros.MacroByName(const Value: string): TMacro;
var
  I: Integer;
begin
  for I := 0 to FItems.Count - 1 do
  begin
    Result := FItems[I];
    if AnsiCompareText(Result.Name, Value) = 0 then Exit;
  end;
  Result := Nil;
end;

function TMacros.GetMacroText(const MacroName: string): String;
begin
  Result := MacroByName(MacroName).text;
end;

procedure TMacros.SetMacroText(const MacroName: string;  const text: String);
begin
  MacroByName(MacroName).Text := Text;
end;


{ TMacros }

constructor TMacro.Create(AMacroList: TMacros);
begin
  if AMacroList <> nil then AMacroList.AddMacro(Self);
  MacroOptions := [];
end;

destructor TMacro.Destroy;
begin
   if FMacroList <> nil then FMacroList.RemoveMacro(Self);
end;

procedure TMacro.Assign(Macro: TMacro);
begin
  if Macro <> nil then begin
    Text := Macro.Text;