Delphi控件源码

开发平台：
Delphi

Rxcalc.pas：源码内容
							{*******************************************************}
{                                                       }
{         Delphi VCL Extensions (RX)                    }
{                                                       }
{         Copyright (c) 1995, 1996 AO ROSNO             }
{         Copyright (c) 1997, 1998 Master-Bank          }
{                                                       }
{*******************************************************}
unit RxCalc;
interface
{$I RX.INC}
uses Windows, SysUtils, Variants,
  Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Menus,
  ExtCtrls, Buttons, RxCtrls, Clipbrd;
const
  DefCalcPrecision = 15;
type
  TRxCalcState = (csFirst, csValid, csError);
  TRxCalculatorForm = class;
{ TRxCalculator }
  TRxCalculator = class(TComponent)
  private
    FValue: Double;
    FMemory: Double;
    FTitle: PString;
    FCtl3D: Boolean;
    FPrecision: Byte;
    FBeepOnError: Boolean;
    FHelpContext: THelpContext;
    FCalc: TRxCalculatorForm;
    FOnChange: TNotifyEvent;
    FOnCalcKey: TKeyPressEvent;
    FOnDisplayChange: TNotifyEvent;
    function GetDisplay: Double;
    function GetTitle: string;
    procedure SetTitle(const Value: string);
    function TitleStored: Boolean;
  protected
    procedure Change; dynamic;
    procedure CalcKey(var Key: Char); dynamic;
    procedure DisplayChange; dynamic;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function Execute: Boolean;
    property CalcDisplay: Double read GetDisplay;
    property Memory: Double read FMemory;
  published
    property BeepOnError: Boolean read FBeepOnError write FBeepOnError default True;
    property Ctl3D: Boolean read FCtl3D write FCtl3D default True;
    property HelpContext: THelpContext read FHelpContext write FHelpContext default 0;
    property Precision: Byte read FPrecision write FPrecision default DefCalcPrecision;
    property Title: string read GetTitle write SetTitle stored TitleStored;
    property Value: Double read FValue write FValue;
    property OnCalcKey: TKeyPressEvent read FOnCalcKey write FOnCalcKey;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnDisplayChange: TNotifyEvent read FOnDisplayChange write FOnDisplayChange;
  end;
{ TRxCalculatorForm }
  TRxCalculatorForm = class(TForm)
  private
    FMainPanel: TPanel;
    FCalcPanel: TPanel;
    FDisplayPanel: TPanel;
    FDisplayLabel: TLabel;
    FPasteItem: TMenuItem;
    procedure FormKeyPress(Sender: TObject; var Key: Char);
    procedure PopupMenuPopup(Sender: TObject);
    procedure CopyItemClick(Sender: TObject);
    procedure PasteItemClick(Sender: TObject);
    procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
  protected
    procedure OkClick(Sender: TObject);
    procedure CancelClick(Sender: TObject);
    procedure CalcKey(Sender: TObject; var Key: Char);
    procedure DisplayChange(Sender: TObject);
  public
    constructor Create(AOwner: TComponent); override;
  end;
function CreateCalculatorForm(AOwner: TComponent; AHelpContext: THelpContext): TRxCalculatorForm;
function CreatePopupCalculator(AOwner: TComponent
  {$IFDEF RX_D4}; ABiDiMode: TBiDiMode = bdLeftToRight {$ENDIF}): TWinControl;
procedure SetupPopupCalculator(PopupCalc: TWinControl; APrecision: Byte;
  ABeepOnError: Boolean);
implementation
uses {$IFNDEF WIN32} Str16, {$ENDIF} VclUtils, MaxMin, rxStrUtils, ToolEdit;
{$IFDEF WIN32}
 {$R *.R32}
{$ELSE}
 {$R *.R16}
{$ENDIF}
const
  SCalculator = 'Calculator';
  SError = 'Error';
type
  TCalcBtnKind =
   (cbNone, cbNum0, cbNum1, cbNum2, cbNum3, cbNum4, cbNum5, cbNum6,
    cbNum7, cbNum8, cbNum9, cbSgn, cbDcm, cbDiv, cbMul, cbSub,
    cbAdd, cbSqr, cbPcnt, cbRev, cbEql, cbBck, cbClr, cbMP,
    cbMS, cbMR, cbMC, cbOk, cbCancel);
  TCalcPanelLayout = (clDialog, clPopup);
procedure SetDefaultFont(AFont: TFont; Layout: TCalcPanelLayout);
{$IFDEF WIN32}
var
  NonClientMetrics: TNonClientMetrics;
{$ENDIF}
begin
{$IFDEF WIN32}
  NonClientMetrics.cbSize := SizeOf(NonClientMetrics);
  if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @NonClientMetrics, 0) then
    AFont.Handle := CreateFontIndirect(NonClientMetrics.lfMessageFont)
  else
{$ENDIF}
  with AFont do begin
    Color := clWindowText;
    Name := 'MS Sans Serif';
    Size := 8;
  end;
  AFont.Style := [fsBold];
  if Layout = clDialog then begin
  end
  else begin
  end;
end;
function CreateCalculatorForm(AOwner: TComponent; AHelpContext: THelpContext): TRxCalculatorForm;
begin
  Result := TRxCalculatorForm.Create(AOwner);
  with Result do
  try
    HelpContext := AHelpContext;
{$IFDEF WIN32}
    if HelpContext <> 0 then BorderIcons := BorderIcons + [biHelp];
{$ENDIF}
    if Screen.PixelsPerInch <> 96 then begin { scale to screen res }
      ScaleBy(Screen.PixelsPerInch, 96);
      SetDefaultFont(Font, clDialog);
      Left := (Screen.Width div 2) - (Width div 2);
      Top := (Screen.Height div 2) - (Height div 2);
    end;
  except
    Free;
    raise;
  end;
end;
{ TCalcButton }
type
  TCalcButton = class(TRxSpeedButton)
  private
    FKind: TCalcBtnKind;
    FFontChanging: Boolean;
  protected
    procedure CMParentFontChanged(var Message: TMessage); message CM_PARENTFONTCHANGED;
  public
    constructor CreateKind(AOwner: TComponent; AKind: TCalcBtnKind);
    property Kind: TCalcBtnKind read FKind;
  end;
constructor TCalcButton.CreateKind(AOwner: TComponent; AKind: TCalcBtnKind);
begin
  inherited Create(AOwner);
{$IFDEF WIN32}
  ControlStyle := ControlStyle + [csReplicatable];
{$ENDIF}
  FKind := AKind;
  if FKind in [cbNum0..cbClr] then Tag := Ord(Kind) - 1
  else Tag := -1;
end;
procedure TCalcButton.CMParentFontChanged(var Message: TMessage);
  function BtnColor(Kind: TCalcBtnKind): TColor;
  begin
    if Kind in [cbSqr, cbPcnt, cbRev, cbMP..cbMC] then Result := clNavy
    else if Kind in [cbDiv, cbMul, cbSub, cbAdd, cbEql] then Result := clPurple
    else if Kind in [cbBck, cbClr] then Result := clMaroon
    else Result := clBtnText;
  end;
begin
  if not FFontChanging then inherited;
  if ParentFont and not FFontChanging then begin
    FFontChanging := True;
    try
      Font.Color := BtnColor(FKind);
      ParentFont := True;
    finally
      FFontChanging := False;
    end;
  end;
end;
const
  BtnPos: array[TCalcPanelLayout, TCalcBtnKind] of TPoint =
  (((X: -1; Y: -1), (X: 47; Y: 104), (X: 47; Y: 80), (X: 85; Y: 80),
    (X: 123; Y: 80), (X: 47; Y: 56), (X: 85; Y: 56), (X: 123; Y: 56),
    (X: 47; Y: 32), (X: 85; Y: 32), (X: 123; Y: 32), (X: 85; Y: 104),
    (X: 123; Y: 104), (X: 161; Y: 32), (X: 161; Y: 56), (X: 161; Y: 80),
    (X: 161; Y: 104), (X: 199; Y: 32), (X: 199; Y: 56), (X: 199; Y: 80),
    (X: 199; Y: 104), (X: 145; Y: 6), (X: 191; Y: 6), (X: 5; Y: 104),
    (X: 5; Y: 80), (X: 5; Y: 56), (X: 5; Y: 32),
    (X: 47; Y: 6), (X: 85; Y: 6)),
   ((X: -1; Y: -1), (X: 6; Y: 75), (X: 6; Y: 52), (X: 29; Y: 52),
    (X: 52; Y: 52), (X: 6; Y: 29), (X: 29; Y: 29), (X: 52; Y: 29),
    (X: 6; Y: 6), (X: 29; Y: 6), (X: 52; Y: 6), (X: 52; Y: 75),
    (X: 29; Y: 75), (X: 75; Y: 6), (X: 75; Y: 29), (X: 75; Y: 52),
    (X: 75; Y: 75), (X: -1; Y: -1), (X: -1; Y: -1), (X: -1; Y: -1),
    (X: 52; Y: 98), (X: 29; Y: 98), (X: 6; Y: 98), (X: -1; Y: -1),
    (X: -1; Y: -1), (X: -1; Y: -1), (X: -1; Y: -1),
    (X: -1; Y: -1), (X: -1; Y: -1)));
  ResultKeys = [#13, '=', '%'];
function CreateCalcBtn(AParent: TWinControl; AKind: TCalcBtnKind;
  AOnClick: TNotifyEvent; ALayout: TCalcPanelLayout): TCalcButton;
const
  BtnCaptions: array[cbSgn..cbMC] of PChar =
   ('

						