home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 September / Chip_2001-09_cd1.bin / zkuste / delphi / kolekce / d6 / RX275D6.ZIP / Units / RXCALC.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  2001-06-24  |  30.2 KB  |  1,072 lines
  1. {*******************************************************}
  2. {                                                       }
  3. {         Delphi VCL Extensions (RX)                    }
  4. {                                                       }
  5. {         Copyright (c) 1995, 1996 AO ROSNO             }
  6. {         Copyright (c) 1997, 1998 Master-Bank          }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit RxCalc;
  11.  
  12. interface
  13.  
  14. {$I RX.INC}
  15.  
  16. uses Windows, SysUtils, Variants,
  17.   Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Menus,
  18.   ExtCtrls, Buttons, RxCtrls, Clipbrd;
  19.  
  20. const
  21.   DefCalcPrecision = 15;
  22.  
  23. type
  24.   TRxCalcState = (csFirst, csValid, csError);
  25.   TRxCalculatorForm = class;
  26.  
  27. { TRxCalculator }
  28.  
  29.   TRxCalculator = class(TComponent)
  30.   private
  31.     FValue: Double;
  32.     FMemory: Double;
  33.     FTitle: PString;
  34.     FCtl3D: Boolean;
  35.     FPrecision: Byte;
  36.     FBeepOnError: Boolean;
  37.     FHelpContext: THelpContext;
  38.     FCalc: TRxCalculatorForm;
  39.     FOnChange: TNotifyEvent;
  40.     FOnCalcKey: TKeyPressEvent;
  41.     FOnDisplayChange: TNotifyEvent;
  42.     function GetDisplay: Double;
  43.     function GetTitle: string;
  44.     procedure SetTitle(const Value: string);
  45.     function TitleStored: Boolean;
  46.   protected
  47.     procedure Change; dynamic;
  48.     procedure CalcKey(var Key: Char); dynamic;
  49.     procedure DisplayChange; dynamic;
  50.   public
  51.     constructor Create(AOwner: TComponent); override;
  52.     destructor Destroy; override;
  53.     function Execute: Boolean;
  54.     property CalcDisplay: Double read GetDisplay;
  55.     property Memory: Double read FMemory;
  56.   published
  57.     property BeepOnError: Boolean read FBeepOnError write FBeepOnError default True;
  58.     property Ctl3D: Boolean read FCtl3D write FCtl3D default True;
  59.     property HelpContext: THelpContext read FHelpContext write FHelpContext default 0;
  60.     property Precision: Byte read FPrecision write FPrecision default DefCalcPrecision;
  61.     property Title: string read GetTitle write SetTitle stored TitleStored;
  62.     property Value: Double read FValue write FValue;
  63.     property OnCalcKey: TKeyPressEvent read FOnCalcKey write FOnCalcKey;
  64.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  65.     property OnDisplayChange: TNotifyEvent read FOnDisplayChange write FOnDisplayChange;
  66.   end;
  67.  
  68. { TRxCalculatorForm }
  69.  
  70.   TRxCalculatorForm = class(TForm)
  71.   private
  72.     FMainPanel: TPanel;
  73.     FCalcPanel: TPanel;
  74.     FDisplayPanel: TPanel;
  75.     FDisplayLabel: TLabel;
  76.     FPasteItem: TMenuItem;
  77.     procedure FormKeyPress(Sender: TObject; var Key: Char);
  78.     procedure PopupMenuPopup(Sender: TObject);
  79.     procedure CopyItemClick(Sender: TObject);
  80.     procedure PasteItemClick(Sender: TObject);
  81.     procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
  82.   protected
  83.     procedure OkClick(Sender: TObject);
  84.     procedure CancelClick(Sender: TObject);
  85.     procedure CalcKey(Sender: TObject; var Key: Char);
  86.     procedure DisplayChange(Sender: TObject);
  87.   public
  88.     constructor Create(AOwner: TComponent); override;
  89.   end;
  90.  
  91. function CreateCalculatorForm(AOwner: TComponent; AHelpContext: THelpContext): TRxCalculatorForm;
  92. function CreatePopupCalculator(AOwner: TComponent
  93.   {$IFDEF RX_D4}; ABiDiMode: TBiDiMode = bdLeftToRight {$ENDIF}): TWinControl;
  94. procedure SetupPopupCalculator(PopupCalc: TWinControl; APrecision: Byte;
  95.   ABeepOnError: Boolean);
  96.  
  97. implementation
  98.  
  99. uses {$IFNDEF WIN32} Str16, {$ENDIF} VclUtils, MaxMin, rxStrUtils, ToolEdit;
  100.  
  101. {$IFDEF WIN32}
  102.  {$R *.R32}
  103. {$ELSE}
  104.  {$R *.R16}
  105. {$ENDIF}
  106.  
  107. const
  108.   SCalculator = 'Calculator';
  109.   SError = 'Error';
  110.  
  111. type
  112.   TCalcBtnKind =
  113.    (cbNone, cbNum0, cbNum1, cbNum2, cbNum3, cbNum4, cbNum5, cbNum6,
  114.     cbNum7, cbNum8, cbNum9, cbSgn, cbDcm, cbDiv, cbMul, cbSub,
  115.     cbAdd, cbSqr, cbPcnt, cbRev, cbEql, cbBck, cbClr, cbMP,
  116.     cbMS, cbMR, cbMC, cbOk, cbCancel);
  117.  
  118.   TCalcPanelLayout = (clDialog, clPopup);
  119.  
  120. procedure SetDefaultFont(AFont: TFont; Layout: TCalcPanelLayout);
  121. {$IFDEF WIN32}
  122. var
  123.   NonClientMetrics: TNonClientMetrics;
  124. {$ENDIF}
  125. begin
  126. {$IFDEF WIN32}
  127.   NonClientMetrics.cbSize := SizeOf(NonClientMetrics);
  128.   if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @NonClientMetrics, 0) then
  129.     AFont.Handle := CreateFontIndirect(NonClientMetrics.lfMessageFont)
  130.   else
  131. {$ENDIF}
  132.   with AFont do begin
  133.     Color := clWindowText;
  134.     Name := 'MS Sans Serif';
  135.     Size := 8;
  136.   end;
  137.   AFont.Style := [fsBold];
  138.   if Layout = clDialog then begin
  139.   end
  140.   else begin
  141.   end;
  142. end;
  143.  
  144. function CreateCalculatorForm(AOwner: TComponent; AHelpContext: THelpContext): TRxCalculatorForm;
  145. begin
  146.   Result := TRxCalculatorForm.Create(AOwner);
  147.   with Result do
  148.   try
  149.     HelpContext := AHelpContext;
  150. {$IFDEF WIN32}
  151.     if HelpContext <> 0 then BorderIcons := BorderIcons + [biHelp];
  152. {$ENDIF}
  153.     if Screen.PixelsPerInch <> 96 then begin { scale to screen res }
  154.       ScaleBy(Screen.PixelsPerInch, 96);
  155.       SetDefaultFont(Font, clDialog);
  156.       Left := (Screen.Width div 2) - (Width div 2);
  157.       Top := (Screen.Height div 2) - (Height div 2);
  158.     end;
  159.   except
  160.     Free;
  161.     raise;
  162.   end;
  163. end;
  164.  
  165. { TCalcButton }
  166.  
  167. type
  168.   TCalcButton = class(TRxSpeedButton)
  169.   private
  170.     FKind: TCalcBtnKind;
  171.     FFontChanging: Boolean;
  172.   protected
  173.     procedure CMParentFontChanged(var Message: TMessage); message CM_PARENTFONTCHANGED;
  174.   public
  175.     constructor CreateKind(AOwner: TComponent; AKind: TCalcBtnKind);
  176.     property Kind: TCalcBtnKind read FKind;
  177.   end;
  178.  
  179. constructor TCalcButton.CreateKind(AOwner: TComponent; AKind: TCalcBtnKind);
  180. begin
  181.   inherited Create(AOwner);
  182. {$IFDEF WIN32}
  183.   ControlStyle := ControlStyle + [csReplicatable];
  184. {$ENDIF}
  185.   FKind := AKind;
  186.   if FKind in [cbNum0..cbClr] then Tag := Ord(Kind) - 1
  187.   else Tag := -1;
  188. end;
  189.  
  190. procedure TCalcButton.CMParentFontChanged(var Message: TMessage);
  191.  
  192.   function BtnColor(Kind: TCalcBtnKind): TColor;
  193.   begin
  194.     if Kind in [cbSqr, cbPcnt, cbRev, cbMP..cbMC] then Result := clNavy
  195.     else if Kind in [cbDiv, cbMul, cbSub, cbAdd, cbEql] then Result := clPurple
  196.     else if Kind in [cbBck, cbClr] then Result := clMaroon
  197.     else Result := clBtnText;
  198.   end;
  199.  
  200. begin
  201.   if not FFontChanging then inherited;
  202.   if ParentFont and not FFontChanging then begin
  203.     FFontChanging := True;
  204.     try
  205.       Font.Color := BtnColor(FKind);
  206.       ParentFont := True;
  207.     finally
  208.       FFontChanging := False;
  209.     end;
  210.   end;
  211. end;
  212.  
  213. const
  214.   BtnPos: array[TCalcPanelLayout, TCalcBtnKind] of TPoint =
  215.   (((X: -1; Y: -1), (X: 47; Y: 104), (X: 47; Y: 80), (X: 85; Y: 80),
  216.     (X: 123; Y: 80), (X: 47; Y: 56), (X: 85; Y: 56), (X: 123; Y: 56),
  217.     (X: 47; Y: 32), (X: 85; Y: 32), (X: 123; Y: 32), (X: 85; Y: 104),
  218.     (X: 123; Y: 104), (X: 161; Y: 32), (X: 161; Y: 56), (X: 161; Y: 80),
  219.     (X: 161; Y: 104), (X: 199; Y: 32), (X: 199; Y: 56), (X: 199; Y: 80),
  220.     (X: 199; Y: 104), (X: 145; Y: 6), (X: 191; Y: 6), (X: 5; Y: 104),
  221.     (X: 5; Y: 80), (X: 5; Y: 56), (X: 5; Y: 32),
  222.     (X: 47; Y: 6), (X: 85; Y: 6)),
  223.    ((X: -1; Y: -1), (X: 6; Y: 75), (X: 6; Y: 52), (X: 29; Y: 52),
  224.     (X: 52; Y: 52), (X: 6; Y: 29), (X: 29; Y: 29), (X: 52; Y: 29),
  225.     (X: 6; Y: 6), (X: 29; Y: 6), (X: 52; Y: 6), (X: 52; Y: 75),
  226.     (X: 29; Y: 75), (X: 75; Y: 6), (X: 75; Y: 29), (X: 75; Y: 52),
  227.     (X: 75; Y: 75), (X: -1; Y: -1), (X: -1; Y: -1), (X: -1; Y: -1),
  228.     (X: 52; Y: 98), (X: 29; Y: 98), (X: 6; Y: 98), (X: -1; Y: -1),
  229.     (X: -1; Y: -1), (X: -1; Y: -1), (X: -1; Y: -1),
  230.     (X: -1; Y: -1), (X: -1; Y: -1)));
  231.  
  232.   ResultKeys = [#13, '=', '%'];
  233.  
  234. function CreateCalcBtn(AParent: TWinControl; AKind: TCalcBtnKind;
  235.   AOnClick: TNotifyEvent; ALayout: TCalcPanelLayout): TCalcButton;
  236. const
  237.   BtnCaptions: array[cbSgn..cbMC] of PChar =
  238.    ('▒', ',', '/', '*', '-', '+', 'sqrt', '%', '1/x', '=', '<-', 'C',
  239.     'MP', 'MS', 'MR', 'MC');
  240. begin
  241.   Result := TCalcButton.CreateKind(AParent, AKind);
  242.   with Result do
  243.   try
  244.     if Kind in [cbNum0..cbNum9] then Caption := IntToStr(Tag)
  245.     else if Kind = cbDcm then Caption := DecimalSeparator
  246.     else if Kind in [cbSgn..cbMC] then Caption := StrPas(BtnCaptions[Kind]);
  247.     Left := BtnPos[ALayout, Kind].X;
  248.     Top := BtnPos[ALayout, Kind].Y;
  249.     if ALayout = clDialog then begin
  250.       Width := 36;
  251.       Height := 22;
  252.     end
  253.     else begin
  254.       Width := 21;
  255.       Height := 21;
  256.     end;
  257.     Style := bsNew;
  258.     OnClick := AOnClick;
  259.     ParentFont := True;
  260.     Parent := AParent;
  261.   except
  262.     Free;
  263.     raise;
  264.   end;
  265. end;
  266.  
  267. { TCalculatorPanel }
  268.  
  269. type
  270.   TCalculatorPanel = class(TPanel)
  271.   private
  272.     FText: string;
  273.     FStatus: TRxCalcState;
  274.     FOperator: Char;
  275.     FOperand: Double;
  276.     FMemory: Double;
  277.     FPrecision: Byte;
  278.     FBeepOnError: Boolean;
  279.     FMemoryPanel: TPanel;
  280.     FMemoryLabel: TLabel;
  281.     FOnError: TNotifyEvent;
  282.     FOnOk: TNotifyEvent;
  283.     FOnCancel: TNotifyEvent;
  284.     FOnResult: TNotifyEvent;
  285.     FOnTextChange: TNotifyEvent;
  286.     FOnCalcKey: TKeyPressEvent;
  287.     FOnDisplayChange: TNotifyEvent;
  288.     FControl: TControl;
  289.     procedure SetText(const Value: string);
  290.     procedure CheckFirst;
  291.     procedure CalcKey(Key: Char);
  292.     procedure Clear;
  293.     procedure Error;
  294.     procedure SetDisplay(R: Double);
  295.     function GetDisplay: Double;
  296.     procedure UpdateMemoryLabel;
  297.     function FindButton(Key: Char): TRxSpeedButton;
  298.     procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
  299.     procedure BtnClick(Sender: TObject);
  300.   protected
  301.     procedure TextChanged; virtual;
  302.   public
  303.     constructor CreateLayout(AOwner: TComponent; ALayout: TCalcPanelLayout);
  304.     procedure CalcKeyPress(Sender: TObject; var Key: Char);
  305.     procedure Copy;
  306.     procedure Paste;
  307.     property DisplayValue: Double read GetDisplay write SetDisplay;
  308.     property Text: string read FText;
  309.     property OnOkClick: TNotifyEvent read FOnOk write FOnOk;
  310.     property OnCancelClick: TNotifyEvent read FOnCancel write FOnCancel;
  311.     property OnResultClick: TNotifyEvent read FOnResult write FOnResult;
  312.     property OnError: TNotifyEvent read FOnError write FOnError;
  313.     property OnTextChange: TNotifyEvent read FOnTextChange write FOnTextChange;
  314.     property OnCalcKey: TKeyPressEvent read FOnCalcKey write FOnCalcKey;
  315.     property OnDisplayChange: TNotifyEvent read FOnDisplayChange write FOnDisplayChange;
  316.   end;
  317.  
  318. constructor TCalculatorPanel.CreateLayout(AOwner: TComponent;
  319.   ALayout: TCalcPanelLayout);
  320. var
  321.   Bmp: TBitmap;
  322.   I: TCalcBtnKind;
  323. const
  324.   BtnGlyphs: array[cbSgn..cbCancel] of Integer = (2{Sgn}, -1, -1, 3{Mul},
  325.     4{Sub}, 5{Add}, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 1{Ok}, 0{Cancel});
  326. begin
  327.   inherited Create(AOwner);
  328. {$IFDEF WIN32}
  329.   if ALayout = clPopup then
  330.     ControlStyle := ControlStyle + [csReplicatable];
  331. {$ENDIF}
  332.   ParentColor := False;
  333.   Color := clBtnFace;
  334.   if ALayout = clDialog then begin
  335.     Height := 129;
  336.     Width := 240;
  337.   end
  338.   else begin
  339.     Height := 124;
  340.     Width := 98;
  341.   end;
  342.   SetDefaultFont(Font, ALayout);
  343.   ParentFont := False;
  344.   BevelOuter := bvNone;
  345.   BevelInner := bvNone;
  346.   ParentColor := True;
  347.   ParentCtl3D := True;
  348.   if ALayout = clDialog then Bmp := TBitmap.Create
  349.   else Bmp := nil;
  350.   try
  351.     if Bmp <> nil then Bmp.Handle := LoadBitmap(hInstance, 'CALCBTNS');
  352.     for I := cbNum0 to cbCancel do begin
  353.       if BtnPos[ALayout, I].X > 0 then
  354.         with CreateCalcBtn(Self, I, BtnClick, ALayout) do begin
  355.           if ALayout = clDialog then begin
  356.             if (Kind in [cbBck, cbClr]) then Width := 44;
  357.             if (Kind in [cbSgn..cbCancel]) then
  358.               if BtnGlyphs[Kind] >= 0 then begin
  359.                 Caption := '';
  360.                 AssignBitmapCell(Bmp, Glyph, 6, 1, BtnGlyphs[Kind]);
  361.               end;
  362.           end
  363.           else begin
  364.             if Kind in [cbEql] then Width := 44;
  365.           end;
  366.         end;
  367.     end;
  368.     if ALayout = clDialog then begin
  369.       { Memory panel }
  370.       FMemoryPanel := TPanel.Create(Self);
  371.       with FMemoryPanel do begin
  372.         SetBounds(6, 7, 34, 20);
  373.         BevelInner := bvLowered;
  374.         BevelOuter := bvNone;
  375.         ParentColor := True;
  376.         Parent := Self;
  377.       end;
  378.       FMemoryLabel := TLabel.Create(Self);
  379.       with FMemoryLabel do begin
  380.         SetBounds(3, 3, 26, 14);
  381.         Alignment := taCenter;
  382.         AutoSize := False;
  383.         Parent := FMemoryPanel;
  384.         Font.Style := [];
  385.       end;
  386.     end;
  387.   finally
  388.     Bmp.Free;
  389.   end;
  390.   FText := '0';
  391.   FMemory := 0.0;
  392.   FPrecision := DefCalcPrecision;
  393.   FBeepOnError := True;
  394. end;
  395.  
  396. procedure TCalculatorPanel.SetText(const Value: string);
  397. begin
  398.   if FText <> Value then begin
  399.     FText := Value;
  400.     TextChanged;
  401.   end;
  402. end;
  403.  
  404. procedure TCalculatorPanel.TextChanged;
  405. begin
  406.   if Assigned(FControl) then TLabel(FControl).Caption := FText;
  407.   if Assigned(FOnTextChange) then FOnTextChange(Self);
  408. end;
  409.  
  410. procedure TCalculatorPanel.Error;
  411. begin
  412.   FStatus := csError;
  413.   SetText(SError);
  414.   if FBeepOnError then MessageBeep(0);
  415.   if Assigned(FOnError) then FOnError(Self);
  416. end;
  417.  
  418. procedure TCalculatorPanel.SetDisplay(R: Double);
  419. var
  420.   S: string;
  421. begin
  422.   S := FloatToStrF(R, ffGeneral, Max(2, FPrecision), 0);
  423.   if FText <> S then begin
  424.     SetText(S);
  425.     if Assigned(FOnDisplayChange) then FOnDisplayChange(Self);
  426.   end;
  427. end;
  428.  
  429. function TCalculatorPanel.GetDisplay: Double;
  430. begin
  431.   if FStatus = csError then Result := 0.0
  432.   else Result := StrToFloat(Trim(FText));
  433. end;
  434.  
  435. procedure TCalculatorPanel.CheckFirst;
  436. begin
  437.   if FStatus = csFirst then begin
  438.     FStatus := csValid;
  439.     SetText('0');
  440.   end;
  441. end;
  442.  
  443. procedure TCalculatorPanel.CMCtl3DChanged(var Message: TMessage);
  444. const
  445.   Ctl3DStyle: array[Boolean] of TButtonStyle = (bsWin31, bsNew);
  446.   Ctl3DBevel: array[Boolean] of TPanelBevel = (bvNone, bvLowered);
  447.   Ctl3DBorder: array[Boolean] of TBorderStyle = (bsSingle, bsNone);
  448. var
  449.   I: Integer;
  450. begin
  451.   inherited;
  452.   for I := 0 to ComponentCount - 1 do begin
  453.     if Components[I] is TRxSpeedButton then
  454.       TRxSpeedButton(Components[I]).Style := Ctl3DStyle[Ctl3D]
  455.     else if Components[I] = FMemoryPanel then begin
  456.       FMemoryPanel.BevelInner := Ctl3DBevel[Ctl3D];
  457.       FMemoryPanel.BorderStyle := Ctl3DBorder[Ctl3D];
  458.     end;
  459.   end;
  460. end;
  461.  
  462. procedure TCalculatorPanel.UpdateMemoryLabel;
  463. begin
  464.   if FMemoryLabel <> nil then
  465.     if FMemory <> 0.0 then FMemoryLabel.Caption := 'M'
  466.     else FMemoryLabel.Caption := '';
  467. end;
  468.  
  469. procedure TCalculatorPanel.CalcKey(Key: Char);
  470. var
  471.   R: Double;
  472. begin
  473.   Key := UpCase(Key);
  474.   if (FStatus = csError) and (Key <> 'C') then Key := #0;
  475.   if Assigned(FOnCalcKey) then FOnCalcKey(Self, Key);
  476.   if Key in [DecimalSeparator, '.', ','] then begin
  477.     CheckFirst;
  478.     if Pos(DecimalSeparator, FText) = 0 then
  479.       SetText(FText + DecimalSeparator);
  480.     Exit;
  481.   end;
  482.   case Key of
  483.     'R':
  484.       if FStatus in [csValid, csFirst] then begin
  485.         FStatus := csFirst;
  486.         if GetDisplay = 0 then Error else SetDisplay(1.0 / GetDisplay);
  487.       end;
  488.     'Q':
  489.       if FStatus in [csValid, csFirst] then begin
  490.         FStatus := csFirst;
  491.         if GetDisplay < 0 then Error else SetDisplay(Sqrt(GetDisplay));
  492.       end;
  493.     '0'..'9':
  494.       begin
  495.         CheckFirst;
  496.         if FText = '0' then SetText('');
  497.         if Pos('E', FText) = 0 then begin
  498.           if Length(FText) < Max(2, FPrecision) + Ord(Boolean(Pos('-', FText))) then
  499.             SetText(FText + Key)
  500.           else if FBeepOnError then MessageBeep(0);
  501.         end;
  502.       end;
  503.     #8:
  504.       begin
  505.         CheckFirst;
  506.         if (Length(FText) = 1) or ((Length(FText) = 2) and (FText[1] = '-')) then
  507.           SetText('0')
  508.         else
  509.           SetText(System.Copy(FText, 1, Length(FText) - 1));
  510.       end;
  511.     '_': SetDisplay(-GetDisplay);
  512.     '+', '-', '*', '/', '=', '%', #13:
  513.       begin
  514.         if FStatus = csValid then begin
  515.           FStatus := csFirst;
  516.           R := GetDisplay;
  517.           if Key = '%' then
  518.             case FOperator of
  519.               '+', '-': R := FOperand * R / 100.0;
  520.               '*', '/': R := R / 100.0;
  521.             end;
  522.           case FOperator of
  523.             '+': SetDisplay(FOperand + R);
  524.             '-': SetDisplay(FOperand - R);
  525.             '*': SetDisplay(FOperand * R);
  526.             '/': if R = 0 then Error else SetDisplay(FOperand / R);
  527.           end;
  528.         end;
  529.         FOperator := Key;
  530.         FOperand := GetDisplay;
  531.         if Key in ResultKeys then
  532.           if Assigned(FOnResult) then FOnResult(Self);
  533.       end;
  534.     #27, 'C': Clear;
  535.     ^C: Copy;
  536.     ^V: Paste;
  537.   end;
  538. end;
  539.  
  540. procedure TCalculatorPanel.Clear;
  541. begin
  542.   FStatus := csFirst;
  543.   SetDisplay(0.0);
  544.   FOperator := '=';
  545. end;
  546.  
  547. procedure TCalculatorPanel.CalcKeyPress(Sender: TObject; var Key: Char);
  548. var
  549.   Btn: TRxSpeedButton;
  550. begin
  551.   Btn := FindButton(Key);
  552.   if Btn <> nil then Btn.ButtonClick
  553.   else CalcKey(Key);
  554. end;
  555.  
  556. function TCalculatorPanel.FindButton(Key: Char): TRxSpeedButton;
  557. const
  558.   ButtonChars = '0123456789_./*-+Q%R='#8'C';
  559. var
  560.   I: Integer;
  561.   BtnTag: Longint;
  562. begin
  563.   if Key in [DecimalSeparator, '.', ','] then Key := '.'
  564.   else if Key = #13 then Key := '='
  565.   else if Key = #27 then Key := 'C';
  566.   BtnTag := Pos(UpCase(Key), ButtonChars) - 1;
  567.   if BtnTag >= 0 then
  568.     for I := 0 to ControlCount - 1 do begin
  569.       if Controls[I] is TRxSpeedButton then begin
  570.         Result := TRxSpeedButton(Controls[I]);
  571.         if Result.Tag = BtnTag then Exit;
  572.       end;
  573.     end;
  574.   Result := nil;
  575. end;
  576.  
  577. procedure TCalculatorPanel.BtnClick(Sender: TObject);
  578. begin
  579.   case TCalcButton(Sender).Kind of
  580.     cbNum0..cbNum9: CalcKey(Char(TComponent(Sender).Tag + Ord('0')));
  581.     cbSgn: CalcKey('_');
  582.     cbDcm: CalcKey(DecimalSeparator);
  583.     cbDiv: CalcKey('/');
  584.     cbMul: CalcKey('*');
  585.     cbSub: CalcKey('-');
  586.     cbAdd: CalcKey('+');
  587.     cbSqr: CalcKey('Q');
  588.     cbPcnt: CalcKey('%');
  589.     cbRev: CalcKey('R');
  590.     cbEql: CalcKey('=');
  591.     cbBck: CalcKey(#8);
  592.     cbClr: CalcKey('C');
  593.     cbMP:
  594.       if FStatus in [csValid, csFirst] then begin
  595.         FStatus := csFirst;
  596.         FMemory := FMemory + GetDisplay;
  597.         UpdateMemoryLabel;
  598.       end;
  599.     cbMS:
  600.       if FStatus in [csValid, csFirst] then begin
  601.         FStatus := csFirst;
  602.         FMemory := GetDisplay;
  603.         UpdateMemoryLabel;
  604.       end;
  605.     cbMR:
  606.       if FStatus in [csValid, csFirst] then begin
  607.         FStatus := csFirst;
  608.         CheckFirst;
  609.         SetDisplay(FMemory);
  610.       end;
  611.     cbMC:
  612.       begin
  613.         FMemory := 0.0;
  614.         UpdateMemoryLabel;
  615.       end;
  616.     cbOk:
  617.       begin
  618.         if FStatus <> csError then begin
  619.           DisplayValue := DisplayValue; { to raise exception on error }
  620.           if Assigned(FOnOk) then FOnOk(Self);
  621.         end
  622.         else if FBeepOnError then MessageBeep(0);
  623.       end;
  624.     cbCancel: if Assigned(FOnCancel) then FOnCancel(Self);
  625.   end;
  626. end;
  627.  
  628. procedure TCalculatorPanel.Copy;
  629. begin
  630.   Clipboard.AsText := FText;
  631. end;
  632.  
  633. procedure TCalculatorPanel.Paste;
  634. begin
  635.   if Clipboard.HasFormat(CF_TEXT) then
  636.     try
  637.       SetDisplay(StrToFloat(Trim(ReplaceStr(Clipboard.AsText,
  638.         CurrencyString, ''))));
  639.     except
  640.       SetText('0');
  641.     end;
  642. end;
  643.  
  644. { TLocCalculator }
  645.  
  646. type
  647.   TLocCalculator = class(TCalculatorPanel)
  648.   private
  649.     procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  650.   protected
  651.     procedure CreateParams(var Params: TCreateParams); override;
  652.   public
  653.     constructor Create(AOwner: TComponent); override;
  654.   end;
  655.  
  656. constructor TLocCalculator.Create(AOwner: TComponent);
  657. begin
  658.   inherited CreateLayout(AOwner, clPopup);
  659.   ControlStyle := [csCaptureMouse, csClickEvents, csDoubleClicks];
  660. {$IFDEF WIN32}
  661.   ControlStyle := ControlStyle + [csReplicatable];
  662. {$ENDIF}
  663.   Enabled := False;
  664.   TabStop := False;
  665. end;
  666.  
  667. procedure TLocCalculator.CMEnabledChanged(var Message: TMessage);
  668. begin
  669.   if HandleAllocated and not (csDesigning in ComponentState) then
  670.     EnableWindow(Handle, True);
  671. end;
  672.  
  673. procedure TLocCalculator.CreateParams(var Params: TCreateParams);
  674. begin
  675.   inherited CreateParams(Params);
  676.   with Params do begin
  677.     Style := Style and not (WS_TABSTOP or WS_DISABLED);
  678. {$IFDEF RX_D4}
  679.     AddBiDiModeExStyle(ExStyle);
  680. {$ENDIF}
  681.   end;
  682. end;
  683.  
  684. { TPopupCalculator }
  685.  
  686. type
  687.   TPopupCalculator = class(TPopupWindow)
  688.   private
  689.     FCalcPanel: TLocCalculator;
  690.     procedure TextChange(Sender: TObject);
  691.     procedure ResultClick(Sender: TObject);
  692.   protected
  693.     procedure KeyPress(var Key: Char); override;
  694. {$IFDEF WIN32}
  695.     function GetValue: Variant; override;
  696.     procedure SetValue(const Value: Variant); override;
  697. {$ELSE}
  698.     function GetValue: string; override;
  699.     procedure SetValue(const Value: string); override;
  700. {$ENDIF}
  701.   public
  702.     constructor Create(AOwner: TComponent); override;
  703.     function GetPopupText: string; override;
  704.   end;
  705.  
  706. function CreatePopupCalculator(AOwner: TComponent
  707.   {$IFDEF RX_D4}; ABiDiMode: TBiDiMode = bdLeftToRight {$ENDIF}): TWinControl;
  708. begin
  709.   Result := TPopupCalculator.Create(AOwner);
  710.   if (AOwner <> nil) and not (csDesigning in AOwner.ComponentState) and
  711.     (Screen.PixelsPerInch <> 96) then
  712.   begin { scale to screen res }
  713.     Result.ScaleBy(Screen.PixelsPerInch, 96);
  714.     { The ScaleBy method does not scale the font well, so set the
  715.       font back to the original info. }
  716.     TPopupCalculator(Result).FCalcPanel.ParentFont := True;
  717.     SetDefaultFont(TPopupCalculator(Result).Font, clPopup);
  718. {$IFDEF RX_D4}
  719.     Result.BiDiMode := ABiDiMode;
  720. {$ENDIF}
  721.   end;
  722. end;
  723.  
  724. procedure SetupPopupCalculator(PopupCalc: TWinControl; APrecision: Byte;
  725.   ABeepOnError: Boolean);
  726. begin
  727.   if (PopupCalc = nil) or not (PopupCalc is TPopupCalculator) then
  728.     Exit;
  729.   if TPopupCalculator(PopupCalc).FCalcPanel <> nil then
  730.     with TPopupCalculator(PopupCalc).FCalcPanel do begin
  731.       FPrecision := Max(2, APrecision);
  732.       FBeepOnError := ABeepOnError;
  733.     end;
  734. end;
  735.  
  736. constructor TPopupCalculator.Create(AOwner: TComponent);
  737. begin
  738.   inherited Create(AOwner);
  739.   Height := 127;
  740.   Width := 104;
  741.   Color := clBtnFace;
  742.   SetDefaultFont(Font, clPopup);
  743.   if (csDesigning in ComponentState) then Exit;
  744.   FCalcPanel := TLocCalculator.Create(Self);
  745.   with FCalcPanel do begin
  746.     Parent := Self;
  747.     Align := alClient;
  748.     BevelOuter := bvRaised;
  749.     FPrecision := DefCalcPrecision;
  750.     Visible := True;
  751.     OnTextChange := Self.TextChange;
  752.     OnResultClick := Self.ResultClick;
  753.   end;
  754. end;
  755.  
  756. procedure TPopupCalculator.KeyPress(var Key: Char);
  757. begin
  758.   if FCalcPanel <> nil then FCalcPanel.CalcKeyPress(Self, Key);
  759.   inherited KeyPress(Key);
  760. end;
  761.  
  762. {$IFDEF WIN32}
  763.  
  764. function TPopupCalculator.GetValue: Variant;
  765. begin
  766.   if (csDesigning in ComponentState) then Result := 0
  767.   else begin
  768.     if FCalcPanel.FStatus <> csError then begin
  769.       { to raise exception on error }
  770.       FCalcPanel.DisplayValue := FCalcPanel.DisplayValue;
  771.       Result := FCalcPanel.DisplayValue;
  772.     end
  773.     else begin
  774.       if FCalcPanel.FBeepOnError then MessageBeep(0);
  775.       Result := 0;
  776.     end;
  777.   end;
  778. end;
  779.  
  780. procedure TPopupCalculator.SetValue(const Value: Variant);
  781. begin
  782.   if not (csDesigning in ComponentState) then
  783.     with FCalcPanel do begin
  784.       try
  785.         if VarIsNull(Value) or VarIsEmpty(Value) then
  786.           DisplayValue := 0
  787.         else
  788.           DisplayValue := Value;
  789.       except
  790.         DisplayValue := 0;
  791.       end;
  792.       FStatus := csFirst;
  793.       FOperator := '=';
  794.     end;
  795. end;
  796.  
  797. {$ELSE}
  798.  
  799. function TPopupCalculator.GetValue: string;
  800. var
  801.   D: Double;
  802. begin
  803.   if (csDesigning in ComponentState) or (FCalcPanel = nil) then Result := '0'
  804.   else begin
  805.     if FCalcPanel.FStatus <> csError then begin
  806.       { to raise exception on error }
  807.       FCalcPanel.DisplayValue := FCalcPanel.DisplayValue;
  808.       D := FCalcPanel.DisplayValue;
  809.     end
  810.     else begin
  811.       if FCalcPanel.FBeepOnError then MessageBeep(0);
  812.       D := 0;
  813.     end;
  814.     Result := FloatToStrF(D, ffGeneral, Max(2, FCalcPanel.FPrecision), 0);
  815.   end;
  816. end;
  817.  
  818. procedure TPopupCalculator.SetValue(const Value: string);
  819. begin
  820.   if not (csDesigning in ComponentState) then begin
  821.     with FCalcPanel do begin
  822.       if Value = '' then DisplayValue := 0
  823.       else
  824.         try
  825.           DisplayValue := StrToFloat(Value);
  826.         except
  827.           DisplayValue := 0;
  828.         end;
  829.       FStatus := csFirst;
  830.       FOperator := '=';
  831.     end;
  832.   end;
  833. end;
  834.  
  835. {$ENDIF}
  836.  
  837. function TPopupCalculator.GetPopupText: string;
  838. begin
  839.   Result := FCalcPanel.Text;
  840. end;
  841.  
  842. procedure TPopupCalculator.ResultClick(Sender: TObject);
  843. begin
  844.   if FCalcPanel.FStatus <> csError then begin
  845.     FCalcPanel.DisplayValue := FCalcPanel.DisplayValue;
  846.     CloseUp(True);
  847.   end;
  848. end;
  849.  
  850. procedure TPopupCalculator.TextChange(Sender: TObject);
  851. begin
  852.   InvalidateEditor;
  853. end;
  854.  
  855. { TRxCalculator }
  856.  
  857. constructor TRxCalculator.Create(AOwner: TComponent);
  858. begin
  859.   inherited Create(AOwner);
  860.   FTitle := NullStr;
  861.   AssignStr(FTitle, SCalculator);
  862.   FCtl3D := True;
  863.   FPrecision := DefCalcPrecision;
  864.   FBeepOnError := True;
  865. end;
  866.  
  867. destructor TRxCalculator.Destroy;
  868. begin
  869.   FOnChange := nil;
  870.   FOnDisplayChange := nil;
  871.   DisposeStr(FTitle);
  872.   inherited Destroy;
  873. end;
  874.  
  875. function TRxCalculator.GetTitle: string;
  876. begin
  877.   Result := FTitle^;
  878. end;
  879.  
  880. procedure TRxCalculator.SetTitle(const Value: string);
  881. begin
  882.   AssignStr(FTitle, Value);
  883. end;
  884.  
  885. function TRxCalculator.TitleStored: Boolean;
  886. begin
  887.   Result := Title <> SCalculator;
  888. end;
  889.  
  890. function TRxCalculator.GetDisplay: Double;
  891. begin
  892.   if Assigned(FCalc) then
  893.     Result := TCalculatorPanel(FCalc.FCalcPanel).GetDisplay
  894.   else Result := FValue;
  895. end;
  896.  
  897. procedure TRxCalculator.CalcKey(var Key: Char);
  898. begin
  899.   if Assigned(FOnCalcKey) then FOnCalcKey(Self, Key);
  900. end;
  901.  
  902. procedure TRxCalculator.DisplayChange;
  903. begin
  904.   if Assigned(FOnDisplayChange) then FOnDisplayChange(Self);
  905. end;
  906.  
  907. procedure TRxCalculator.Change;
  908. begin
  909.   if Assigned(FOnChange) then FOnChange(Self);
  910. end;
  911.  
  912. function TRxCalculator.Execute: Boolean;
  913. begin
  914.   FCalc := CreateCalculatorForm(Self, HelpContext);
  915.   with FCalc do
  916.   try
  917.     Ctl3D := FCtl3D;
  918.     Caption := Self.Title;
  919.     TCalculatorPanel(FCalcPanel).FMemory := Self.FMemory;
  920.     TCalculatorPanel(FCalcPanel).UpdateMemoryLabel;
  921.     TCalculatorPanel(FCalcPanel).FPrecision := Max(2, Self.Precision);
  922.     TCalculatorPanel(FCalcPanel).FBeepOnError := Self.BeepOnError;
  923.     if Self.FValue <> 0 then begin
  924.       TCalculatorPanel(FCalcPanel).DisplayValue := Self.FValue;
  925.       TCalculatorPanel(FCalcPanel).FStatus := csFirst;
  926.       TCalculatorPanel(FCalcPanel).FOperator := '=';
  927.     end;
  928.     Result := (ShowModal = mrOk);
  929.     if Result then begin
  930.       Self.FMemory := TCalculatorPanel(FCalcPanel).FMemory;
  931.       if (TCalculatorPanel(FCalcPanel).DisplayValue <> Self.FValue) then begin
  932.         Self.FValue := TCalculatorPanel(FCalcPanel).DisplayValue;
  933.         Change;
  934.       end;
  935.     end;
  936.   finally
  937.     Free;
  938.     FCalc := nil;
  939.   end;
  940. end;
  941.  
  942. { TRxCalculatorForm }
  943.  
  944. constructor TRxCalculatorForm.Create(AOwner: TComponent);
  945. var
  946.   Control: TWinControl;
  947.   Popup: TPopupMenu;
  948.   Items: array[0..1] of TMenuItem;
  949. begin
  950. {$IFDEF CBUILDER}
  951.   inherited CreateNew(AOwner, 0);
  952. {$ELSE}
  953.   inherited CreateNew(AOwner);
  954. {$ENDIF}
  955.   BorderIcons := [biSystemMenu];
  956.   BorderStyle := bsDialog;
  957.   Caption := SCalculator;
  958.   ClientHeight := 159;
  959.   ClientWidth := 242;
  960.   SetDefaultFont(Font, clDialog);
  961.   KeyPreview := True;
  962.   PixelsPerInch := 96;
  963.   Position := poScreenCenter;
  964.   OnKeyPress := FormKeyPress;
  965.   Items[0] := NewItem('&Copy', scCtrl + vk_Insert, False, True, CopyItemClick, 0, '');
  966.   Items[1] := NewItem('&Paste', scShift + vk_Insert, False, True, PasteItemClick, 0, '');
  967.   FPasteItem := Items[1];
  968.   Popup := NewPopupMenu(Self, 'PopupMenu', paLeft, True, Items);
  969.   Popup.OnPopup := PopupMenuPopup;
  970.   { MainPanel }
  971.   FMainPanel := TPanel.Create(Self);
  972.   with FMainPanel do begin
  973.     Align := alClient;
  974.     Parent := Self;
  975.     BevelOuter := bvLowered;
  976.     ParentColor := True;
  977.     PopupMenu := Popup;
  978.   end;
  979.   { DisplayPanel }
  980.   FDisplayPanel := TPanel.Create(Self);
  981.   with FDisplayPanel do begin
  982.     SetBounds(6, 6, 230, 23);
  983.     Parent := FMainPanel;
  984.     BevelOuter := bvLowered;
  985.     Color := clWindow;
  986.     Ctl3D := False;
  987.   end;
  988.   Control := TPanel.Create(Self);
  989.   with TPanel(Control) do begin
  990.     SetBounds(1, 1, 228, 21);
  991.     Align := alClient;
  992.     Parent := FDisplayPanel;
  993.     BevelOuter := bvNone;
  994.     BorderStyle := bsSingle;
  995.     Ctl3D := False;
  996.     ParentColor := True;
  997.     ParentCtl3D := False;
  998.   end;
  999.   FDisplayLabel := TLabel.Create(Self);
  1000.   with FDisplayLabel do begin
  1001.     AutoSize := False;
  1002.     Alignment := taRightJustify;
  1003.     SetBounds(5, 2, 217, 15);
  1004.     Parent := TPanel(Control);
  1005.     Caption := '0';
  1006.   end;
  1007.   { CalcPanel }
  1008.   FCalcPanel := TCalculatorPanel.CreateLayout(Self, clDialog);
  1009.   with TCalculatorPanel(FCalcPanel) do begin
  1010.     Align := alBottom;
  1011.     Parent := FMainPanel;
  1012.     OnOkClick := Self.OkClick;
  1013.     OnCancelClick := Self.CancelClick;
  1014.     OnCalcKey := Self.CalcKey;
  1015.     OnDisplayChange := Self.DisplayChange;
  1016.     FControl := FDisplayLabel;
  1017.   end;
  1018. end;
  1019.  
  1020. procedure TRxCalculatorForm.CMCtl3DChanged(var Message: TMessage);
  1021. const
  1022.   Ctl3DBevel: array[Boolean] of TPanelBevel = (bvNone, bvLowered);
  1023. begin
  1024.   inherited;
  1025.   if FDisplayPanel <> nil then FDisplayPanel.BevelOuter := Ctl3DBevel[Ctl3D];
  1026.   if FMainPanel <> nil then FMainPanel.BevelOuter := Ctl3DBevel[Ctl3D];
  1027. end;
  1028.  
  1029. procedure TrxCalculatorForm.FormKeyPress(Sender: TObject; var Key: Char);
  1030. begin
  1031.   TCalculatorPanel(FCalcPanel).CalcKeyPress(Sender, Key);
  1032. end;
  1033.  
  1034. procedure TRxCalculatorForm.CopyItemClick(Sender: TObject);
  1035. begin
  1036.   TCalculatorPanel(FCalcPanel).Copy;
  1037. end;
  1038.  
  1039. procedure TRxCalculatorForm.PasteItemClick(Sender: TObject);
  1040. begin
  1041.   TCalculatorPanel(FCalcPanel).Paste;
  1042. end;
  1043.  
  1044. procedure TRxCalculatorForm.OkClick(Sender: TObject);
  1045. begin
  1046.   ModalResult := mrOk;
  1047. end;
  1048.  
  1049. procedure TRxCalculatorForm.CancelClick(Sender: TObject);
  1050. begin
  1051.   ModalResult := mrCancel;
  1052. end;
  1053.  
  1054. procedure TRxCalculatorForm.CalcKey(Sender: TObject; var Key: Char);
  1055. begin
  1056.   if (Owner <> nil) and (Owner is TRxCalculator) then
  1057.     TRxCalculator(Owner).CalcKey(Key);
  1058. end;
  1059.  
  1060. procedure TRxCalculatorForm.DisplayChange(Sender: TObject);
  1061. begin
  1062.   if (Owner <> nil) and (Owner is TRxCalculator) then
  1063.     TRxCalculator(Owner).DisplayChange;
  1064. end;
  1065.  
  1066. procedure TRxCalculatorForm.PopupMenuPopup(Sender: TObject);
  1067. begin
  1068.   FPasteItem.Enabled := Clipboard.HasFormat(CF_TEXT);
  1069. end;
  1070.  
  1071. end.
  1072.