frxdsgnintf.pas

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

  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 := {'';//}'(' + String(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];
    FontDialog.Device := fdBoth;
    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);
end;


{ TfrxFontCharsetProperty }

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

function TfrxFontCharsetProperty.GetValue: String;
begin
  if not CharsetToIdent(GetOrdValue, Result) then
    FmtStr(Result, '%d', [GetOrdValue]);
end;

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

procedure TfrxFontCharsetProperty.GetValues;
begin
  inherited;
  GetCharsetValues(GetStrProc);
end;


{ TfrxModalResultProperty }

const
  ModalResults: array[mrNone..mrYesToAll] of string = (
    'mrNone',
    'mrOk',
    'mrCancel',
    'mrAbort',
    'mrRetry',
    'mrIgnore',
    'mrYes',
    'mrNo',
    'mrAll',
    'mrNoToAll',
    'mrYesToAll');

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

function TfrxModalResultProperty.GetValue: String;
begin
  if GetOrdValue in [mrNone..mrYesToAll] then
    Result := ModalResults[GetOrdValue] else
    Result := inherited GetValue;
end;

procedure TfrxModalResultProperty.SetValue(const Value: String);
var
  i: Integer;
  s: String;
begin
  s := Value;
  if s = '' then
    s := '0';
  for i := Low(ModalResults) to High(ModalResults) do
    if CompareText(ModalResults[i], s) = 0 then
    begin
      SetOrdValue(i);
      Exit;
    end;
  inherited SetValue(s);
end;

procedure TfrxModalResultProperty.GetValues;
var
  i: Integer;
begin
  inherited;
  for i := mrNone to mrYesToAll do
    Values.Add(ModalResults[i]);
end;


{ TfrxShortCutProperty }

const
  ShortCuts: array[0..108] of TShortCut = (
    scNone,
    Byte('A') or scCtrl,
    Byte('B') or scCtrl,
    Byte('C') or scCtrl,
    Byte('D') or scCtrl,
    Byte('E') or scCtrl,
    Byte('F') or scCtrl,
    Byte('G') or scCtrl,
    Byte('H') or scCtrl,
    Byte('I') or scCtrl,
    Byte('J') or scCtrl,
    Byte('K') or scCtrl,
    Byte('L') or scCtrl,
    Byte('M') or scCtrl,
    Byte('N') or scCtrl,
    Byte('O') or scCtrl,
    Byte('P') or scCtrl,
    Byte('Q') or scCtrl,
    Byte('R') or scCtrl,
    Byte('S') or scCtrl,
    Byte('T') or scCtrl,
    Byte('U') or scCtrl,
    Byte('V') or scCtrl,
    Byte('W') or scCtrl,
    Byte('X') or scCtrl,
    Byte('Y') or scCtrl,
    Byte('Z') or scCtrl,
    Byte('A') or scCtrl or scAlt,
    Byte('B') or scCtrl or scAlt,
    Byte('C') or scCtrl or scAlt,
    Byte('D') or scCtrl or scAlt,
    Byte('E') or scCtrl or scAlt,
    Byte('F') or scCtrl or scAlt,
    Byte('G') or scCtrl or scAlt,
    Byte('H') or scCtrl or scAlt,
    Byte('I') or scCtrl or scAlt,
    Byte('J') or scCtrl or scAlt,
    Byte('K') or scCtrl or scAlt,
    Byte('L') or scCtrl or scAlt,
    Byte('M') or scCtrl or scAlt,
    Byte('N') or scCtrl or scAlt,
    Byte('O') or scCtrl or scAlt,
    Byte('P') or scCtrl or scAlt,
    Byte('Q') or scCtrl or scAlt,
    Byte('R') or scCtrl or scAlt,
    Byte('S') or scCtrl or scAlt,
    Byte('T') or scCtrl or scAlt,
    Byte('U') or scCtrl or scAlt,
    Byte('V') or scCtrl or scAlt,
    Byte('W') or scCtrl or scAlt,
    Byte('X') or scCtrl or scAlt,
    Byte('Y') or scCtrl or scAlt,
    Byte('Z') or scCtrl or scAlt,
    VK_F1,
    VK_F2,
    VK_F3,
    VK_F4,
    VK_F5,
    VK_F6,
    VK_F7,
    VK_F8,
    VK_F9,
    VK_F10,
    VK_F11,
    VK_F12,
    VK_F1 or scCtrl,
    VK_F2 or scCtrl,
    VK_F3 or scCtrl,
    VK_F4 or scCtrl,
    VK_F5 or scCtrl,
    VK_F6 or scCtrl,
    VK_F7 or scCtrl,
    VK_F8 or scCtrl,
    VK_F9 or scCtrl,
    VK_F10 or scCtrl,
    VK_F11 or scCtrl,
    VK_F12 or scCtrl,
    VK_F1 or scShift,
    VK_F2 or scShift,
    VK_F3 or scShift,
    VK_F4 or scShift,
    VK_F5 or scShift,
    VK_F6 or scShift,
    VK_F7 or scShift,
    VK_F8 or scShift,
    VK_F9 or scShift,
    VK_F10 or scShift,
    VK_F11 or scShift,
    VK_F12 or scShift,
    VK_F1 or scShift or scCtrl,
    VK_F2 or scShift or scCtrl,
    VK_F3 or scShift or scCtrl,
    VK_F4 or scShift or scCtrl,
    VK_F5 or scShift or scCtrl,
    VK_F6 or scShift or scCtrl,
    VK_F7 or scShift or scCtrl,
    VK_F8 or scShift or scCtrl,
    VK_F9 or scShift or scCtrl,
    VK_F10 or scShift or scCtrl,
    VK_F11 or scShift or scCtrl,
    VK_F12 or scShift or scCtrl,
    VK_INSERT,
    VK_INSERT or scShift,
    VK_INSERT or scCtrl,
    VK_DELETE,
    VK_DELETE or scShift,
    VK_DELETE or scCtrl,
    VK_BACK or scAlt,
    VK_BACK or scShift or scAlt);

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

function TfrxShortCutProperty.GetValue: String;
var
  CurValue: TShortCut;
begin
  CurValue := GetOrdValue;
  if CurValue = scNone then
    Result := srNone else
    Result := ShortCutToText(CurValue);
end;

procedure TfrxShortCutProperty.SetValue(const Value: String);
var
  NewValue: TShortCut;
begin
  NewValue := 0;
  if (Value <> '') and (AnsiCompareText(Value, srNone) <> 0) then
    NewValue := TextToShortCut(Value);
  SetOrdValue(NewValue);
end;

procedure TfrxShortCutProperty.GetValues;
var
  i: Integer;
begin
  inherited;
  Values.Add(srNone);
  for i := 1 to High(ShortCuts) do
    Values.Add(ShortCutToText(ShortCuts[i]));
end;


{ TfrxCursorProperty }

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

function TfrxCursorProperty.GetValue: string;
begin
  Result := CursorToString(TCursor(GetOrdValue));
end;

procedure TfrxCursorProperty.GetValues;
begin
  inherited;
  GetCursorValues(GetStrProc);