rm_dlgexpr.pas

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

{*****************************************}
{                                         }
{          Report Machine v1.0            }
{             Expr Dialog                 }
{                                         }
{*****************************************}

unit RM_DlgExpr;

{$I RM.INC}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, ComCtrls, Buttons{$IFDEF Delphi4}, ImgList{$ENDIF};

type
  TRMFormExpressionBuilder = class(TForm)
    Panel2: TPanel;
    PageControl1: TPageControl;
    TabSheetExpr: TTabSheet;
    TabSheetDatabase: TTabSheet;
    TabSheetVal: TTabSheet;
    TabSheetFunc: TTabSheet;
    lblHeading: TLabel;
    InsertGroupBox: TGroupBox;
    AddPlus: TButton;
    AddMinus: TButton;
    AddMul: TButton;
    AddDiv: TButton;
    AddEqual: TButton;
    AddSmaller: TButton;
    AddLarger: TButton;
    AddNotEqual: TButton;
    AddLessEqual: TButton;
    AddGreaterEqual: TButton;
    AddNot: TButton;
    AddAnd: TButton;
    AddOr: TButton;
    Button3: TButton;
    btnClearExpr: TButton;
    btnOK: TButton;
    btnCancel: TButton;
    SelectVariableGroupBox: TGroupBox;
    btnVariableOK: TButton;
    btnVariableCancel: TButton;
    btnFunctionOK: TButton;
    btnFunctionCancel: TButton;
    FunctionGroupBox: TGroupBox;
    FuncName: TLabel;
    FuncDescription: TLabel;
    lstFunc: TListBox;
    btnDataFieldOK: TButton;
    DataFieldCancelBtn: TButton;
    DatafieldGB: TGroupBox;
    DatasetLabel: TLabel;
    DatafieldLabel: TLabel;
    lstFields: TListBox;
    lstDatasets: TListBox;
    TabSheetFuncParam: TTabSheet;
    GroupBox6: TGroupBox;
    CopyFuncName: TLabel;
    CopyFuncDescription: TLabel;
    FuncParamSB: TScrollBox;
    btnFuncParamOk: TButton;
    btnFuncArgCancel: TButton;
    CategoryLB: TListBox;
    VarLB: TListBox;
    Image2: TImage;
    Image1: TImage;
    Image3: TImage;
    Image4: TImage;
    Image5: TImage;
    btnInsertDataField: TSpeedButton;
    btnInsertVariable: TSpeedButton;
    btnInsertFunction: TSpeedButton;
    TreeViewFunctions: TTreeView;
    ImageList1: TImageList;
    chkUseTableName: TCheckBox;
    procedure FormCreate(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure btnOKClick(Sender: TObject);
    procedure btnCancelClick(Sender: TObject);
    procedure btnClearExprClick(Sender: TObject);
    procedure btnInsertDataFieldClick(Sender: TObject);
    procedure btnDataFieldOKClick(Sender: TObject);
    procedure DataFieldCancelBtnClick(Sender: TObject);
    procedure btnInsertFunctionClick(Sender: TObject);
    procedure btnFunctionOKClick(Sender: TObject);
    procedure btnInsertVariableClick(Sender: TObject);
    procedure btnFunctionCancelClick(Sender: TObject);
    procedure lstDatasetsClick(Sender: TObject);
    procedure AddOrClick(Sender: TObject);
    procedure lstFieldsDblClick(Sender: TObject);
    procedure btnVariableOKClick(Sender: TObject);
    procedure btnVariableCancelClick(Sender: TObject);
    procedure lstFuncDblClick(Sender: TObject);
    procedure btnFuncParamOkClick(Sender: TObject);
    procedure btnFuncArgCancelClick(Sender: TObject);
    procedure lstFuncClick(Sender: TObject);
    procedure CategoryLBDrawItem(Control: TWinControl; Index: Integer;
      ARect: TRect; State: TOwnerDrawState);
    procedure CategoryLBClick(Sender: TObject);
    procedure VarLBDblClick(Sender: TObject);
    procedure TreeViewFunctionsChange(Sender: TObject; Node: TTreeNode);
    procedure FormShow(Sender: TObject);
    procedure VarLBClick(Sender: TObject);
  private
    Expr: TEdit;
    FExprResult: integer;
    FDatafieldResult: integer;
    FFuncParamsResult: integer;
    FFuncResult: integer;
    FVariableResult: integer;
    FVal: string;

    function CurDataSet: string;
    procedure GetVariables;
    procedure GetSpecValues;
    function GetParams(ParamList: string; var ParamResult: string): boolean;
    procedure GetParamExprClick(Sender: TObject);
    procedure SelectFunc(Index: integer);

    procedure InsertText(AText: string);
    function GetDatafield(var Field: string): boolean;
    function GetFunc(var Func: string): boolean;
    function GetVariable(var Variable: string): boolean;
    procedure Localize;
  public
  end;

function RMGetExpression(ACaption: string; var Value: string; AParentControl: TWinControl): boolean;

implementation

uses
  RM_Pars, RM_Class, RM_Const, RM_Const1, RM_Utils, RM_DBRel, DB, RM_Desgn,
  RM_CmpReg;

{$R *.DFM}

var
  LastDB: string;
  LastCategory: string;

function TrimExpr(AExpr: string): string;
begin
  while pos(#13, AExpr) > 0 do
    Delete(AExpr, Pos(#13, AExpr), 2);
  Result := AExpr;
end;

function RMGetExpression(ACaption: string; var Value: string; AParentControl: TWinControl): boolean;
begin
  with TRMFormExpressionBuilder.Create(Application) do
  try
    chkUseTableName.Checked := TRMDesignerForm(RMDesigner).UseTableName;
    if AParentControl <> nil then
    begin
      Parent := AParentControl;
      Top := 0;
      Left := 0;
      BorderStyle := bsNone;
      Position := poDesigned;
    end;
    if ACaption <> '' then
      lblHeading.Caption := ACaption;
    Expr.Text := Value;
    Expr.SelStart := 0;
    Expr.SelLength := Length(Value);
    FExprResult := 0;
    if Parent = nil then
      ShowModal
    else
    begin
      Show;
      repeat
        Application.HandleMessage
      until FExprResult <> 0;
    end;
    Result := FExprResult = 1;
    if Result then
      Value := TrimExpr(Expr.Text)
    else
      Value := '';
  finally
    TRMDesignerForm(RMDesigner).UseTableName := chkUseTableName.Checked;
    Free;
  end;
end;

function AddBrackets(s: string): string;
var
  i: Integer;
begin
  Result := s;
  s := AnsiUpperCase(s);
  for i := 1 to Length(s) do
  begin
    if not (s[i] in ['0'..'9', '_', '.', 'A'..'Z']) then
    begin
      Result := '[' + Result + ']';
      Break;
    end;
  end;
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{ 函数处理程序 }

function GetDescription(const FuncName: string): string; // 函数功能描述
var
  i, j: integer;
  pfunc: PRMFunctionDesc;
begin
  Result := '';
  for i := 0 to RMAddInFunctionCount - 1 do
  begin
    with RMAddInFunctions(i) do
    begin
      for j := 0 to FuncList.Count - 1 do
      begin
        pfunc := PRMFunctionDesc(FuncList[j]);
        if AnsiCompareText(pfunc^.FuncName, FuncName) = 0 then
        begin
          Result := pfunc^.Description;
          Exit;
        end;
      end;
    end;
  end;
end;

function GetArguments(const FuncName: string): string; // 函数参数
var
  i, j: integer;
  pfunc: PRMFunctionDesc;
begin
  Result := '';
  for i := 0 to RMAddInFunctionCount - 1 do
  begin
    with RMAddInFunctions(i) do
    begin
      for j := 0 to FuncList.Count - 1 do
      begin
        pfunc := PRMFunctionDesc(FuncList[j]);
        if AnsiCompareText(pfunc^.FuncName, FuncName) = 0 then
        begin
          Result := pfunc^.FuncPara;
          Exit;
        end;
      end;
    end;
  end;
end;

procedure GetCategoryList(aList: TStrings); // 函数分类
var
  i, j, k: Integer;
  pfunc: PRMFunctionDesc;
  sl: TStringList;
begin
  sl := TStringList.Create;
  try
    sl.Sorted := True;
    for i := 0 to RMAddInFunctionCount - 1 do
    begin
      with RMAddInFunctions(i) do
      begin
        for j := 0 to FuncList.Count - 1 do
        begin
          pfunc := PRMFunctionDesc(FuncList[j]);
          if not sl.Find(pfunc.Category, k) then
            sl.Add(pfunc^.Category);
        end;
      end;
    end;

    sl.Sort;
    aList.Assign(sl);
  finally
    sl.Free;
  end;
end;

procedure GetFunctionList(aCategory: string; aList: TStrings); // 每类函数列表
var
  i, j: Integer;
  pfunc: PRMFunctionDesc;
  sl: TStringList;
begin
  sl := TStringList.Create;
  try
    if aCategory = RMLoadStr(SAllCategories) then
      aCategory := '';

    for i := 0 to RMAddInFunctionCount - 1 do
    begin
      with RMAddInFunctions(i) do
      begin
        for j := 0 to FuncList.Count - 1 do
        begin
          pfunc := PRMFunctionDesc(FuncList[j]);
          if (aCategory = '') or (AnsiCompareText(pfunc^.Category, aCategory) = 0) then
            sl.Add(pfunc^.FuncName);
        end;
      end;
    end;

    sl.Sort;
    aList.Assign(sl);
  finally
    sl.Free;
  end;
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{ TWordWrapEdit }
type
  TWordWrapEdit = class(TEdit)
  protected
    procedure CreateParams(var Params: TCreateParams); override;
  end;

procedure TWordWrapEdit.CreateParams(var Params: TCreateParams);
const
  WordWraps: array[Boolean] of LongInt = (0, ES_AUTOHSCROLL);
begin
  inherited CreateParams(Params);
  with Params do
  begin
    Style := Style and not WordWraps[True] or ES_MULTILINE
  end;
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMFormExpressionBuilder}

procedure TRMFormExpressionBuilder.Localize;
begin
  Font.Name := RMLoadStr(SRMDefaultFontName);
  Font.Size := StrToInt(RMLoadStr(SRMDefaultFontSize));
  Font.Charset := StrToInt(RMLoadStr(SCharset));

  RMSetStrProp(Self, 'Caption', rmRes + 700);
  RMSetStrProp(lblHeading, 'Caption', rmRes + 701);
  RMSetStrProp(InsertGroupBox, 'Caption', rmRes + 702);
  RMSetStrProp(btnInsertDataField, 'Caption', rmRes + 703);
  RMSetStrProp(btnInsertVariable, 'Caption', rmRes + 704);
  RMSetStrProp(btnInsertFunction, 'Caption', rmRes + 705);
  RMSetStrProp(btnClearExpr, 'Caption', rmRes + 721);
  RMSetStrProp(Button3, 'Caption', rmRes + 712);

  RMSetStrProp(DatasetLabel, 'Caption', rmRes + 706);
  RMSetStrProp(DatafieldLabel, 'Caption', rmRes + 707);
  RMSetStrProp(DatafieldGB, 'Caption', rmRes + 713);
  btnDataFieldOK.Caption := RMLoadStr(SOK);
  DataFieldCancelBtn.Caption := RMLoadStr(SCancel);

  btnVariableOK.Caption := RMLoadStr(SOK);
  btnVariableCancel.Caption := RMLoadStr(SCancel);
  RMSetStrProp(SelectVariableGroupBox, 'Caption', rmRes + 708);

  RMSetStrProp(btnFunctionOK, 'Caption', rmRes + 709);
  btnFunctionCancel.Caption := RMLoadStr(SCancel);
  RMSetStrProp(FunctionGroupBox, 'Caption', rmRes + 710);

  RMSetStrProp(GroupBox6, 'Caption', rmRes + 711);
  btnFuncParamOk.Caption := RMLoadStr(SOK);
  btnFuncArgCancel.Caption := RMLoadStr(SCancel);
  RMSetStrProp(chkUseTableName, 'Caption', rmRes + 722);

  btnOK.Caption := RMLoadStr(SOK);
  btnCancel.Caption := RMLoadStr(SCancel);
end;

procedure TRMFormExpressionBuilder.InsertText(AText: string);
begin
  Expr.SelText := AText;
  Expr.SelStart := Expr.SelStart + Expr.SelLength;
  Expr.SelLength := 0;
end;

procedure TRMFormExpressionBuilder.SelectFunc(Index: Integer);
var
  str: string;
begin
  if Index < lstFunc.Items.Count then
  begin
    str := GetDescription(lstFunc.Items[lstFunc.ItemIndex]);
    FuncName.Caption := Copy(str, 1, Pos('|', str) - 1);
    FuncDescription.Caption := Copy(str, Pos('|', str) + 1, 1000);
  end
  else
  begin
    FuncDescription.Caption := '';
    FuncName.Caption := '';
  end;
end;

procedure TRMFormExpressionBuilder.GetParamExprClick(Sender: TObject);
var
  I: integer;
  ParamExpr: string;
begin
  for I := 0 to FuncParamSB.ControlCount - 1 do
  begin
    if (FuncParamSB.Controls[I] is TEdit) and (TEdit(FuncParamSB.Controls[I]).Tag = TSpeedButton(Sender).Tag) then
    begin
      with TEdit(FuncParamSB.Controls[I]) do
      begin
        ParamExpr := Text;
        if RMGetExpression(Format(RMLoadStr(rmRes + 728), [Tag + 1, FuncName.Caption]),
          ParamExpr, Self) then
          Text := ParamExpr;

        PageControl1.ActivePage := TabSheetFuncParam;
        SetFocus;
        SelStart := 0;
        SelLength := Length(Text);
        Exit;
      end;
    end;
  end;
end;

function TRMFormExpressionBuilder.GetParams(ParamList: string; var ParamResult: string): boolean;
var
  I: integer;
begin
  PageControl1.ActivePage := TabSheetFuncParam;
  CopyFuncName.Caption := FuncName.Caption;
  CopyFuncDescription.Caption := FuncDescription.Caption;
  for I := 0 to length(ParamList) - 1 do
  begin
    with TLabel.Create(Self) do
    begin
      Parent := FuncParamSB;
      Left := 10;
      Top := I * 40;
      Tag := 1;
      case ParamList[I + 1] of