fastscript增加三方控件之二

unit fs_BsDataSet;

interface

{$i fs.inc}

uses
SysUtils, Classes, fs_iinterpreter, fs_itools, fs_ievents,
DB,Bs_DataSet,fs_iclassesrtti,System.Variants;

type
TBsDBRTTI = class(TBsDataSet); // fake component

TBsDatasetNotifyEvent = class(TfsCustomEvent)
public
procedure DoEvent(Dataset: TBsDataSet);
function GetMethod: Pointer; override;
end;

TBsDataSetErrorEvent = class(TfsCustomEvent)
public
procedure DoEvent(DataSet: TDataSet; E: EDatabaseError;var Action: TDataAction);
function GetMethod: Pointer; override;
end;

TBsFilterRecordEvent = class(TfsCustomEvent)
public
procedure DoEvent(DataSet: TBsDataSet; var Accept: Boolean);
function GetMethod: Pointer; override;
end;

TBsFieldGetTextEvent = class(TfsCustomEvent)
public
procedure DoEvent(Sender: TField; var Text: String; DisplayText: Boolean);
function GetMethod: Pointer; override;
end;

type
TBsFunctions = class(TfsRTTIModule)
private
function CallMethod(Instance: TObject; ClassType: TClass;
const MethodName: String; Caller: TfsMethodHelper): Variant;
function GetProp(Instance: TObject; ClassType: TClass;
const PropName: String): Variant;
procedure SetProp(Instance: TObject; ClassType: TClass;
const PropName: String; Value: Variant);
public
constructor Create(AScript: TfsScript); override;
end;
VAR BsFunctions:TBsFunctions;
implementation

type
TByteSet = set of 0..7;
PByteSet = ^TByteSet;

{ TfsDatasetNotifyEvent }

procedure TBsDatasetNotifyEvent.DoEvent(Dataset: TBsDataSet);
begin
CallHandler([Dataset]);
end;

function TBsDatasetNotifyEvent.GetMethod: Pointer;
begin
Result := @TBsDatasetNotifyEvent.DoEvent;
end;

procedure TBsDataSetErrorEvent.DoEvent(DataSet: TDataSet; E: EDatabaseError;var Action: TDataAction);
begin
CallHandler([Dataset,@E,@Action]);
Action := Handler.Params[2].Value;
end;

function TBsDataSetErrorEvent.GetMethod: Pointer;
begin
Result := @TBsDataSetErrorEvent.DoEvent;
end;

{ TfsFilterRecordEvent }

procedure TBsFilterRecordEvent.DoEvent(DataSet: TBsDataSet; var Accept: Boolean);
begin
CallHandler([DataSet, Accept]);
Accept := Handler.Params[1].Value;
end;

function TBsFilterRecordEvent.GetMethod: Pointer;
begin
Result := @TBsFilterRecordEvent.DoEvent;
end;

{ TfsFieldGetTextEvent }

procedure TBsFieldGetTextEvent.DoEvent(Sender: TField; var Text: String; DisplayText: Boolean);
begin
CallHandler([Sender, Text, DisplayText]);
Text := Handler.Params[1].Value;
end;

function TBsFieldGetTextEvent.GetMethod: Pointer;
begin
Result := @TBsFieldGetTextEvent.DoEvent;
end;

{ TFunctions }

constructor TBsFunctions.Create(AScript: TfsScript);
begin
inherited Create(AScript);
with AScript do
begin
AddEnum('TDataAction','daFail, daAbort, daRetry');
AddEnumSet('TIndexOptions', 'ixPrimary, ixUnique, ixDescending, ixCaseInsensitive,ixExpression, ixNonMaintained');
with AddClass(Exception,'TObject') do
begin

end;
with AddClass(EDatabaseError,'Exception') do
begin

end;
with AddClass(TIndexDefs,'TCollection') do
begin
AddMethod('procedure Add(const Name,Fields:string;Options: TIndexOptions)',CallMethod);
end;
with AddClass(TBsDataSet, 'TDataSet') do
begin
AddMethod('procedure OpenData', CallMethod);
AddMethod('procedure OpenList', CallMethod);
AddMethod('procedure OpenPackList', CallMethod);
AddMethod('procedure OpenListUP', CallMethod);
AddMethod('procedure OpenListDown', CallMethod);
AddMethod('procedure SaveData', CallMethod);

AddMethod('procedure Open', CallMethod);
AddMethod('procedure Close', CallMethod);
AddMethod('procedure First', CallMethod);
AddMethod('procedure Last', CallMethod);
AddMethod('procedure Next', CallMethod);
AddMethod('procedure Prior', CallMethod);
AddMethod('procedure Cancel', CallMethod);
AddMethod('procedure Delete', CallMethod);
AddMethod('procedure Post', CallMethod);
AddMethod('procedure Append', CallMethod);
AddMethod('procedure Insert', CallMethod);
AddMethod('procedure Edit', CallMethod);
AddConstructor('constructor Create(AOwner: TComponent)',CallMethod);

AddMethod('function FieldByName(const FieldName: string): TField', CallMethod);
AddMethod('procedure GetFieldNames(List: TStrings)', CallMethod);
AddMethod('function FindFirst: Boolean', CallMethod);
AddMethod('function FindLast: Boolean', CallMethod);
AddMethod('function FindNext: Boolean', CallMethod);
AddMethod('function FindPrior: Boolean', CallMethod);
AddMethod('procedure FreeBookmark(Bookmark: TBookmark)', CallMethod);
AddMethod('function GetBookmark: TBookmark', CallMethod);
AddMethod('procedure GotoBookmark(Bookmark: TBookmark)', CallMethod);
AddMethod('function Locate(const KeyFields: string; const KeyValues: Variant;' +
'Options: TLocateOptions): Boolean', CallMethod);
AddMethod('function IsEmpty: Boolean', CallMethod);
AddMethod('procedure EnableControls', CallMethod);
AddMethod('procedure DisableControls', CallMethod);
AddMethod('procedure AddIndex(const Name, Fields: string;Options: TIndexOptions)',CallMethod);

AddProperty('Bof', 'Boolean', GetProp, nil);
AddProperty('Eof', 'Boolean', GetProp, nil);
AddProperty('FieldCount', 'Integer', GetProp, nil);
AddProperty('FieldDefs', 'TFieldDefs', GetProp, nil);
AddProperty('Fields', 'TFields', GetProp, nil);
AddProperty('Filter', 'string', GetProp, SetProp);
AddProperty('Filtered', 'Boolean', GetProp, SetProp);
AddProperty('FilterOptions', 'TFilterOptions', GetProp, SetProp);
AddProperty('Active', 'Boolean', GetProp, SetProp);
AddProperty('Data','OleVariant',GetProp,SetProp);
AddProperty('Params','TParams',GetProp,NIL);
AddProperty('IndexDefs','TIndexDefs',GetProp,nil);
AddProperty('FilterCode','string',GetProp,SetProp);
AddProperty('FilterLineListText','string',GetProp,SetProp);
AddProperty('FilterLineSQL','string',GetProp,SetProp);
AddProperty('FbMustFilter','Boolean',GetProp,SetProp);
AddProperty('FbPost','Boolean',GetProp,SetProp);
AddProperty('FbMultTable','Boolean',GetProp,SetProp);
AddProperty('RecordCount','Integer',GetProp,nil);
AddProperty('QFDataSetOpenSQL','string',GetProp,SetProp);

AddEvent('BeforeOpen', TBsDatasetNotifyEvent);
AddEvent('AfterOpen', TBsDatasetNotifyEvent);
AddEvent('BeforeClose', TBsDatasetNotifyEvent);
AddEvent('AfterClose', TBsDatasetNotifyEvent);
AddEvent('BeforeInsert', TBsDatasetNotifyEvent);
AddEvent('AfterInsert', TBsDatasetNotifyEvent);
AddEvent('BeforeEdit', TBsDatasetNotifyEvent);
AddEvent('AfterEdit', TBsDatasetNotifyEvent);
AddEvent('BeforePost', TBsDatasetNotifyEvent);
AddEvent('AfterPost', TBsDatasetNotifyEvent);
AddEvent('BeforeCancel', TBsDatasetNotifyEvent);
AddEvent('AfterCancel', TBsDatasetNotifyEvent);
AddEvent('BeforeDelete', TBsDatasetNotifyEvent);
AddEvent('AfterDelete', TBsDatasetNotifyEvent);
AddEvent('BeforeScroll', TBsDatasetNotifyEvent);
AddEvent('AfterScroll', TBsDatasetNotifyEvent);
AddEvent('OnCalcFields', TBsDatasetNotifyEvent);
AddEvent('OnFilterRecord', TBsFilterRecordEvent);
AddEvent('OnNewRecord', TBsDatasetNotifyEvent);
AddEvent('OnPostError', TBsDataSetErrorEvent);
end;
end;
end;

function TBsFunctions.CallMethod(Instance: TObject; ClassType: TClass;
const MethodName: String; Caller: TfsMethodHelper): Variant;
var
_TDataSet: TBsDataSet;
_TIndexDefs:TIndexDefs;

function IntToLocateOptions(i: Integer): TLocateOptions;
begin
Result := [];
if (i and 1) <> 0 then
Result := Result + [loCaseInsensitive];
if (i and 2) <> 0 then
Result := Result + [loPartialKey];
end;

function IntToIndexOptions(i: Integer): TIndexOptions;
begin
Result := [];
if (i = 1) then
Result := Result + [ixPrimary];
if (i = 2) then
Result := Result + [ixUnique];
if (i = 3) then
Result := Result + [ixDescending];
if (i = 4) then
Result := Result + [ixCaseInsensitive];
if (i = 5) then
Result := Result + [ixExpression];
if (i = 6) then
Result := Result + [ixNonMaintained];
end;
procedure IndexDefsAdd(QName, QFields: string;QArgs:Variant);
var ar:TIndexOptions;
i,n:Integer;
begin
n := VarArrayHighBound(QArgs, 1) + 1;
for i := 0 to n - 1 do
begin
ar :=ar+ IntToIndexOptions(QArgs[i]);
end;
_TIndexDefs.Add(QName,QFields,ar);
end;

procedure BsAddIndex(QName, QFields: string;QArgs:Variant);
var ar:TIndexOptions;
i,n:Integer;
begin
n := VarArrayHighBound(QArgs, 1) + 1;
for i := 0 to n - 1 do
begin
ar :=ar+ IntToIndexOptions(QArgs[i]);
end;
_TDataSet.AddIndex(QName,QFields,ar);
end;

begin
Result := 0;
if ClassType = TBsDataSet then
begin
_TDataSet := TBsDataSet(Instance);
if MethodName='OPENDATA' then
_TDataSet.OpenData
ELSE
if MethodName='OPENLIST' then
_TDataSet.OpenList
ELSE
if MethodName='OPENPACKLIST' then
_TDataSet.OpenPackList
ELSE
if MethodName='OPENLISTUP' then
_TDataSet.OpenListUP
ELSE
if MethodName='OPENLISTDOWN' then
_TDataSet.OpenListDown
ELSE
if MethodName='SAVEDATA' then
_TDataSet.SaveData
ELSE
if MethodName = 'OPEN' then
_TDataSet.Open
else if MethodName = 'CLOSE' then
_TDataSet.Close
else if MethodName = 'FIRST' then
_TDataSet.First
else if MethodName = 'LAST' then
_TDataSet.Last
else if MethodName = 'NEXT' then
_TDataSet.Next
else if MethodName = 'PRIOR' then
_TDataSet.Prior
else if MethodName = 'CANCEL' then
_TDataSet.Cancel
else if MethodName = 'DELETE' then
_TDataSet.Delete
else if MethodName = 'POST' then
_TDataSet.Post
else if MethodName = 'APPEND' then
_TDataSet.Append
else if MethodName = 'INSERT' then
_TDataSet.Insert
else if MethodName = 'EDIT' then
_TDataSet.Edit
else if MethodName = 'FIELDBYNAME' then
Result := frxInteger(_TDataSet.FieldByName(Caller.Params[0]))
else if MethodName = 'GETFIELDNAMES' then
_TDataSet.GetFieldNames(TStrings(frxInteger(Caller.Params[0])))
else if MethodName = 'FINDFIRST' then
Result := _TDataSet.FindFirst
else if MethodName = 'FINDLAST' then
Result := _TDataSet.FindLast
else if MethodName = 'FINDNEXT' then
Result := _TDataSet.FindNext
else if MethodName = 'FINDPRIOR' then
Result := _TDataSet.FindPrior
else if MethodName = 'FREEBOOKMARK' then
_TDataSet.FreeBookmark(TBookMark(frxInteger(Caller.Params[0])))
{$IFNDEF WIN64}
else if MethodName = 'GETBOOKMARK' then
Result := frxInteger(_TDataSet.GetBookmark)
{$ENDIF}
else if MethodName = 'GOTOBOOKMARK' then
_TDataSet.GotoBookmark(TBookMark(frxInteger(Caller.Params[0])))
else if MethodName = 'LOCATE' then
Result := _TDataSet.Locate(Caller.Params[0], Caller.Params[1], IntToLocateOptions(Caller.Params[2]))
else if MethodName = 'ISEMPTY' then
Result := _TDataSet.IsEmpty
else if MethodName = 'ENABLECONTROLS' then
_TDataSet.EnableControls
else if MethodName = 'DISABLECONTROLS' then
_TDataSet.DisableControls
else if MethodName='CREATE' then
Result := frxInteger(TComponent(Instance).Create(TComponent(frxInteger(Caller.Params[0]))))
else if MethodName='ADDINDEX' then
BsAddIndex(Caller.Params[0], Caller.Params[1],Caller.Params[2])
end
else
if ClassType = TIndexDefs then
begin
_TIndexDefs := TIndexDefs(Instance);
if MethodName='ADD' then
IndexDefsAdd(Caller.Params[0],Caller.Params[1],Caller.Params[2])
end;
end;

function TBsFunctions.GetProp(Instance: TObject; ClassType: TClass;
const PropName: String): Variant;
var
_TField: TField;
_TParam: TParam;
_TDataSet: TBsDataSet;
_TIndexDefs:TIndexDefs;

function FilterOptionsToInt(f: TFilterOptions): Integer;
begin
Result := 0;
if foCaseInsensitive in f then
Result := Result or 1;
if foNoPartialCompare in f then
Result := Result or 2;
end;

begin
Result := 0;
if ClassType = TBsDataSet then
begin
_TDataSet := TBsDataSet(Instance);
if PropName = 'BOF' then
Result := _TDataSet.Bof
else if PropName = 'EOF' then
Result := _TDataSet.Eof
else if PropName = 'FIELDCOUNT' then
Result := _TDataSet.FieldCount
else if PropName = 'FIELDDEFS' then
Result := frxInteger(_TDataSet.FieldDefs)
else if PropName = 'FIELDS' then
Result := frxInteger(_TDataSet.Fields)
else if PropName = 'FILTER' then
Result := _TDataSet.Filter
else if PropName = 'FILTERED' then
Result := _TDataSet.Filtered
else if PropName = 'FILTEROPTIONS' then
Result := FilterOptionsToInt(_TDataSet.FilterOptions)
else if PropName = 'ACTIVE' then
Result := _TDataSet.Active
else if PropName = 'DATA' then
Result := _TDataSet.Data
else if PropName = 'PARAMS' then
Result := frxInteger(_TDataSet.Params)
else if PropName = 'INDEXDEFS' then
Result := frxInteger(_TDataSet.IndexDefs)
else if PropName = 'FILTERCODE' then
Result := _TDataSet.FilterCode
else if PropName = uppercase('FilterLineListText') then
Result := _TDataSet.FilterLineListText
else if PropName = uppercase('FilterLineSQL') then
Result := _TDataSet.FilterLineSQL
else if PropName = 'FBMUSTFILTER' then
Result := _TDataSet.FbMustFilter
else if PropName = 'FBPOST' then
Result := _TDataSet.FbPost
else if PropName = 'FBMULTTABLE' then
Result := _TDataSet.FbMultTable
else if PropName = 'RECORDCOUNT' then
Result := _TDataSet.RecordCount
else if PropName = 'QFDATASETOPENSQL' then
Result := _TDataSet.QFDataSetOpenSQL;
end
end;

procedure TBsFunctions.SetProp(Instance: TObject; ClassType: TClass;
const PropName: String; Value: Variant);
var
_TField: TField;
_TParam: TParam;
_TDataSet: TBsDataSet;

function IntToFilterOptions(i: Integer): TFilterOptions;
begin
Result := [];
if (i and 1) <> 0 then
Result := Result + [foCaseInsensitive];
if (i and 2) <> 0 then
Result := Result + [foNoPartialCompare];
end;

begin
if ClassType = TBsDataSet then
begin
_TDataSet := TBsDataSet(Instance);
if PropName = 'FILTER' then
_TDataSet.Filter := Value
else if PropName = 'FILTERED' then
_TDataSet.Filtered := Value
else if PropName = 'FILTEROPTIONS' then
_TDataSet.FilterOptions := IntToFilterOptions(Value)
else if PropName = 'ACTIVE' then
_TDataSet.Active := Value
ELSE if PropName = 'DATA' then
_TDataSet.Data := Value
else if PropName = 'FILTERCODE' then
_TDataSet.FilterCode := Value
else if PropName = uppercase('FilterLineListText') then
_TDataSet.FilterLineListText := Value
else if PropName = uppercase('FilterLineSQL') then
_TDataSet.FilterLineSQL := Value
else if PropName = 'FBMUSTFILTER' then
_TDataSet.FbMustFilter := Value
else if PropName = 'FBPOST' then
_TDataSet.Fbpost := Value
else if PropName = 'FBMULTTABLE' then
_TDataSet.FbMultTable := Value
else if PropName = 'QFDATASETOPENSQL' then
_TDataSet.QFDataSetOpenSQL := Value;

end
end;

initialization

finalization

end.

fastscript增加三方控件之二的更多相关文章

  1. fastscript增加三方控件

    fastscript增加三方控件 A.关于如何使用第三方控件,增加方法.属性.事件)举例如下: 如:有一控件为edtbutton:TedtButton,我们需要在动态脚本中使用该控件.我们采用如下方法 ...

  2. 五种情况下会刷新控件状态(刷新所有子FWinControls的显示)——从DFM读取数据时、新增加子控件时、重新创建当前控件的句柄时、设置父控件时、显示状态被改变时

    五种情况下会刷新控件状态(刷新控件状态才能刷新所有子FWinControls的显示): 在TWinControls.PaintControls中,对所有FWinControls只是重绘了边框,而没有整 ...

  3. Delphi编程之好用的三方控件

    Delphi的强大与其庞大的组件库息息相关,目前的XE10.1版本已自带FastReport和GDI+等,下面我们来看一下几个非常强大且实用的组件库 一.DevExpress套件 Dev包含Grid. ...

  4. 对百度WebUploader开源上传控件的二次封装,精简前端代码(两句代码搞定上传)

    前言 首先声明一下,我这个是对WebUploader开源上传控件的二次封装,底层还是WebUploader实现的,只是为了更简洁的使用他而已. 下面先介绍一下WebUploader 简介: WebUp ...

  5. PropertyGrid控件由浅入深(二):基础用法

    目录 PropertyGrid控件由浅入深(一):文章大纲 PropertyGrid控件由浅入深(二):基础用法 控件的外观构成 控件的外观构成如下图所示: PropertyGrid控件包含以下几个要 ...

  6. Delphi以及三方控件的源代码规模

    这些项目大多数使用C++或者C编写,使用SourceCounter-3.5.33.73工具来统计源代码数量,本来是这里下载的: https://code.google.com/p/boomworks/ ...

  7. Xamarin XAML语言教程构建ControlTemplate控件模板 (二)

    Xamarin XAML语言教程构建ControlTemplate控件模板 (二) (2)打开MainPage.xaml文件,编写代码,将构建的控件模板应用于ContentView中.代码如下: &l ...

  8. iOS 简单易用的二维码扫描及生成二维码三方控件LFQRCode,可灵活自定义UI

    一.扫码 扫描的控件是一个view,使用者只需贴在自己的控制器内即可.其他UI用户可在自己控制器随便添加.代码如下 - (void)viewDidLoad { [super viewDidLoad]; ...

  9. Android support library支持包常用控件介绍(二)

    谷歌官方推出Material Design 设计理念已经有段时间了,为支持更方便的实现 Material Design设计效果,官方给出了Android support design library ...

随机推荐

  1. HDU 5237 Base64 模拟

    题意: 输入一个明文串,输出\(k\)次\(Base64\)加密以后得到的串. 分析: 好像没什么Trick,直接模拟就行了. 注意:长度为\(3k+1\)的串,后面会有两个\(=\).长度为\(3k ...

  2. JAVA-基础(五) 更多工具集

    1.StringTokenizer(字符串标记) StringTokenizer实现枚举(Enumeration)接口.因此,给定一个输 入字符串,可以使用StringTokenizer对包含于其中的 ...

  3. luogu3383 【模板】线性筛素数

    如果prime[i]是k的因子,那么[k * (在prime[i]以后的质数)]等于[prime[i]*(k/prime[i])*(这个质数)],一定被筛过了,所以这里可以break. #includ ...

  4. Selenium WebDriver-操作键盘事件

    # 注意: !!!操作操作系统的按键,需要先装pywin32,然后通过交互模式import win32api和import win32con判断是否安装成功,需要重启下cmd进入交互模式# 下载链接: ...

  5. [uiautomator篇][python调用java][1]应用下载的插件需要很长时间问题解决

    1第一次打开应用,可能会要求下载插件,我们先在/sdcard/Android/data/<packageName>  或者/data/data/<pakeageName>找到插 ...

  6. Code Jam 2017 Round 1A Problem B. Ratatouille

    传送门 分析 首先把包(package)的克数 $Q_{ij}$ 转化成区间 $[\lceil Q_{ij}/(1.1 r_i )\rceil, \lfloor Q_{ij}/(0.9 r_i)\rf ...

  7. 周赛Problem 1021: 分蛋糕(埃拉托斯特尼筛法)

    Problem 1021: 分蛋糕 Time Limits:  1000 MS   Memory Limits:  65536 KB 64-bit interger IO format:  %lld  ...

  8. 网抓(XML Http Request、VBA)实现

    第一种,先看VBA Public Function GetInfo(strMoblie As String) As String '创建对象 Dim xmlHttp As Object Set xml ...

  9. java面试题之happens before原则

    JSR-133使用happens-before的概念来指定两个操作之间的执行顺序.由于这两个操作可以在一个线程内,也可以在不同线程之间.因此,JMM可以通过happens-before关系向程序员提供 ...

  10. poj Pseudoprime numbers 3641

    Pseudoprime numbers Time Limit: 1000MS   Memory Limit: 65536K Total Submissions: 10903   Accepted: 4 ...