expressionform.pas

来自「胜天财务进销存2003源代码,SQLSERVER版,目前最完整的财务进销存系统.」· PAS 代码 · 共 328 行

unit ExpressionForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Buttons, ExtCtrls, ComCtrls, EditForm, DB, ADODB, KsSkinEngine,
  KsButtons, KsSkinButtons, KsControls, KsSpeedButtons, KsSkinSpeedButtons,
  KsListBoxs, KsSkinListBoxs, KsGroupBoxs, KsSkinGroupBoxs, KsPanels,
  KsSkinPanels, BaseForm, Compile_Calc, KsHooks, KsForms, KsSkinForms, dxCntner,
  dxEditor, dxExEdtr, dxEdLib;

type
  TfrmExpression = class(TfrmEditForm)
    GroupBox2: TSeSkinGroupBox;
    ListBox: TSeSkinListBox;
    GroupBox3: TSeSkinGroupBox;
    sbAdd: TSeSkinSpeedButton;
    sbEec: TSeSkinSpeedButton;
    sbMul: TSeSkinSpeedButton;
    sbDiv: TSeSkinSpeedButton;
    sbLeft: TSeSkinSpeedButton;
    sbRight: TSeSkinSpeedButton;
    sbCheck: TSeSkinButton;
    bbYes: TSeSkinButton;
    bbClear: TSeSkinButton;
    bbExit: TSeSkinButton;
    SeSkinPanel1: TSeSkinPanel;
    Memo1: TdxMemo;
    procedure bbYesClick(Sender: TObject);
    procedure ListBoxDblClick(Sender: TObject);
    procedure sbEecClick(Sender: TObject);
    procedure sbMulClick(Sender: TObject);
    procedure sbDivClick(Sender: TObject);
    procedure sbLeftClick(Sender: TObject);
    procedure sbRightClick(Sender: TObject);
    procedure sbAddClick(Sender: TObject);
    procedure sbCheckClick(Sender: TObject);
    procedure bbClearClick(Sender: TObject);
    procedure bbExitClick(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
  private
    { Private declarations }
    sReturn: string;
    lMode: Integer;
    function CheckExpression(szExp: string): Boolean;
    function ItemToIndex(szExp: string): string;
    procedure LoadGrid;
    procedure LoadData;
    procedure MainRun;
  public
    { Public declarations }
  end;
function GetExpression(szItem: string; szExp: string; l1Mode: Integer = 0): string;
  //返回以ItemIndex为准的公式串
function GetFormulaResult(formula: string): Boolean; //检验公式是否正确
function OperateFormula(Formula: string): Double; //递归实现公式的值
function GetCompileValue(sFormula: string): Double; //使用Compile_Hss类求公式的值

implementation

uses SysPublic, DBData;
{$R *.DFM}

function GetExpression(szItem: string; szExp: string; l1Mode: Integer = 0): string;
var
  frmExpression: TfrmExpression;
begin
  frmExpression := TfrmExpression.Create(Application);
  with frmExpression do
  begin
    ListBox.Items.Text := szItem;
    Memo1.Lines.Text := szExp;
    lMode := l1Mode;
    MainRun;
    Result := sReturn;
    Free;
  end;
end;

procedure TfrmExpression.MainRun;
begin
  bOperateLog := False;
  LoadGrid;
  LoadData;
  ShowModal;
end;

procedure TfrmExpression.LoadGrid;
begin
  sReturn := '';
  case lMode of
    1:
      begin
        sbEec.Visible := False;
        sbMul.Visible := False;
        sbDiv.Visible := False;
        sbLeft.Visible := False;
        sbRight.Visible := False;
      end;
  end;
end;

procedure TfrmExpression.LoadData;
begin
end;

function TfrmExpression.CheckExpression(szExp: string): Boolean;
begin
  szExp := ItemToIndex(szExp);
  Result := GetFormulaResult(szExp);
end;

function TfrmExpression.ItemToIndex(szExp: string): string;
var
  i: Integer;
  szItem: string;
begin
  for i := 0 to ListBox.Items.Count - 1 do
  begin
    szItem := ListBox.Items.Strings[i];
    szExp := StringReplace(szExp, szItem, ' ' + IntToStr(i), [rfReplaceAll]);
  end;
  Result := szExp;
end;

procedure TfrmExpression.bbYesClick(Sender: TObject);
begin
  if Trim(Memo1.lines.Text) = '' then
  begin
    ShowMsg('请输入公式。');
    exit;
  end;
  if CheckExpression(Memo1.lines.Text) then
  begin
    sReturn := Memo1.lines.Text;
    Close;
  end;
end;

procedure TfrmExpression.ListBoxDblClick(Sender: TObject);
begin
  MemoAddStart(Memo1, ListBox.Items.Strings[ListBox.ItemIndex]);
end;

procedure TfrmExpression.sbEecClick(Sender: TObject);
begin
  MemoAddStart(Memo1, '-');
end;

procedure TfrmExpression.sbMulClick(Sender: TObject);
begin
  MemoAddStart(Memo1, '*');
end;

procedure TfrmExpression.sbDivClick(Sender: TObject);
begin
  MemoAddStart(Memo1, '/');
end;

procedure TfrmExpression.sbLeftClick(Sender: TObject);
begin
  MemoAddStart(Memo1, '(');
end;

procedure TfrmExpression.sbRightClick(Sender: TObject);
begin
  MemoAddStart(Memo1, ')');
end;

procedure TfrmExpression.sbAddClick(Sender: TObject);
begin
  MemoAddStart(Memo1, '+');
end;

procedure TfrmExpression.sbCheckClick(Sender: TObject);
begin
  if CheckExpression(Memo1.lines.Text) then
    ShowMsg('公式正确。');
end;

function GetFormulaResult(formula: string): Boolean;
var
  i, j, CountOfBracket: integer;
begin
  result := False;
  CountOfBracket := 0;
  if Trim(formula) = '' then
    exit;
  for i := 1 to Length(formula) do
  begin
    if (i = 1) or (i = Length(formula)) then //检查第一个和最好一个字母的合法性
      if formula[i] in ['+', '-', '*', '/', '.'] then
      begin
        ShowMsg('算式不合法,请重新输入公式。');
        exit;
      end;
    if (formula[i] in ['+', '-', '*', '/', '.']) and (formula[i - 1] in ['+',
      '-', '*', '/', '.']) then
    begin
      ShowMsg('两个运算符相邻出错,请重新输入公式。');
        //检查是否出现两个运算符相邻
      exit;
    end;
    if (formula[i] in ['0'..'9']) then
      // and (formula[i-1] in [' '])and(formula[i-2] in ['0'..'9']) then
    begin
      for j := 1 to i do
      begin
        if (formula[i - j] in [' ']) then
          Continue;
        if (formula[i] = '0') and (formula[i - j] = '/') then
        begin
          ShowMsg('被零除错误,请重新输入公式。');
          exit;
        end;
        if not (formula[i - j] in ['0'..'9']) then
          break;
        ShowMsg('两个项目相邻出错,请重新输入公式。');
        exit;
      end;
    end;
    if (formula[i] = ')') and (formula[i - 1] = '(') then //是否有'()'
    begin
      ShowMsg('出现"()",请重新输入公式。');
      exit;
    end;
    if (ord(formula[i]) < 48) or (ord(formula[i]) > 57) then
      //检查公式中是否含有字母
      if not (formula[i] in ['+', '-', '*', '/', '.', '(', ')', ' ']) then
      begin
        ShowMsg('含有非法字符,请重新输入公式。');
        exit;
      end;
    if formula[i] = '(' then //判断括号前后的合法性
    begin
      inc(CountofBracket);
      if i <> 1 then
        if not (formula[i - 1] in ['+', '-', '*', '/', '(']) then
        begin
          Application.MessageBox('括号前后不匹配,请重新输入公式。', '错误',
            MB_OK);
          exit;
        end;
      if formula[i + 1] in ['+', '-', '*', '/', ')'] then
      begin
        ShowMsg('算式不合法,请重新输入公式。');
        exit;
      end;
    end
    else if formula[i] = ')' then //判断括号前后的合法性
    begin
      dec(CountOfBracket);
      if formula[i - 1] in ['+', '-', '*', '/'] then
      begin
        ShowMsg('括号前后不匹配,请重新输入公式。');
        exit;
      end;
      if i <> length(formula) then
        if not (formula[i + 1] in ['+', '-', '*', '/', ')']) then
        begin
          ShowMsg('算式不合法,请重新输入公式。');
          exit;
        end;
      if CountOfBracket < 0 then
      begin
        ShowMsg('括号前后不匹配,请重新输入公式。');
        exit;
      end;
    end;
  end;
  if CountOfBracket <> 0 then
  begin
    ShowMsg('括号前后不匹配,请重新输入公式。');
    exit;
  end;
  result := True;
end;

function OperateFormula(Formula: string): Double; //递归实现公式的值
var
  sSql: string;
  DataSet: TADODataSet;
begin
  DataSet := TADODataSet.Create(Application);
  sSql := 'SELECT ' + Formula + ' As ExpValue';
  DataSet.LockType := ltReadOnly;
  OpenDataSet(DataSet, sSql);
  if not DataSet.IsEmpty then
  begin
    Result := DataSet.FieldByname('ExpValue').AsFloat;
  end
  else
    Result := 0;
  DataSet.Free;
end;

function GetCompileValue(sFormula: string): Double;
var
  Compilation: TCompile;
begin
  Compilation := TCompile.Create;
  Compilation.SetText(sFormula);
  Result := Compilation.GetValue();
end;

procedure TfrmExpression.bbClearClick(Sender: TObject);
begin
  Memo1.Lines.Clear;
end;

procedure TfrmExpression.bbExitClick(Sender: TObject);
begin
  sReturn := '';
  Close;
end;

procedure TfrmExpression.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if KEY = VK_ESCAPE then
    bbExitClick(Sender);
end;

end.