expressionform.pas

进销存·完整的·有数据库的·非常完整·只得参考

unit ExpressionForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Buttons, ExtCtrls, ComCtrls, EditForm, DB, ADODB, KsSkinEngine,
  KsSkinButtons, KsSkinSpeedButtons, KsSkinListBoxs, KsSkinGroupBoxs,
  KsSkinPanels, BaseForm, Compile_Calc, KsSkinForms, dxCntner, dxEditor,
  dxExEdtr, dxEdLib, se_controls;

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.