frxdsgnintf.pas

这个是功能强大的报表软件

destructor TfrxPropertyEditor.Destroy;
begin
  FCompList.Free;
  FPropList.Free;
  FValues.Free;
  inherited;
end;

function TfrxPropertyEditor.GetAttributes: TfrxPropertyAttributes;
begin
  Result := [paMultiSelect];
end;

function TfrxPropertyEditor.GetName: String;
begin
  Result := String(PropInfo.Name);
end;

function TfrxPropertyEditor.GetComponent: TPersistent;
begin
  Result := FCompList[0];
end;

function TfrxPropertyEditor.GetfrComponent: TfrxComponent;
begin
  if TObject(FCompList[0]) is TfrxComponent then
    Result := FCompList[0] else
    Result := nil;
end;

function TfrxPropertyEditor.GetPropInfo: PPropInfo;
begin
  Result := FPropList[0];
end;

function TfrxPropertyEditor.GetValue: String;
begin
  Result := '(Unknown)';
end;

procedure TfrxPropertyEditor.SetValue(const Value: String);
begin
  { empty method }
end;

function TfrxPropertyEditor.GetFloatValue: Extended;
begin
  Result := GetFloatProp(Component, PropInfo);
end;

function TfrxPropertyEditor.GetOrdValue: Integer;
begin
  Result := GetOrdProp(Component, PropInfo);
end;

function TfrxPropertyEditor.GetStrValue: String;
begin
  Result := GetStrProp(Component, PropInfo);
end;

function TfrxPropertyEditor.GetVarValue: Variant;
begin
  Result := GetVariantProp(Component, PropInfo);
end;

procedure TfrxPropertyEditor.SetFloatValue(Value: Extended);
var
  i: Integer;
begin
  for i := 0 to FCompList.Count - 1 do
    if (PPropInfo(FPropList[i]).SetProc <> nil) then
      SetFloatProp(TObject(FCompList[i]), PPropInfo(FPropList[i]), Value);
end;

procedure TfrxPropertyEditor.SetOrdValue(Value: Integer);
var
  i: Integer;
begin
  for i := 0 to FCompList.Count - 1 do
    if (PPropInfo(FPropList[i]).SetProc <> nil) then
      SetOrdProp(TObject(FCompList[i]), PPropInfo(FPropList[i]), Value);
end;

procedure TfrxPropertyEditor.SetStrValue(const Value: String);
var
  i: Integer;
begin
  for i := 0 to FCompList.Count - 1 do
    if (PPropInfo(FPropList[i]).SetProc <> nil) then
      SetStrProp(TObject(FCompList[i]), PPropInfo(FPropList[i]), Value);
end;

procedure TfrxPropertyEditor.SetVarValue(Value: Variant);
var
  i: Integer;
begin
  for i := 0 to FCompList.Count - 1 do
    if (PPropInfo(FPropList[i]).SetProc <> nil) then
      SetVariantProp(TObject(FCompList[i]), PPropInfo(FPropList[i]), Value);
end;

procedure TfrxPropertyEditor.GetValues;
begin
  FValues.Clear;
  TStringList(FValues).Sorted := paSortList in GetAttributes;
end;

procedure TfrxPropertyEditor.GetStrProc(const s: String);
begin
  FValues.Add(s);
end;

function TfrxPropertyEditor.Edit: Boolean;
var
  i: Integer;
begin
  Result := False;
  GetValues;
  if FValues.Count > 0 then
  begin
    i := FValues.IndexOf(Value) + 1;
    if i = FValues.Count then
      i := 0;
    Value := FValues[i];
    Result := True;
  end;
end;

procedure TfrxPropertyEditor.OnDrawLBItem(Control: TWinControl;
  Index: Integer; ARect: TRect; State: TOwnerDrawState);
begin
  with TListBox(Control).Canvas do
  begin
    FillRect(ARect);
    TextOut(ARect.Left + FItemHeight + 4, ARect.Top + 1, TListBox(Control).Items[Index]);
    Pen.Color := clGray;
  end;
end;

procedure TfrxPropertyEditor.OnDrawItem(Canvas: TCanvas; ARect: TRect);
begin
  Canvas.TextOut(ARect.Left + FItemHeight - 2, ARect.Top, Value);
  Canvas.Pen.Color := clGray;
end;

function TfrxPropertyEditor.GetExtraLBSize: Integer;
begin
  Result := FItemHeight + 2;
end;


{ TfrxComponentEditor }

function TfrxComponentEditor.Edit: Boolean;
begin
  Result := False;
end;

procedure TfrxComponentEditor.GetMenuItems;
begin
// empty method
end;

function TfrxComponentEditor.Execute(Tag: Integer; Checked: Boolean): Boolean;
begin
  Result := False;
end;

function TfrxComponentEditor.HasEditor: Boolean;
begin
  Result := False;
end;

function TfrxComponentEditor.AddItem(const Caption: String; Tag: Integer;
  Checked: Boolean): TMenuItem;
begin
  Result := TMenuItem.Create(FMenu);
  Result.Caption := Caption;
  Result.Tag := Tag;
  Result.Checked := Checked;
  FMenu.Items.Add(Result);
end;


constructor TfrxComponentEditor.Create(Component: TfrxComponent;
  Designer: TfrxCustomDesigner; Menu: TMenu);
begin
  FComponent := Component;
  FDesigner := Designer;
  FMenu := Menu;
end;


{ TfrxPropertyList }

constructor TfrxPropertyList.Create(Designer: TfrxCustomDesigner);
begin
  inherited Create(TfrxPropertyItem);
  FDesigner := Designer;
end;

function TfrxPropertyList.GetPropertyItem(Index: Integer): TfrxPropertyItem;
begin
  Result := TfrxPropertyItem(inherited Items[Index]);
end;

function TfrxPropertyList.Add: TfrxPropertyItem;
begin
  Result := TfrxPropertyItem(inherited Add);
end;

procedure TfrxPropertyList.SetComponent(Value: TPersistent);
begin
  FComponent := Value;
  Clear;
  FillProperties(FComponent);
end;

procedure TfrxPropertyList.FillProperties(AClass: TPersistent);
var
  Item, Item1: TfrxPropertyItem;
  TypeInfo: PTypeInfo;
  PropertyCount: Integer;
  PropertyList: PPropList;
  i, j: Integer;
  FClass: TClass;

  function CreateEditor(EditorClass: TfrxPropertyEditorClass; AClass: TPersistent;
    PropInfo: PPropInfo): TfrxPropertyEditor;
  var
    Item: TfrxPropertyEditorItem;
    e: Integer;
  begin
    Result := nil;
    e := frxPropertyEditors.GetPropertyEditor(PropInfo.PropType^, AClass, String(PropInfo.Name));
    if e <> -1 then
    begin
      Item := frxPropertyEditors[e];
      if Item.EditorClass <> nil then
        Result := TfrxPropertyEditor(Item.EditorClass.NewInstance) else
        Exit;
    end
    else
      Result := TfrxPropertyEditor(EditorClass.NewInstance);

    Result.Create(FDesigner);
    Result.FCompList.Add(AClass);
    Result.FPropList.Add(PropInfo);
  end;

begin
  if AClass = nil then exit;

  TypeInfo := AClass.ClassInfo;
  PropertyCount := GetPropList(TypeInfo, tkProperties, nil);
  GetMem(PropertyList, PropertyCount * SizeOf(PPropInfo));
  GetPropList(TypeInfo, tkProperties, PropertyList);

  for i := 0 to PropertyCount - 1 do
  begin
    Item := Add;
    case PropertyList[i].PropType^.Kind of
      tkInteger:
        Item.FEditor := CreateEditor(TfrxIntegerProperty, AClass, PropertyList[i]);

      tkChar, tkWChar:
        Item.FEditor := CreateEditor(TfrxCharProperty, AClass, PropertyList[i]);

      tkFloat:
        Item.FEditor := CreateEditor(TfrxFloatProperty, AClass, PropertyList[i]);

      tkString, tkLString, tkWString{$IFDEF Delphi12}, tkUString{$ENDIF}:
        Item.FEditor := CreateEditor(TfrxStringProperty, AClass, PropertyList[i]);

      tkEnumeration:
        Item.FEditor := CreateEditor(TfrxEnumProperty, AClass, PropertyList[i]);

      tkSet:
        begin
          Item.FSubProperty := TfrxPropertyList.Create(FDesigner);
          Item.FSubProperty.FParent := Self;
          Item.FEditor := CreateEditor(TfrxSetProperty, AClass, PropertyList[i]);
          with GetTypeData(GetTypeData(PropertyList[i].PropType^).CompType^)^ do
            for j := MinValue to MaxValue do
            begin
              Item1 := Item.FSubProperty.Add;
              Item1.FEditor := CreateEditor(TfrxSetElementProperty, AClass, PropertyList[i]);
              if Item1.FEditor <> nil then
                TfrxSetElementProperty(Item1.FEditor).FElement := j;
            end;
        end;

      tkClass:
        begin
          FClass := GetTypeData(PropertyList[i].PropType^)^.ClassType;
          if FClass.InheritsFrom(TComponent) then
            Item.FEditor := CreateEditor(TfrxComponentProperty, AClass, PropertyList[i])
          else if FClass.InheritsFrom(TPersistent) then
          begin
            Item.FEditor := CreateEditor(TfrxClassProperty, AClass, PropertyList[i]);
            Item.FSubProperty := TfrxPropertyList.Create(FDesigner);
            Item.FSubProperty.FParent := Self;
            Item.FSubProperty.Component := TPersistent(GetOrdProp(AClass, PropertyList[i]));
            if Item.SubProperty.Count = 0 then
            begin
              Item.FSubProperty.Free;
              Item.FSubProperty := nil;
            end;
          end;
        end;
    end;
    if Item.FEditor = nil then
      Item.Free;
  end;

  FreeMem(PropertyList, PropertyCount * SizeOf(PPropInfo));
end;

procedure TfrxPropertyList.FillCommonProperties(PropertyList: TfrxPropertyList);
var
  i, j: Integer;
  p, p1: TfrxPropertyItem;
  Found: Boolean;
begin
  i := 0;
  while i < Count do
  begin
    p := Items[i];
    Found := False;
    if paMultiSelect in p.Editor.GetAttributes then
      for j := 0 to PropertyList.Count - 1 do
      begin
        p1 := PropertyList.Items[j];
        if (p1.Editor.GetPropInfo.PropType^.Kind = p.Editor.GetPropInfo.PropType^.Kind) and
           (p1.Editor.GetPropInfo.Name = p.Editor.GetPropInfo.Name) then
        begin
          Found := True;
          break;
        end;
      end;

    if not Found then
      p.Free else
      Inc(i);
  end;
end;

procedure TfrxPropertyList.AddProperties(PropertyList: TfrxPropertyList);

  procedure EnumProperties(p1, p2: TfrxPropertyList);
  var
    i: Integer;
  begin
    for i := 0 to p1.Count - 1 do
    begin
      p1[i].Editor.FCompList.Add(p2[i].Editor.FCompList[0]);
      p1[i].Editor.FPropList.Add(p2[i].Editor.FPropList[0]);
      if p1[i].SubProperty <> nil then
        EnumProperties(p1[i].SubProperty, p2[i].SubProperty);
    end;
  end;

begin
  EnumProperties(Self, PropertyList);
end;


{ TfrxPropertyItem }

destructor TfrxPropertyItem.Destroy;
begin
  if Editor <> nil then
    Editor.Free;
  if SubProperty <> nil then
    SubProperty.Free;
  inherited;
end;


{ TfrxIntegerProperty }

function TfrxIntegerProperty.GetValue: String;
begin
  Result := IntToStr(GetOrdValue);
end;

procedure TfrxIntegerProperty.SetValue(const Value: String);
begin
  SetOrdValue(StrToInt(Value));
end;


{ TfrxFloatProperty }

function TfrxFloatProperty.GetValue: String;
begin
  Result := FloatToStr(GetFloatValue);
end;

procedure TfrxFloatProperty.SetValue(const Value: String);
begin
  SetFloatValue(frStrToFloat(Value));
end;


{ TfrxCharProperty }

function TfrxCharProperty.GetValue: String;
var
  Ch: Char;
begin
  Ch := Chr(GetOrdValue);
{$IFDEF Delphi12}
  if CharInSet(Ch, [#33..#255]) then
{$ELSE}
  if Ch in [#33..#255] then
{$ENDIF}
    Result := Ch else
    FmtStr(Result, '#%d', [Ord(Ch)]);
end;

procedure TfrxCharProperty.SetValue(const Value: String);
var
  i: Integer;
begin
  if Length(Value) = 0 then i := 0 else
    if Length(Value) = 1 then i := Ord(Value[1]) else
      if Value[1] = '#' then i := StrToInt(Copy(Value, 2, 255)) else
        raise Exception.Create(frxResources.Get('prInvProp'));
  SetOrdValue(i);
end;


{ TfrxStringProperty }

function TfrxStringProperty.GetValue: String;
begin
  Result := GetStrValue;
end;

procedure TfrxStringProperty.SetValue(const Value: String);
begin
  SetStrValue(Value);
end;


{ TfrxEnumProperty }

function TfrxEnumProperty.GetAttributes: TfrxPropertyAttributes;
begin
  Result := [paMultiSelect, paValueList, paSortList];
end;

function TfrxEnumProperty.GetValue: String;
var
  i: Integer;
begin
  i := GetOrdValue;
  Result := GetEnumName(PropInfo.PropType^, i);
end;

procedure TfrxEnumProperty.GetValues;
var
  i: Integer;
begin
  inherited;
  with GetTypeData(PropInfo.PropType^)^ do
    for i := MinValue to MaxValue do
      Values.Add(GetEnumName(PropInfo.PropType^, i));
end;

procedure TfrxEnumProperty.SetValue(const Value: String);
var
  i: Integer;
begin
  i := GetEnumValue(PropInfo.PropType^, Value);
  if i < 0 then
    raise Exception.Create(frxResources.Get('prInvProp'));
  SetOrdValue(i);
end;


{ TfrxSetProperty }

function TfrxSetProperty.GetAttributes: TfrxPropertyAttributes;
begin
  Result := [paMultiSelect, paSubProperties, paReadOnly];
end;

function TfrxSetProperty.GetValue: String;
var