frxdsgnintf.pas

报表源码 FastReport 3 is new generation of the report generators components. It consists of report engin

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, 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:
        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);
  if Ch in [#33..#255] then
    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
  S:TIntegerSet;
  TypeInfo:PTypeInfo;
  I:Integer;
begin
  Integer(S):= GetOrdValue;
  TypeInfo:= GetTypeData(PropInfo.PropType^).CompType^;
  Result:= '[';
  for i:= 0 to 31 do
    if i in S then
    begin
      if Length(Result)<>1 then
        Result:= Result+',';
      Result:= Result+GetEnumName(TypeInfo, i);
    end;
  Result:= Result+']';
end;

{ TfrxSetElementProperty }

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

function TfrxSetElementProperty.GetName:String;
begin
  Result:= GetEnumName(GetTypeData(PropInfo.PropType^).CompType^, FElement);
end;

function TfrxSetElementProperty.GetValue:String;
var
  S:TIntegerSet;
begin
  Integer(S):= GetOrdValue;
  if FElement in S then
    Result:= 'True' else
    Result:= 'False';
end;

procedure TfrxSetElementProperty.GetValues;
begin
  inherited;
  Values.Add('False');
  Values.Add('True');
end;

procedure TfrxSetElementProperty.SetValue(const Value:String);
var
  S:TIntegerSet;
begin
  Integer(S):= GetOrdValue;
  if CompareText(Value, 'True') = 0 then
    Include(S, FElement)
  else if CompareText(Value, 'False') = 0 then
    Exclude(S, FElement)
  else
    raise Exception.Create(frxResources.Get('prInvProp'));

  SetOrdValue(Integer(S));
end;

{ TfrxClassProperty }

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

function TfrxClassProperty.GetValue:String;
begin
  Result:= {'';//}'('+PropInfo.PropType^.Name+')';
end;

{ TComponentProperty }

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

function TfrxComponentProperty.GetValue:String;
var
  c:TComponent;
begin
  c:= TComponent(GetOrdValue);
  if c<>nil then
    Result:= c.Name else
    Result:= '';
end;

procedure TfrxComponentProperty.GetValues;
var
  i:Integer;
  c, c1:TfrxComponent;
begin
  inherited;

  if frComponent<>nil then
  begin
    if frComponent is TfrxReportComponent then
      c:= frComponent.Page else
      c:= frComponent;
    for i:= 0 to c.AllObjects.Count-1 do
    begin
      c1:= c.AllObjects[i];
      if (c1<>frComponent) and
        c1.InheritsFrom(GetTypeData(PropInfo.PropType^)^.ClassType) then
        Values.Add(c1.Name);
    end;
  end;
end;

procedure TfrxComponentProperty.SetValue(const Value:String);
var
  c:TComponent;
begin
  c:= nil;
  if Value<>'' then
  begin
    c:= frComponent.Report.FindObject(Value);
    if c = nil then
      raise Exception.Create(frxResources.Get('prInvProp'));
  end;

  SetOrdValue(Integer(c));
end;

{ TfrxNameProperty }

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

{ TfrxColorProperty }

function TfrxColorProperty.GetAttributes:TfrxPropertyAttributes;
begin
  Result:= [paMultiSelect, paValueList, paOwnerDraw];
end;

function TfrxColorProperty.GetValue:String;
begin
  Result:= ColorToString(GetOrdValue);
end;

procedure TfrxColorProperty.SetValue(const Value:String);
var
  c:Integer;
begin
  if IdentToColor(Value, c) then
    SetOrdValue(c) else
    inherited SetValue(Value);
end;

procedure TfrxColorProperty.GetValues;
begin
  inherited;
  GetColorValues(GetStrProc);
end;

function TfrxColorProperty.Edit:Boolean;
begin
  with TColorDialog.Create(Application) do
  begin
    Color:= GetOrdValue;
    Result:= Execute;
    if Result then
      SetOrdValue(Color);
    Free;
  end;
end;

procedure TfrxColorProperty.OnDrawLBItem(Control:TWinControl; Index:Integer;
  ARect:TRect; State:TOwnerDrawState);
var
  c:Integer;
begin
  inherited;
  with TListBox(Control), TListBox(Control).Canvas do
  begin
    IdentToColor(Items[Index], c);
    Brush.Color:= c;
    Rectangle(ARect.Left+2, ARect.Top+2, ARect.Left+(ARect.Bottom-ARect.Top-2), ARect.Bottom-2);
  end;
end;

procedure TfrxColorProperty.OnDrawItem(Canvas:TCanvas; ARect:TRect);
begin
  inherited;
  with Canvas do
  begin
    Brush.Color:= GetOrdValue;
    Rectangle(ARect.Left, ARect.Top+1, ARect.Left+(ARect.Bottom-ARect.Top-5), ARect.Bottom-4);
  end;
end;

{ TfrxFontProperty }

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

function TfrxFontProperty.Edit:Boolean;
var
  FontDialog:TFontDialog;
begin
  FontDialog:= TFontDialog.Create(Application);
  try
    FontDialog.Font:= TFont(GetOrdValue);
    FontDialog.Options:= FontDialog.Options+[fdForceFontExist];
    Result:= FontDialog.Execute;
    if Result then
      SetOrdValue(Integer(FontDialog.Font));
  finally
    FontDialog.Free;
  end;
end;

{ TfrxFontNameProperty }

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

procedure TfrxFontNameProperty.GetValues;
begin
  Values.Assign(Screen.Fonts);