bscalc.pas

一套非常好用的delphi控件,方便程序员工作

function CreateCalcBtn(AParent: TWinControl; AKind: TCalcBtnKind;
  AOnClick: TNotifyEvent): TCalcButton;
const
  BtnCaptions: array[cbSgn..cbMC] of PChar =
   ('+/-', ',', '/', '*', '-', '+', 'sqrt', '%', '1/x', '=', '<', 'C',
    'MP', 'MS', 'MR', 'MC');
begin
  Result := TCalcButton.CreateKind(AParent, AKind);
  with Result do
  try
    if Kind in [cbNum0..cbNum9] then Caption := IntToStr(Tag)
    else if Kind = cbDcm then Caption := DecimalSeparator
    else if Kind in [cbSgn..cbMC] then Caption := StrPas(BtnCaptions[Kind]);
    Left := BtnPos[Kind].X + BtnOffset;
    Top := BtnPos[Kind].Y;
    Width := 30;
    Height := 22;
    OnClick := AOnClick;
    Parent := AParent;
  except
    Free;
    raise;
  end;
end;

{ TCalculatorPanel }

type
  TCalculatorPanel = class(TbsSkinPanel)
  private
    FText: string;
    FStatus: TbsCalcState;
    FOperator: Char;
    FOperand: Double;
    FMemory: Double;
    FPrecision: Byte;
    FBeepOnError: Boolean;
    FMemoryLabel: TbsSkinStdLabel;
    FOnError: TNotifyEvent;
    FOnOk: TNotifyEvent;
    FOnCancel: TNotifyEvent;
    FOnResult: TNotifyEvent;
    FOnTextChange: TNotifyEvent;
    FOnCalcKey: TKeyPressEvent;
    FOnDisplayChange: TNotifyEvent;
    FControl: TControl;
    procedure SetText(const Value: string);
    procedure CheckFirst;
    procedure CalcKey(Key: Char);
    procedure Clear;
    procedure Error;
    procedure SetDisplay(R: Double);
    function GetDisplay: Double;
    procedure UpdateMemoryLabel;
    function FindButton(Key: Char): TbsSkinSpeedButton;
    procedure BtnClick(Sender: TObject);
  protected
    procedure TextChanged; virtual;
  public
    constructor CreateLayout(AOwner: TComponent);
    procedure CalcKeyPress(Sender: TObject; var Key: Char);
    procedure Copy;
    procedure Paste;
    property DisplayValue: Double read GetDisplay write SetDisplay;
    property Text: string read FText;
    property OnOkClick: TNotifyEvent read FOnOk write FOnOk;
    property OnCancelClick: TNotifyEvent read FOnCancel write FOnCancel;
    property OnResultClick: TNotifyEvent read FOnResult write FOnResult;
    property OnError: TNotifyEvent read FOnError write FOnError;
    property OnTextChange: TNotifyEvent read FOnTextChange write FOnTextChange;
    property OnCalcKey: TKeyPressEvent read FOnCalcKey write FOnCalcKey;
    property OnDisplayChange: TNotifyEvent read FOnDisplayChange write FOnDisplayChange;
  end;

constructor TCalculatorPanel.CreateLayout(AOwner: TComponent);
var
  I: TCalcBtnKind;
const
    BtnCaptions: array[cbSgn..cbCancel] of PChar =
    ('+/-', ',', '/', '*', '-', '+', 'sqrt', '%', '1/x', '=', '', '',
    'MP', 'MS', 'MR', 'MC', '', '');
begin
  inherited Create(AOwner);
  Height := 150;
  Width := 210 + BtnOffset;
  try
    for I := cbNum0 to cbCancel do begin
      if BtnPos[I].X > 0 then
        with CreateCalcBtn(Self, I, BtnClick) do
        begin
          NumGlyphs := 1;
          case I of
            cbClr: Glyph.LoadFromResourceName(HInstance, 'BS_CALC_CLEAR');
            cbBck: Glyph.LoadFromResourceName(HInstance, 'BS_CALC_BACKSPACE');
            cbOK: Glyph.LoadFromResourceName(HInstance, 'BS_CALC_OK');
            cbCancel: Glyph.LoadFromResourceName(HInstance, 'BS_CALC_CANCEL');
          end;
          if (Kind in [cbBck, cbClr]) then Width := 46;
          if (Kind in [cbSgn..cbCancel]) then Caption := BtnCaptions[Kind];
        end;
    end;
    FMemoryLabel := TbsSkinStdLabel.Create(Self);
    with FMemoryLabel do begin
      SetBounds(6, 7, 34, 20);
      Parent := Self;
      Alignment := taCenter;
    end;
  finally
  end;
  FText := '0';
  FMemory := 0.0;
  FPrecision := DefCalcPrecision;
  FBeepOnError := True;
end;

procedure TCalculatorPanel.SetText(const Value: string);
begin
  if FText <> Value then begin
    FText := Value;
    TextChanged;
  end;
end;

procedure TCalculatorPanel.TextChanged;
begin
  if Assigned(FControl) then TLabel(FControl).Caption := FText;
  if Assigned(FOnTextChange) then FOnTextChange(Self);
end;

procedure TCalculatorPanel.Error;
begin
  FStatus := csError;
  SetText(BS_ERROR);
  if FBeepOnError then MessageBeep(0);
  if Assigned(FOnError) then FOnError(Self);
end;

procedure TCalculatorPanel.SetDisplay(R: Double);
var
  S: string;
begin
  S := FloatToStrF(R, ffGeneral, Max(2, FPrecision), 0);
  if FText <> S then begin
    SetText(S);
    if Assigned(FOnDisplayChange) then FOnDisplayChange(Self);
  end;
end;

function TCalculatorPanel.GetDisplay: Double;
begin
  if FStatus = csError then Result := 0.0
  else Result := StrToFloat(Trim(FText));
end;

procedure TCalculatorPanel.CheckFirst;
begin
  if FStatus = csFirst then begin
    FStatus := csValid;
    SetText('0');
  end;
end;

procedure TCalculatorPanel.UpdateMemoryLabel;
begin
  if FMemoryLabel <> nil then
    if FMemory <> 0.0 then FMemoryLabel.Caption := 'M'
    else FMemoryLabel.Caption := '';
end;

procedure TCalculatorPanel.CalcKey(Key: Char);
var
  R: Double;
begin
  Key := UpCase(Key);
  if (FStatus = csError) and (Key <> 'C') then Key := #0;
  if Assigned(FOnCalcKey) then FOnCalcKey(Self, Key);
  if Key in [DecimalSeparator, '.', ','] then begin
    CheckFirst;
    if Pos(DecimalSeparator, FText) = 0 then
      SetText(FText + DecimalSeparator);
    Exit;
  end;
  case Key of
    'R':
      if FStatus in [csValid, csFirst] then begin
        FStatus := csFirst;
        if GetDisplay = 0 then Error else SetDisplay(1.0 / GetDisplay);
      end;
    'Q':
      if FStatus in [csValid, csFirst] then begin
        FStatus := csFirst;
        if GetDisplay < 0 then Error else SetDisplay(Sqrt(GetDisplay));
      end;
    '0'..'9':
      begin
        CheckFirst;
        if FText = '0' then SetText('');
        if Pos('E', FText) = 0 then begin
          if Length(FText) < Max(2, FPrecision) + Ord(Boolean(Pos('-', FText))) then
            SetText(FText + Key)
          else if FBeepOnError then MessageBeep(0);
        end;
      end;
    #8:
      begin
        CheckFirst;
        if (Length(FText) = 1) or ((Length(FText) = 2) and (FText[1] = '-')) then
          SetText('0')
        else
          SetText(System.Copy(FText, 1, Length(FText) - 1));
      end;
    '_': SetDisplay(-GetDisplay);
    '+', '-', '*', '/', '=', '%', #13:
      begin
        if FStatus = csValid then begin
          FStatus := csFirst;
          R := GetDisplay;
          if Key = '%' then
            case FOperator of
              '+', '-': R := FOperand * R / 100.0;
              '*', '/': R := R / 100.0;
            end;
          case FOperator of
            '+': SetDisplay(FOperand + R);
            '-': SetDisplay(FOperand - R);
            '*': SetDisplay(FOperand * R);
            '/': if R = 0 then Error else SetDisplay(FOperand / R);
          end;
        end;
        FOperator := Key;
        FOperand := GetDisplay;
        if Key in ResultKeys then
          if Assigned(FOnResult) then FOnResult(Self);
      end;
    #27, 'C': Clear;
    ^C: Copy;
    ^V: Paste;
  end;
end;

procedure TCalculatorPanel.Clear;
begin
  FStatus := csFirst;
  SetDisplay(0.0);
  FOperator := '=';
end;

procedure TCalculatorPanel.CalcKeyPress(Sender: TObject; var Key: Char);
var
  Btn: TbsSkinSpeedButton;
begin
  Btn := FindButton(Key);
  if Btn <> nil then Btn.ButtonClick
  else CalcKey(Key);
end;

function TCalculatorPanel.FindButton(Key: Char): TbsSkinSpeedButton;
const
  ButtonChars = '0123456789_./*-+Q%R='#8'C';
var
  I: Integer;
  BtnTag: Longint;
begin
  if Key in [DecimalSeparator, '.', ','] then Key := '.'
  else if Key = #13 then Key := '='
  else if Key = #27 then Key := 'C';
  BtnTag := Pos(UpCase(Key), ButtonChars) - 1;
  if BtnTag >= 0 then
    for I := 0 to ControlCount - 1 do begin
      if Controls[I] is TbsSkinSpeedButton then begin
        Result := TbsSkinSpeedButton(Controls[I]);
        if Result.Tag = BtnTag then Exit;
      end;
    end;
  Result := nil;
end;

procedure TCalculatorPanel.BtnClick(Sender: TObject);
begin
  case TCalcButton(Sender).Kind of
    cbNum0..cbNum9: CalcKey(Char(TComponent(Sender).Tag + Ord('0')));
    cbSgn: CalcKey('_');
    cbDcm: CalcKey(DecimalSeparator);
    cbDiv: CalcKey('/');
    cbMul: CalcKey('*');
    cbSub: CalcKey('-');
    cbAdd: CalcKey('+');
    cbSqr: CalcKey('Q');
    cbPcnt: CalcKey('%');
    cbRev: CalcKey('R');
    cbEql: CalcKey('=');
    cbBck: CalcKey(#8);
    cbClr: CalcKey('C');
    cbMP:
      if FStatus in [csValid, csFirst] then begin
        FStatus := csFirst;
        FMemory := FMemory + GetDisplay;
        UpdateMemoryLabel;
      end;
    cbMS:
      if FStatus in [csValid, csFirst] then begin
        FStatus := csFirst;
        FMemory := GetDisplay;
        UpdateMemoryLabel;
      end;
    cbMR:
      if FStatus in [csValid, csFirst] then begin
        FStatus := csFirst;
        CheckFirst;
        SetDisplay(FMemory);
      end;
    cbMC:
      begin
        FMemory := 0.0;
        UpdateMemoryLabel;
      end;
    cbOk:
      begin
        if FStatus <> csError then begin
          CalcKey('=');
          DisplayValue := DisplayValue; { to raise exception on error }
          if Assigned(FOnOk) then FOnOk(Self);
        end
        else if FBeepOnError then MessageBeep(0);
      end;
    cbCancel: if Assigned(FOnCancel) then FOnCancel(Self);
  end;
end;

procedure TCalculatorPanel.Copy;
begin
  Clipboard.AsText := FText;
end;

procedure TCalculatorPanel.Paste;
begin
  if Clipboard.HasFormat(CF_TEXT) then
    try
      SetDisplay(StrToFloat(Trim(ReplaceStr(Clipboard.AsText,
        CurrencyString, ''))));
    except
      SetText('0');
    end;
end;

{ TbsCalculator }

constructor TbsSkinCalculator.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FTitle := BS_CALC_CAP;
  FPrecision := DefCalcPrecision;
  FBeepOnError := True;
  FButtonSkinDataName := 'toolbutton';
  FDisplayLabelSkinDataName := 'label';
  FDefaultFont := TFont.Create;
  with FDefaultFont do
  begin
    Name := 'Arial';
    Style := [];
    Height := 14;
  end;
end;

destructor TbsSkinCalculator.Destroy;
begin
  FOnChange := nil;
  FOnDisplayChange := nil;
  FDefaultFont.Free;
  inherited Destroy;
end;

procedure TbsSkinCalculator.SetDefaultFont;
begin
  FDefaultFont.Assign(Value);
end;


procedure TbsSkinCalculator.Notification;
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (AComponent = FSD) then FSD := nil;
  if (Operation = opRemove) and (AComponent = FCtrlFSD) then FCtrlFSD := nil;
end;

function TbsSkinCalculator.GetTitle: string;
begin
  Result := FTitle;
end;

procedure TbsSkinCalculator.SetTitle(const Value: string);
begin
  FTitle := Value;
end;

function TbsSkinCalculator.TitleStored: Boolean;
begin
  Result := Title <> BS_CALC_CAP;
end;

function TbsSkinCalculator.GetDisplay: Double;
begin
  if Assigned(FCalc) then
    Result := TCalculatorPanel(FCalc.FCalcPanel).GetDisplay
  else Result := FValue;
end;

procedure TbsSkinCalculator.CalcKey(var Key: Char);
begin
  if Assigned(FOnCalcKey) then FOnCalcKey(Self, Key);
end;

procedure TbsSkinCalculator.DisplayChange;
begin
  if Assigned(FOnDisplayChange) then FOnDisplayChange(Self);
end;