fr_dctrl.pas

1、开发环境 d6 up2,sqlserver2000, win2000 server 1024*768（笔记本电脑） c/s 2、数据库配置方法

{******************************************}
{                                          }
{     FastReport v2.4 - Dialog designer    }
{         Standard Dialog controls         }
{                                          }
{ Copyright (c) 1998-2001 by Tzyganenko A. }
{                                          }
{******************************************}

unit FR_DCtrl;

interface

{$I FR.inc}
{$IFDEF RX}
  {$DEFINE DateEdit}
{$ENDIF}
{$IFNDEF Delphi2}
  {$DEFINE DateEdit}
{$ENDIF}


uses
  Windows, Messages, SysUtils, Classes, Graphics, FR_Class, StdCtrls,
  Controls, Forms, Menus, Dialogs
{$IFDEF RX}
, Mask, DateUtil, ToolEdit
{$ELSE}
, Comctrls
{$ENDIF};

type
  TfrDialogControls = class(TComponent) // fake component
  end;

  TfrStdControl = class(TfrControl)
  private
    procedure FontEditor(Sender: TObject);
    procedure OnClickEditor(Sender: TObject);
    procedure OnClick(Sender: TObject);
  protected
    procedure SetPropValue(Index: String; Value: Variant); override;
    function GetPropValue(Index: String): Variant; override;
    function DoMethod(MethodName: String; Par1, Par2, Par3: Variant): Variant; override;
  public
    procedure AssignControl(AControl: TControl);
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    procedure DefineProperties; override;
    procedure ShowEditor; override;
  end;

  TfrLabelControl = class(TfrStdControl)
  private
    FLabel: TLabel;
  protected
    procedure SetPropValue(Index: String; Value: Variant); override;
    function GetPropValue(Index: String): Variant; override;
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure Draw(Canvas: TCanvas); override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    procedure DefineProperties; override;
    property LabelCtl: TLabel read FLabel;
  end;

  TfrEditControl = class(TfrStdControl)
  private
    FEdit: TEdit;
  protected
    procedure SetPropValue(Index: String; Value: Variant); override;
    function GetPropValue(Index: String): Variant; override;
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    procedure DefineProperties; override;
    property Edit: TEdit read FEdit;
  end;

  TfrMemoControl = class(TfrStdControl)
  private
    FMemo: TMemo;
    procedure LinesEditor(Sender: TObject);
  protected
    procedure SetPropValue(Index: String; Value: Variant); override;
    function GetPropValue(Index: String): Variant; override;
    function DoMethod(MethodName: String; Par1, Par2, Par3: Variant): Variant; override;
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    procedure DefineProperties; override;
    property MemoCtl: TMemo read FMemo;
  end;

  TfrButtonControl = class(TfrStdControl)
  private
    FButton: TButton;
  protected
    procedure SetPropValue(Index: String; Value: Variant); override;
    function GetPropValue(Index: String): Variant; override;
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    procedure DefineProperties; override;
    property Button: TButton read FButton;
  end;

  TfrCheckBoxControl = class(TfrStdControl)
  private
    FCheckBox: TCheckBox;
  protected
    procedure SetPropValue(Index: String; Value: Variant); override;
    function GetPropValue(Index: String): Variant; override;
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    procedure DefineProperties; override;
    property CheckBox: TCheckBox read FCheckBox;
  end;

  TfrRadioButtonControl = class(TfrStdControl)
  private
    FRadioButton: TRadioButton;
  protected
    procedure SetPropValue(Index: String; Value: Variant); override;
    function GetPropValue(Index: String): Variant; override;
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    procedure DefineProperties; override;
    property RadioButton: TRadioButton read FRadioButton;
  end;

  TfrListBoxControl = class(TfrStdControl)
  private
    FListBox: TListBox;
    procedure LinesEditor(Sender: TObject);
  protected
    procedure SetPropValue(Index: String; Value: Variant); override;
    function GetPropValue(Index: String): Variant; override;
    function DoMethod(MethodName: String; Par1, Par2, Par3: Variant): Variant; override;
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    procedure DefineProperties; override;
    property ListBox: TListBox read FListBox;
  end;

  TfrComboBoxControl = class(TfrStdControl)
  private
    FComboBox: TComboBox;
    procedure ComboBoxDrawItem(Control: TWinControl;
     Index: Integer; Rect: TRect; State: TOwnerDrawState);
    procedure LinesEditor(Sender: TObject);
    procedure OnKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
  protected
    procedure SetPropValue(Index: String; Value: Variant); override;
    function GetPropValue(Index: String): Variant; override;
    function DoMethod(MethodName: String; Par1, Par2, Par3: Variant): Variant; override;
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    procedure DefineProperties; override;
    property ComboBox: TComboBox read FComboBox;
  end;

{$IFDEF DateEdit}
  TfrDateEditControl = class(TfrStdControl)
  private
{$IFDEF RX}
    FDateEdit: TDateEdit;
{$ELSE}
    FDateEdit: TDateTimePicker;
{$ENDIF}
  protected
    procedure SetPropValue(Index: String; Value: Variant); override;
    function GetPropValue(Index: String): Variant; override;
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    procedure DefineProperties; override;
{$IFDEF RX}
    property DateEdit: TDateEdit read FDateEdit;
{$ELSE}
    property DateEdit: TDateTimePicker read FDateEdit;
{$ENDIF}
  end;
{$ENDIF}

const
  csLookup = csOwnerDrawFixed;

function frGetShortCuts: String;


implementation

uses FR_Utils, FR_Const, FR_LEdit
{$IFDEF Delphi6}
, Variants
{$ENDIF};

{$R FR_DCtrl.RES}
{$R FR_Lng4.RES}

type
  THackControl = class(TControl)
  end;


const
  ShortCuts: array[0..81] of TShortCut = (
    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,
    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 frGetShortCuts: String;
var
  i: Word;
begin
  Result := frLoadStr(SNotAssigned);
  for i := Low(ShortCuts) to High(ShortCuts) do
    Result := Result + ';' + ShortCutToText(ShortCuts[i]);
  SetLength(Result, Length(Result) - 1);
end;


{ TfrStdControl }

procedure TfrStdControl.DefineProperties;
begin
  inherited DefineProperties;
  AddProperty('Color', [frdtColor], nil);
  AddProperty('Enabled', [frdtBoolean], nil);
  AddProperty('Font', [frdtHasEditor], FontEditor);
  AddProperty('Font.Name', [], nil);
  AddProperty('Font.Size', [], nil);
  AddProperty('Font.Style', [], nil);
  AddProperty('Font.Color', [], nil);
  AddProperty('OnClick', [frdtHasEditor, frdtOneObject], OnClickEditor);
end;

procedure TfrStdControl.SetPropValue(Index: String; Value: Variant);
begin
  inherited SetPropValue(Index, Value);
  Index := AnsiUpperCase(Index);
  SetFontProp(THackControl(Control).Font, Index, Value);
  if Index = 'COLOR' then
    THackControl(Control).Color := Value
  else if Index = 'ENABLED' then
    Control.Enabled := Value
  else if Index = 'LEFT' then
  begin
    if DocMode = dmPrinting then
      Control.Left := Value;
  end
  else if Index = 'TOP' then
  begin
    if DocMode = dmPrinting then
      Control.Top := Value;
  end
  else if Index = 'WIDTH' then
  begin
    if DocMode = dmPrinting then
      Control.Width := Value;
  end
  else if Index = 'HEIGHT' then
  begin
    if DocMode = dmPrinting then
      Control.Height := Value;
  end
  else if Index = 'VISIBLE' then
  begin
    if DocMode = dmPrinting then
      Control.Visible := Value;
  end
end;

function TfrStdControl.GetPropValue(Index: String): Variant;
begin
  Index := AnsiUpperCase(Index);
  Result := inherited GetPropValue(Index);
  if Result <> Null then Exit;
  Result := GetFontProp(THackControl(Control).Font, Index);
  if Index = 'COLOR' then
    Result := THackControl(Control).Color
  else if Index = 'ENABLED' then
    Result := Control.Enabled
end;

function TfrStdControl.DoMethod(MethodName: String; Par1, Par2, Par3: Variant): Variant;
begin
  Result := inherited DoMethod(MethodName, Par1, Par2, Par3);
  if MethodName = 'SETFOCUS' then
    if Control is TWinControl then
      TWinControl(Control).SetFocus;
end;

procedure TfrStdControl.LoadFromStream(Stream: TStream);
begin
  inherited LoadFromStream(Stream);
  THackControl(Control).Color := frReadInteger(Stream);
  Control.Enabled := frReadBoolean(Stream);
  frReadFont(Stream, THackControl(Control).Font);
end;

procedure TfrStdControl.SaveToStream(Stream: TStream);
begin
  inherited SaveToStream(Stream);
  frWriteInteger(Stream, THackControl(Control).Color);
  frWriteBoolean(Stream, Control.Enabled);
  frWriteFont(Stream, THackControl(Control).Font);
end;

procedure TfrStdControl.ShowEditor;
begin
  frMemoEditor(nil);
end;

procedure TfrStdControl.FontEditor(Sender: TObject);
var
  i: Integer;
  t: TfrView;
  fd: TFontDialog;
begin
  fd := TFontDialog.Create(nil);
  with fd do
  begin
    Font.Assign(THackControl(Control).Font);
    if Execute then
    begin
      frDesigner.BeforeChange;
      for i := 0 to frDesigner.Page.Objects.Count - 1 do
      begin
        t := frDesigner.Page.Objects[i];
        if t.Selected and (t is TfrStdControl) then
          if (t.Restrictions and frrfDontModify) = 0 then
            THackControl(TfrStdControl(t).Control).Font.Assign(Font);
      end;
      frDesigner.AfterChange;
    end;
  end;
  fd.Free;
end;