rm_common.pas

来自「胜天进销存源码,国产优秀的进销存」· PAS 代码 · 共 1,262 行 · 第 1/3 页

unit RM_Common;

interface

{$I RM.inc}

uses
  SysUtils, Windows, Messages, Classes, Graphics, Forms, ExtCtrls, TypInfo,
  RM_Parser
{$IFDEF USE_INTERNAL_JVCL}
  , rm_JvInterpreter, rm_JvInterpreterParser, rm_JvInterpreterFm
{$ELSE}
  , JvInterpreter, JvInterpreterParser, JvInterpreterFm
{$ENDIF}
{$IFDEF Delphi6}, Variants{$ENDIF};

type
{    <Table>
    Value               Meaning
    ---------------------------
    rmutInches            Display in inches.
    rmutMillimeters       Display in millimeters.
    rmutScreenPixels      Display in screen pixels.
    rmutPrinterPixels     Display in printer pixels.
    rmutMMThousandths     Display in thousandths of millimeters.
    </Table>}
  TRMResolutionType = (rmrtHorizontal, rmrtVertical);
  TRMUnitType = (rmutScreenPixels, rmutInches, rmutMillimeters, rmutMMThousandths);
  TRMPrinterOrientation = (rmpoPortrait, rmpoLandscape);
  TRMPreviewZoom = (pzDefault, pzPageWidth, pzOnePage, pzTwoPages);
  TRMPreviewButton = (pbZoom, pbLoad, pbSave, pbPrint, pbFind, pbPageSetup, pbExit, pbDesign,
    pbSaveToXLS);
  TRMPreviewButtons = set of TRMPreviewButton;
  TRMScaleMode = (mdNone, mdPageWidth, mdOnePage, mdTwoPages, mdPrinterZoom);

  TRMDataType = (rmdtBoolean, rmdtDate, rmdtTime, rmdtDateTime, rmdtInteger, rmdtSingle,
    rmdtDouble, rmdtExtended, rmdtCurrency, rmdtChar, rmdtString, rmdtVariant,
    rmdtLongint, rmdtBLOB, rmdtMemo, rmdtGraphic, rmdtNotKnown, rmdtLargeInt);
  TRMSearchOperatorType = (rmsoEqual, rmsoNotEqual,
    rmsoLessThan, rmsoLessThanOrEqualTo,
    rmsoGreaterThan, rmsoGreaterThanOrEqualTo,
    rmsoLike, rmsoNotLike,
    rmsoBetween, soNotBetween,
    rmsoInList, rmsoNotInList,
    rmsoBlank, rmsoNotBlank);

  TRMPageInfo = record // print info about page size, margins e.t.c
    PrinterPageWidth, PrinterPageHeight, PageWidth, PageHeight: Integer; // page width/height (printer/screen)
    PrinterOffsetX, PrinterOffsetY {, OffsetX, OffsetY}: Integer; // offset x/y
  end;

  TRMReportInfo = packed record
    Title: string;
    Author: string;
    Company: string;
    CopyRight: string;
    Comment: string;
  end;

  TRMClass = class of TRMCustomView;
  TRMCustomReport = class;

  TRMParamRec = record
    IsVar: Boolean;
    IsConst: Boolean;
    IsArray: Boolean;
    Name: string;
    ClassType: string;
  end;

  PRMParamRecArray = ^TRMParamRecArray;
  TRMParamRecArray = array[0..32] of TRMParamRec;

  { TRMPersistent }
  TRMPersistent = class(TPersistent)
  private
    function GetPropVars: TRMVariables;
  protected
    FPropVars: TRMVariables;
    FName: string;

    procedure LoadEventInfo(aStream: TStream);
    procedure SaveEventInfo(aStream: TStream);

    procedure SetObjectEvent(aEventList: TList; aEngine: TJvInterpreterFm);
    procedure SetName(const Value: string); virtual;
    function GetPropValue(aObject: TObject; aPropName: string; var aValue: Variant;
      Args: array of Variant): Boolean; virtual;
    function SetPropValue(aObject: TObject; aPropName: string;
      aValue: Variant): Boolean; virtual;
  public
    constructor Create; virtual;
    destructor Destroy; override;

    property PropVars: TRMVariables read GetPropVars;
    property Name: string read FName write SetName;
  published
  end;

 { TRMComponent }
  TRMComponent = class(TComponent)
  private
  protected
    function GetPropValue(aObject: TObject; aPropName: string; var aValue: Variant;
      Args: array of Variant): Boolean; virtual;
    function SetPropValue(aObject: TObject; aPropName: string;
      aValue: Variant): Boolean; virtual;
  public
  end;

	{ TRMCustomView }
  TRMCustomView = class(TRMPersistent)
  public
    class function CanPlaceOnGridView: Boolean; virtual;
    class procedure DefaultSize(var aKx, aKy: Integer); virtual;
  end;

  TRMPreviewOptions = class(TPersistent)
  private
    FRulerUnit: TRMUnitType;
    FRulerVisible: Boolean;
    FDrawBorder: Boolean;
    FBorderPen: TPen;
  protected
  public
    constructor Create; virtual;
    destructor Destroy; override;

    procedure Assign(Source: TPersistent); override;
  published
    property RulerUnit: TRMUnitType read FRulerUnit write FRulerUnit;
    property RulerVisible: Boolean read FRulerVisible write FRulerVisible;
    property DrawBorder: Boolean read FDrawBorder write FDrawBorder;
    property BorderPen: TPen read FBorderPen write FBorderPen;
  end;

  { TRMCustomPreview}
  TRMCustomPreview = class(TPanel)
  private
    FOptions: TRMPreviewOptions;

    procedure SetOptions(Value: TRMPreviewOptions);
  protected
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    procedure ShowReport(aReport: TObject); virtual; abstract;
    procedure Connect(aReport: TObject); virtual; abstract;
    procedure Print; virtual; abstract;
  published
    property Options: TRMPreviewOptions read FOptions write SetOptions;
  end;

  { TRMBandMsg }
  TRMBandMsg = class(TPersistent)
  private
    FFont: TFont;
    FLeftMemo, FCenterMemo, FRightMemo: TStringList;
    procedure SetFont(Value: TFont);
    procedure SetLeftMemo(Value: TStringList);
    procedure SetCenterMemo(Value: TStringList);
    procedure SetRightMemo(Value: TStringList);
  protected
  public
    constructor Create;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
  published
    property Font: TFont read FFont write SetFont;
    property LeftMemo: TStringList read FLeftMemo write SetLeftMemo;
    property CenterMemo: TStringList read FCenterMemo write SetCenterMemo;
    property RightMemo: TStringList read FRightMemo write SetRightMemo;
  end;

  { TRMPageCaptionMsg }
  TRMPageCaptionMsg = class(TPersistent)
  private
    FTitleFont: TFont;
    FCaptionMsg: TRMBandMsg;
    FTitleMemo: TStringList;

    procedure SetTitleFont(Value: TFont);
    procedure SetTitleMemo(Value: TStringList);
    procedure SetCaptionMsg(Value: TRMBandMsg);
  protected
  public
    constructor Create;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
  published
    property CaptionMsg: TRMBandMsg read FCaptionMsg write SetCaptionMsg;
    property TitleFont: TFont read FTitleFont write SetTitleFont;
    property TitleMemo: TStringList read FTitleMemo write SetTitleMemo;
  end;

 { TRMCustomReport }
  TRMCustomReport = class(TRMComponent)
  private
    FTerminated: Boolean;
  protected
  public
    property Terminated: Boolean read FTerminated write FTerminated;
  end;

  TRMCustomExportFilter = class(TComponent)
  end;

  PRMFunctionDesc = ^TRMFunctionDesc;
  TRMFunctionDesc = packed record
    FuncName: string;
    Category: string;
    Description: string;
    FuncPara: string;
  end;

  { TRMFunctionLibrary }
  TRMCustomFunctionLibrary = class(TObject)
  private
    FFunctionList: TList;
    FList: TStringList;
    procedure Clear;
  protected
  public
    constructor Create; virtual;
    destructor Destroy; override;
    function OnFunction(aParser: TRMParser; const aFunctionName: string;
    	aParams: array of Variant; var aValue: Variant): Boolean; virtual;
    procedure DoFunction(aParser: TRMParser; aFuncNo: Integer; aParams: array of Variant;
      var aValue: Variant); virtual; abstract;
    procedure AddFunctionDesc(const aFuncName, aCategory, aDescription, aFuncPara: string);

    property FunctionList: TList read FFunctionList;
    property List: TStringList read FList;
  end;

 { TRMAddInObjectInfo }
  TRMAddInObjectInfo = class
  private
    FIsPage: Boolean;
    FPage: string;
    FClassRef: TRMClass;
    FEditorFormClass: TFormClass;
    FButtonBmpRes: string;
    FButtonHint: string;
    FIsControl: Boolean;
  public
    constructor Create(AClassRef: TClass; AEditorFormClass: TFormClass;
      const AButtonBmpRes: string; const AButtonHint: string; AIsControl: Boolean);
    property ClassRef: TRMClass read FClassRef write FClassRef;
    property EditorFormClass: TFormClass read FEditorFormClass write FEditorFormClass;
    property ButtonBmpRes: string read FButtonBmpRes write FButtonBmpRes;
    property ButtonHint: string read FButtonHint write FButtonHint;
    property IsControl: Boolean read FIsControl write FIsControl;
    property Page: string read FPage write FPage;
    property IsPage: Boolean read FIsPage write FIsPage;
  end;

  { TRMExportFilterInfo }
  TRMExportFilterInfo = class
  private
    FFilter: TRMCustomExportFilter;
    FFilterDesc: string;
    FFilterExt: string;
  public
    constructor Create(AClassRef: TRMCustomExportFilter; const AFilterDesc: string; const AFilterExt: string);
    property Filter: TRMCustomExportFilter read FFilter write FFilter;
    property FilterDesc: string read FFilterDesc write FFilterDesc;
    property FilterExt: string read FFilterExt write FFilterExt;
  end;

  { TRMToolsInfo }
  TRMToolsInfo = class
  private
    FCaption: string;
    FButtonBmpRes: string;
    FOnClick: TNotifyEvent;
  public
    constructor Create(const ACaption: string; const AButtonBmpRes: string; AOnClick: TNotifyEvent);
    property Caption: string read FCaption write FCaption;
    property ButtonBmpRes: string read FButtonBmpRes write FButtonBmpRes;
    property OnClick: TNotifyEvent read FOnClick write FOnClick;
  end;

  { TRMTempFileStream }
  TRMTempFileStream = class(TFileStream)
  private
    FFileName: string;
  public
    constructor Create;
    destructor Destroy; override;
    property FileName: string read FFileName;
  end;

function RMGetPropValue_1(aObject: TObject; aPropName: string; var aValue: Variant): Boolean;
function RMSetPropValue(aObject: TObject; aPropName: string; aValue: Variant): Boolean;

procedure RMRegisterObjectByRes(ClassRef: TClass; const ButtonBmpRes: string;
  const ButtonHint: string; EditorFormClass: TFormClass);
procedure RMRegisterControl(ClassRef: TClass; const ButtonBmpRes, ButtonHint: string); overload;
procedure RMRegisterControl(const aPage, aPageButtonBmpRes: string; aIsControl: Boolean;
  aClassRef: TClass;  aButtonBmpRes, aButtonHint: string); overload;
procedure RMRegisterControls(const aPage, aPageButtonBmpRes: string; aIsControl: Boolean;
  AryClassRef: array of TClass;
  AryButtonBmpRes: array of string;
  AryButtonHint: array of string);

procedure RMRegisterExportFilter(Filter: TRMCustomExportFilter; const FilterDesc, FilterExt: string);
procedure RMUnRegisterExportFilter(Filter: TRMCustomExportFilter);
procedure RMRegisterTool(const MenuCaption: string; const ButtonBmpRes: string; OnClick: TNotifyEvent);
procedure RMUnRegisterTool(const MenuCaption: string);
procedure RMRegisterFunctionLibrary(ClassRef: TClass);
procedure RMUnRegisterFunctionLibrary(ClassRef: TClass);

function RMAddIns(index: Integer): TRMAddInObjectInfo;
function RMAddInsCount: Integer;
function RMFilters(index: Integer): TRMExportFilterInfo;
function RMFiltersCount: Integer;
function RMTools(index: Integer): TRMToolsInfo;
function RMToolsCount: Integer;
function RMAddInFunctions(Index: Integer): TRMCustomFunctionLibrary;
function RMAddInFunctionCount: Integer;

var
  RMRegRootKey: string;

implementation

uses RM_Const, RM_Const1, RM_Utils;

function RMGetPropValue_1(aObject: TObject; aPropName: string; var aValue: Variant): Boolean;
var
  lPropInfo: PPropInfo;
begin
  lPropInfo := TypInfo.GetPropInfo(aObject.ClassInfo, aPropName);
  if lPropInfo = nil then
  begin
    Result := False;
    Exit;
  end;

  Result := True;
  case lPropInfo.PropType^^.Kind of
    tkInteger, tkChar, tkWChar, tkClass:
      aValue := TypInfo.GetOrdProp(aObject, lPropInfo);
    tkEnumeration:
      aValue := TypInfo.GetOrdProp(aObject, lPropInfo);
    tkSet:
      aValue := TypInfo.GetOrdProp(aObject, lPropInfo);
    tkFloat:
      aValue := TypInfo.GetFloatProp(aObject, lPropInfo);
    tkMethod:
      aValue := lPropInfo^.PropType^.Name;
    tkString, tkLString:
      aValue := TypInfo.GetStrProp(aObject, lPropInfo);
    tkWString:
      {$IFDEF Delphi6}
      aValue := TypInfo.GetWideStrProp(aObject, lPropInfo);
      {$ELSE}
      aValue := TypInfo.GetStrProp(aObject, lPropInfo);
      {$ENDIF}
    tkVariant:
      aValue := TypInfo.GetVariantProp(aObject, lPropInfo);
    tkInt64:
      {$IFDEF Delphi6}
      aValue := TypInfo.GetInt64Prop(aObject, lPropInfo);
      {$ELSE}
      aValue := TypInfo.GetInt64Prop(aObject, lPropInfo) + 0.0;
      {$ENDIF}
    tkDynArray:
  		DynArrayToVariant(aValue, Pointer(GetOrdProp(aObject, lPropInfo)), lPropInfo^.PropType^);
  else
    Result := False;
  end;
end;

function RMSetPropValue(aObject: TObject; aPropName: string; aValue: Variant): Boolean;

  function _RangedValue(const AMin, AMax: Int64): Int64;
  begin
    Result := Trunc(aValue);
    if (Result < AMin) or (Result > AMax) then
    begin
      //raise ERangeError.CreateRes(@SRangeError);
    end;
  end;

var
  lPropInfo: PPropInfo;
  lTypeData: PTypeData;
  lDynArray: Pointer;
begin
  Result := False;
  lPropInfo := GetPropInfo(aObject, aPropName);
  if lPropInfo = nil then Exit;

  Result := True;
  lTypeData := GetTypeData(lPropInfo^.PropType^);
  case lPropInfo.PropType^^.Kind of
    tkInteger, tkChar, tkWChar:
      if lTypeData^.MinValue < lTypeData^.MaxValue then
        TypInfo.SetOrdProp(aObject, lPropInfo, _RangedValue(lTypeData^.MinValue,
          lTypeData^.MaxValue))
      else
        TypInfo.SetOrdProp(aObject, lPropInfo,
          _RangedValue(LongWord(lTypeData^.MinValue),
          LongWord(lTypeData^.MaxValue)));
    tkEnumeration:
      if VarType(aValue) = varString then
        TypInfo.SetEnumProp(aObject, lPropInfo, VarToStr(aValue))
      else if VarType(aValue) = varBoolean then
        TypInfo.SetOrdProp(aObject, lPropInfo, Abs(Trunc(aValue)))
      else
        TypInfo.SetOrdProp(aObject, lPropInfo, _RangedValue(lTypeData^.MinValue,
          lTypeData^.MaxValue));
    tkSet:
      if VarType(aValue) = varInteger then
        TypInfo.SetOrdProp(aObject, lPropInfo, aValue)
      else
        TypInfo.SetSetProp(aObject, lPropInfo, VarToStr(aValue));
    tkFloat: