Smart App Server

Smart Application Server Struction 2005-07-01,edit by Arreck. AppMd.exe is an AppServer means Application Server. This AppServer is a useful smart componet, it can create privider that client need to call at runtime. You need not to create static privider at design time. Following content demostray how to use and call from interface. AppMd.exe include two remote datamodules: NT3Rdm1--use for system database accessing. NT3Rdm2--use for user data database accessing. ========================================================================= NT3Rdm1: ----------------------------------------------------------------- INTERFACE:INT3Rdm1 ------------------------------------------------------------ Method:rspLogIn function rspLogIn(const CLT_IP, KEYWORD: WideString; var LOG_ID: OleVariant): OleVariant; Parameters: CLT_IP--Client host IP adress. KEYWORD--the Client transfer the KEYWORD must equal to AppMd's KEYWORD, default value is '2222'. LOG_ID--return from AppMd,Client must use this LOG_ID to CALL INT3Rdm2.rsfBeReady, INT3Rdm2.rsfBeReady is use for initial use database connection. If LOG_ID is incorrect,you can not call other method of INT3Rdm2. Return Value: 'Y'--Login is Sucessed. 'N'--Login is Failed. 'E'+??+':'+Error Message--Login is Failed,some error is ocur. ========================================================================= NT3Rdm2: ----------------------------------------------------------------- INTERFACE:INT3Rdm2 ------------------------------------------------------------ Method:rsfBeReady function rsfBeReady(const CLT_IP, KEYWORD, LOG_ID, TARDBNM: WideString): OleVariant; Funtional:rsfBeReady is use for initial user database connection. Parameters: CLT_IP--Client host IP adress. KEYWORD--the Client transfer the KEYWORD must equal to AppMd's KEYWORD, default value is '2222'. LOG_ID--that is the value return from INT3Rdm1.rspLogIn, If LOG_ID is incorrect,you can not call this method. TARDBNM--witch database you need to read write to,pass the target database name here. Return Value: 'Y'--Login is Sucessed,the target database is connect open. 'N'--Login is Failed. 'E'+??+':'+Error Message--Login is Failed,some error is ocur. ------------------------------------------------------------ Method:rsfGetData function rsfGetData(xSQL: OleVariant): OleVariant; ------------------------------------------------------------ Method:rsfGetLookupData procedure rsfGetLookupData(const DBName, GetTable: WideString; var KeyFields, KeyVals, ValFields: OleVariant; out ValList, ValStatus: OleVariant); ------------------------------------------------------------ Method:rsfRegPrivider function rsfRegPrivider(const DBNAME, DSNAME, KEYFLDS, MDIFLDS, PVNAME: WideString): OleVariant; ------------------------------------------------------------ Method:rsfRegPrvdrMD function rsfRegPrvdrMD(const DBName, DSNAME, KEYFLDS, MDIFLDS, PVNAME, RLMFLD, RLSFLD, SDNAME, SKEYFS, SMDIFS: WideString): OleVariant; ------------------------------------------------------------ Method:rsfDLLFunCall function rsfDLLFunCall(const DBName, DLLModulName, DLLFunName:WideString; const INParams:OleVariant;var IOParams:OleVariant): OleVariant; *********************************************************************** TDLLFun=Function (CurDbCnn:TADOConnection;const DBName:WideString; const INParams:OleVariant;var IOParams:OleVariant): OleVariant;StdCall; *********************************************************************** ========================================================================= Client Demos in dehphi 6 source. ------------------------------------------------------------------------- //Caller.Exe: /// program Caller; uses ShareMem,Forms, FCallerU in 'FCallerU.pas' {FCaller}, DmBasU in '../Y_BAS/DmBasU.pas' {DmBas: TDataModule}; {$R *.res} begin Application.Initialize; Application.CreateForm(TFCaller, FCaller); Application.Run; end. /// //DmBasU.DFM object DmBas: TDmBas OldCreateOrder = False Left = 326 Top = 196 Height = 150 Width = 215 object SC2: TSocketConnection ServerGUID = '{1A7E46CD-CACD-4263-9B83-A497212B69FE}' ServerName = 'AppMd.NT3rdm2' Address = '127.0.0.1' Left = 48 Top = 8 end object CDST: TClientDataSet Aggregates = <> PacketRecords = 10 Params = <> RemoteServer = SC2 BeforeApplyUpdates = CDSTBeforeApplyUpdates Left = 104 Top = 8 end object DS_CDST: TDataSource DataSet = CDST Left = 160 Top = 8 end object SC1: TSocketConnection ServerGUID = '{7B223352-6088-4A7B-99A1-613A6F544EC7}' ServerName = 'AppMd.NT3rdm1' Address = '127.0.0.1' Left = 8 Top = 8 end end /// // unit DmBasU; interface uses SysUtils, Classes,Variants, DB, DBClient, MConnect, SConnect , StdCtrls; type TDmBas = class(TDataModule) SC2: TSocketConnection; CDST: TClientDataSet; DS_CDST: TDataSource; SC1: TSocketConnection; procedure CDSTBeforeApplyUpdates(Sender: TObject; var OwnerData: OleVariant); private { Private declarations } protected public gC_Corp:String; gC_CpDB:String; gC_DBRQ:String; gC_User:String; gC_Pswd:String; gS_APIP:String; gStrKW,gStrLogID:String; FDebug:Boolean; FMem:TMemo; tBeDBCnnOK:Boolean; { Public declarations } procedure pConnectDB;virtual; function fInitAppRdm:Boolean;virtual; function fRdyCnnDB(Const xStrDBN:String):Boolean;virtual; function fRegPrivider(const DBNAME, DSNAME, KEYFLDS, MDIFLDS, PVNAME: WideString): String; function fRegPrvdrMD(const DBName, DSNAME, KEYFLDS, MDIFLDS, PVNAME, RLMFLD, RLSFLD, SDNAME, SKEYFS, SMDIFS: WideString): String; procedure pGetNextPacket(xCDset:TClientDataset); end; var DmBas: TDmBas; implementation {$R *.dfm} { TDmBas } procedure TDmBas.pConnectDB; begin if (gStrLogID='') then if not fInitAppRdm then Exit; tBeDBCnnOK:=fRdyCnnDB('DEMO'); end; function TDmBas.fInitAppRdm; var aStrX:String; aVLOG_ID,aVRslt: OleVariant; aID:IDispatch; begin result:=False; if not SC1.Connected then begin SC1.Address:=gS_APIP; if FDebug then if FMem<>nil then begin FMem.Lines.Add('App_IP:'+SC1.Address); end; end; aVRslt:=SC1.GetServer; if VarIsNull(aVRslt) or (VarIsEmpty(aVRslt)) then begin if FDebug then if FMem<>nil then begin FMem.Lines.Add('GetServer Fail.'); end; Exit; end else begin try aID:=aVRslt; aStrX:='OK'; except aStrX:='NO'; end; if FDebug then if FMem<>nil then begin FMem.Lines.Add('GetServer:'+aStrX); end; end; gStrKW:='1111'; aVLOG_ID:=''; aStrX:=''; if SC1.Connected then begin if FDebug then if FMem<>nil then begin FMem.Lines.Add('Ap_LogIn:'+gStrKW); end; aVRslt:=SC1.AppServer.rspLogIn(gS_APIP,gStrKW,aVLOG_ID); aStrX:=aVRslt; end else begin if FDebug then if FMem<>nil then begin FMem.Lines.Add('SC1.Connected=False'); end; end; if aStrX='Y' then begin gStrLogID:=aVLOG_ID; //SC1.Connected:=True; Result:=True; end else begin end; if FDebug then if FMem<>nil then begin if aStrX='Y' then FMem.Lines.Add('App_LogID:'+aVLOG_ID) else FMem.Lines.Add('App_LogInFail:'+aStrX); end; end; function TDmBas.fRdyCnnDB(const xStrDBN: String): Boolean; var aRSIsReady:OleVariant; //aIRslt:Integer; begin Result:=False; //aIRslt:=0; if not SC2.Connected then begin SC2.GetServer; if not SC2.Connected then SC2.Connected:=True; end; aRSIsReady:=SC2.AppServer.rsfBeReady(gS_APIP,gStrKW,gStrLogID,xStrDBN); if not VarIsNull(aRSIsReady) then if aRSIsReady='Y' then begin Result:=True; end; end; function TDmBas.fRegPrivider(const DBNAME, DSNAME, KEYFLDS, MDIFLDS, PVNAME: WideString):String; var aRslt:OleVariant; begin Result:=''; if not SC2.Connected then Exit; aRslt:=SC2.AppServer.rsfRegPrivider(DBNAME,DSNAME,KEYFLDS,MDIFLDS,PVNAME); if not VarIsNull(aRslt) then begin Result:=aRslt; end; end; function TDmBas.fRegPrvdrMD(const DBName, DSNAME, KEYFLDS, MDIFLDS, PVNAME, RLMFLD, RLSFLD, SDNAME, SKEYFS, SMDIFS: WideString): String; var aRslt:OleVariant; begin Result:=''; if not SC2.Connected then Exit; aRslt:=SC2.AppServer.rsfRegPrvdrMD(DBName, DSNAME, KEYFLDS, MDIFLDS, PVNAME, RLMFLD, RLSFLD, SDNAME, SKEYFS, SMDIFS); if not VarIsNull(aRslt) then begin Result:=aRslt; end; end; procedure TDmBas.CDSTBeforeApplyUpdates(Sender: TObject; var OwnerData: OleVariant); var aIFx,aIFc:Integer; aStrOD,aStrFNm:String; begin if Sender is TClientDataSet then with TClientDataSet(Sender) do begin aStrOD:=''; aIFc:=FieldCount; if StoreDefs and (Tag>=400) then begin for aIFx:=0 to aIFC-1 do begin if Fields[aIFx].FieldKind=fkData then begin if (pfInUpdate in Fields[aIFx].ProviderFlags) then begin aStrFNm:=Fields[aIFx].FieldName; aStrOD:=aStrOD+aStrFNm+','; end; end; end; end else if (Tag>=400) then begin for aIFx:=0 to aIFC-1 do begin //Fields[aIFx].Tag // 0000 0000 // |||| |||+-[pfHidden] 1 // |||| ||+--[pfInKey] 2 // |||| |+---[pfInWhere] 4 // |||| +----[pfInUpdate] 8 if Fields[aIFx].FieldKind=fkData then if Fields[aIFx].Tag >=8 then begin aStrFNm:=Fields[aIFx].FieldName; aStrOD:=aStrOD+aStrFNm+','; end; end; end; if aStrOD>'' then OwnerData:=aStrOD; end; end; procedure TDmBas.pGetNextPacket(xCDset: TClientDataset); var aIRecNo:Integer; aBeOldFOD:Boolean; begin if not xCDset.Active then Exit; aBeOldFOD:=xCDset.FetchOnDemand; try xCDset.FetchOnDemand :=False; aIRecNo:=xCDset.RecordCount; if xCDset.RecNo=aIRecNo then begin xCDset.GetNextPacket; xCDset.Next; end else begin xCDset.RecNo :=aIRecNo-1; xCDset.Next; end; finally xCDset.FetchOnDemand :=aBeOldFOD; end; end; end. // / //FCallerU.DFM object FCaller: TFCaller Left = 308 Top = 178 Width = 353 Height = 271 Caption = 'FCaller' Color = clBtnFace Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -11 Font.Name = 'MS Sans Serif' Font.Style = [] OldCreateOrder = False OnCloseQuery = FormCloseQuery OnShow = FormShow PixelsPerInch = 96 TextHeight = 13 object Button1: TButton Left = 16 Top = 8 Width = 75 Height = 25 Caption = 'Call' TabOrder = 0 OnClick = Button1Click end object Edit1: TEdit Left = 104 Top = 8 Width = 49 Height = 21 TabOrder = 1 Text = 'INVI02' end object CheckBox1: TCheckBox Left = 160 Top = 8 Width = 49 Height = 17 Caption = '2Th' TabOrder = 2 end end / // unit FCallerU; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls,DLLInfu,DmBasU; type TFCaller = class(TForm) Button1: TButton; Edit1: TEdit; CheckBox1: TCheckBox; procedure Button1Click(Sender: TObject); procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean); procedure FormShow(Sender: TObject); private { Private declarations } public { Public declarations } end; var FCaller: TFCaller; //function GetControler(Const vAppHandle:HWND;vCallBackFun:TCallBackFun;vParams:OleVariant):Integer;StdCall; implementation {$R *.dfm} //function GetControler;external '../C_PKG/POSI02C.DLL' name 'GetControler'; procedure TFCaller.Button1Click(Sender: TObject); var lPass: Boolean; vFunchar, pClientPath: string; lParams: OleVariant; lLibHandle: THandle; lCallBackFun: TCallBackFun; //Pointer; lGetControlerProc: TGetControlerProc; lJobName,vFunName: string; lFmHandle: HWND; aICnt:Integer; begin vFunchar:=Trim(Edit1.Text); pClientPath:='..'; lPass := True; lLibHandle:=0; lFmHandle := 0; if lPass then begin lJobName := vFunchar; vFunName := pClientPath + '/CDLL/' + lJobName + 'C.DLL'; aICnt:=0;//Application.Handle; if not CheckBox1.Checked then begin lFmHandle := GetDLLFmHandle(lJobName); if lFmHandle <> 0 then begin ShowWindow(lFmHandle, SW_NORMAL); BringWindowToTop(lFmHandle); Exit; end; end else begin aICnt:=GetDLLFmCnt(lJobName);; end; lParams := VarArrayCreate([0, 15], varVariant); lParams[0] := pClientPath; //め狠隔畖 lParams[1] := '127.0.0.1';//pComputerName; //App璸衡诀嘿 lParams[2] := 'arreck';//pComputerNameC; //セ诀嘿 lParams[3] := 'DEMO';//pCompanyName; //そ嘿 lParams[4] := 'CORP1';//pCompanyNo; //そ腹 lParams[5] := 'CORP1DB';//pDataBaseName; //Data计沮畐 lParams[6] := 211;//pServerPort; //狠腹 lParams[7] := 'ERPSYS';//pSysBaseName; //Sys计沮畐 lParams[8] := '00000';//pUsr_Group; //舱 lParams[9] := 'Y';//pUsr_IsSuper; //琌禬ノめ lParams[10] := 'sa';//pUsr_Name; //ノめ lParams[11] := 'sa';//pUsr_No; //ノめ腹 lParams[12] := true;// lParams[13] := '2'; //Language select lParams[14] := '*'; // lParams[15] := '*'; // lCallBackFun := @fDLLControl; if lFmHandle =0 then begin if fileExists(vFunName) then lLibHandle := LoadLibrary(PChar(vFunName)); end else begin lLibHandle:=GetDllLibHandle(vFunName); end; if (lLibHandle <> 0 )then begin @lGetControlerProc := GetProcAddress(lLibHandle, 'GetControler'); if not (@lGetControlerProc = nil) then begin aICnt:=aICnt+1; lFmHandle := lGetControlerProc(aICnt, lCallBackFun,DmBas,lParams); end; //lFmHandle := GetControler(Application.Handle, lCallBackFun, lParams); if lFmHandle <> 0 then begin AddDLLHandle(lLibHandle, lFmHandle, lJobName); end else begin end; end else begin lLibHandle:=GetLastError; showmessage(IntToStr(lLibHandle)); end; end; end; procedure TFCaller.FormCloseQuery(Sender: TObject; var CanClose: Boolean); begin ProcessCheckDLLHandles; if uHasWkLib then begin CanClose:=False; ShowMessage('You have UnClose Job Forms.'); end; end; procedure TFCaller.FormShow(Sender: TObject); begin if not Assigned(DmBas) then DmBas:=TDmBas.Create(Application); DmBas.gS_APIP :='127.0.0.1'; DmBas.fInitAppRdm; DmBas.pConnectDB; end; end. // //INVI02C.DLL: /// library INVI02C; uses ShareMem,SysUtils, Classes, Windows, Forms, DLLInfU,FBasU,FBas0U,DmBasU, FTst1U in '../TstC/FTst1U.pas' {FTst1}; {$R *.res} function GetControler(Const vAppHandle:HWND;vCallBackFun:TCallBackFun;xDm:TDmBas;vParams:OleVariant):Integer;StdCall;//SafeCall;// var aDllFrm:TFBas; begin try aDllFrm:=TFTst1.Create(nil); aDllFrm.Name:='FTst1_'+IntToStr(aDllFrm.Handle); aDllFrm.Caption:='[INVI02]-'+IntToStr(vAppHandle); aDllFrm.pCallBackFun :=vCallBackFun; if xDm<>nil then TFBas0(aDllFrm).DmBas0:=xDm;//TDmBas(xDm); aDllFrm.Show; result:=aDllFrm.Handle; except result:=0; end; end; exports GetControler; begin end. /// //FTst1U.DFM inherited FTst1: TFTst1 Left = 204 Top = 101 Width = 583 Height = 468 Caption = 'FTst1' PixelsPerInch = 96 TextHeight = 13 object PgCtrl0: TPageControl Left = 0 Top = 0 Width = 575 Height = 441 ActivePage = TbSht01 Align = alClient TabIndex = 0 TabOrder = 0 object TbSht01: TTabSheet Caption = 'SingleTable' object Panel1: TPanel Left = 0 Top = 0 Width = 567 Height = 81 Align = alTop TabOrder = 0 object Button1: TButton Left = 256 Top = 3 Width = 41 Height = 25 Caption = '&Q?' TabOrder = 0 OnClick = Button1Click end object Edit1: TEdit Left = 299 Top = 4 Width = 46 Height = 21 TabOrder = 1 Text = 'INVMB' end object Edit2: TEdit Left = 344 Top = 4 Width = 129 Height = 21 TabOrder = 2 Text = 'MB001' end object DBNavigator1: TDBNavigator Left = 12 Top = 4 Width = 240 Height = 25 DataSource = DSM TabOrder = 3 end object Edit3: TEdit Left = 14 Top = 34 Width = 403 Height = 21 TabOrder = 4 Text = 'SELECT * FROM INVMB WHERE (MB001<''A'') ORDER BY MB001' end object Button2: TButton Left = 424 Top = 32 Width = 51 Height = 25 Caption = 'Save' TabOrder = 5 OnClick = Button2Click end object CheckBox1: TCheckBox Left = 15 Top = 58 Width = 186 Height = 17 Caption = 'FetchOnDemand PacketRecords' Checked = True State = cbChecked TabOrder = 6 end object EdtPK: TEdit Left = 200 Top = 56 Width = 33 Height = 21 TabOrder = 7 Text = '-1' end object Button3: TButton Left = 248 Top = 56 Width = 57 Height = 25 Caption = 'Add N' TabOrder = 8 Visible = False OnClick = Button3Click end end object PageControl1: TPageControl Left = 0 Top = 81 Width = 567 Height = 332 ActivePage = TabSheet1 Align = alClient TabIndex = 0 TabOrder = 1 object TabSheet1: TTabSheet Caption = 'TabSheet1' object DBGrid1: TDBGrid Left = 0 Top = 0 Width = 559 Height = 304 Align = alClient DataSource = DSM TabOrder = 0 TitleFont.Charset = DEFAULT_CHARSET TitleFont.Color = clWindowText TitleFont.Height = -11 TitleFont.Name = 'MS Sans Serif' TitleFont.Style = [] end end object TabSheet2: TTabSheet Caption = 'TabSheet2' ImageIndex = 1 end end end object TbSht02: TTabSheet Caption = 'MaserDetail' ImageIndex = 1 object Panel2: TPanel Left = 0 Top = 0 Width = 567 Height = 201 Align = alTop TabOrder = 0 object Button4: TButton Left = 256 Top = 3 Width = 41 Height = 25 Caption = '&Q?' TabOrder = 0 OnClick = Button4Click end object Edit4: TEdit Left = 299 Top = 4 Width = 46 Height = 21 TabOrder = 1 Text = 'COPTC' end object Edit5: TEdit Left = 344 Top = 4 Width = 129 Height = 21 TabOrder = 2 Text = 'TC001,TC002' end object DBNavigator2: TDBNavigator Left = 12 Top = 4 Width = 240 Height = 25 DataSource = DSM1 TabOrder = 3 end object Edit6: TEdit Left = 14 Top = 34 Width = 459 Height = 21 TabOrder = 4 Text = 'SELECT * FROM COPTC WHERE (1=1) ORDER BY TC001,TC002' end object Button5: TButton Left = 246 Top = 56 Width = 51 Height = 23 Caption = 'Save' TabOrder = 5 OnClick = Button5Click end object CheckBox2: TCheckBox Left = 15 Top = 58 Width = 186 Height = 17 Caption = 'FetchOnDemand PacketRecords' Checked = True State = cbChecked TabOrder = 6 end object EdtPK2: TEdit Left = 200 Top = 56 Width = 33 Height = 21 TabOrder = 7 Text = '-1' end object DBGrid2: TDBGrid Left = 1 Top = 80 Width = 565 Height = 120 Align = alBottom DataSource = DSM1 TabOrder = 8 TitleFont.Charset = DEFAULT_CHARSET TitleFont.Color = clWindowText TitleFont.Height = -11 TitleFont.Name = 'MS Sans Serif' TitleFont.Style = [] end end object Panel3: TPanel Left = 0 Top = 201 Width = 567 Height = 212 Align = alClient Caption = 'Panel3' TabOrder = 1 object Panel4: TPanel Left = 1 Top = 1 Width = 565 Height = 32 Align = alTop Caption = 'Panel4' TabOrder = 0 object Edit8: TEdit Left = 255 Top = 4 Width = 46 Height = 21 TabOrder = 0 Text = 'COPTD' end object Edit9: TEdit Left = 298 Top = 4 Width = 173 Height = 21 TabOrder = 1 Text = 'TD001,TD002,TD003' end object DBNavigator3: TDBNavigator Left = 4 Top = 3 Width = 240 Height = 25 DataSource = DSD1 TabOrder = 2 end end object DBGrid3: TDBGrid Left = 1 Top = 33 Width = 565 Height = 178 Align = alClient DataSource = DSD1 TabOrder = 1 TitleFont.Charset = DEFAULT_CHARSET TitleFont.Color = clWindowText TitleFont.Height = -11 TitleFont.Name = 'MS Sans Serif' TitleFont.Style = [] end end end object TbSht03: TTabSheet Caption = 'MutiTables' ImageIndex = 5 end object TbSht04: TTabSheet Caption = 'OpenData' ImageIndex = 2 end object TbSht05: TTabSheet Caption = 'LookUp' ImageIndex = 3 end object TbSht06: TTabSheet Caption = 'Message' ImageIndex = 4 object Memo1: TMemo Left = 0 Top = 0 Width = 567 Height = 413 Align = alClient Lines.Strings = ( 'Memo1') ScrollBars = ssVertical TabOrder = 0 end end end object CDSM: TClientDataSet Aggregates = <> CommandText = 'SELECT * FROM INVMB WHERE (MB001<''4'') ORDER BY MB001' PacketRecords = 10 Params = <> Left = 336 Top = 65528 end object DSM: TDataSource DataSet = CDSM Left = 296 Top = 65528 end object CDSM1: TClientDataSet Aggregates = <> CommandText = 'SELECT * FROM COPTC WHERE (1=1) ORDER BY TC001,TC002' PacketRecords = 10 Params = <> ProviderName = 'PCoptc' Left = 392 Top = 65528 end object CDSD1: TClientDataSet Aggregates = <> PacketRecords = 10 Params = <> Left = 448 Top = 65528 end object DSM1: TDataSource DataSet = CDSM1 Left = 408 Top = 65528 end object DSD1: TDataSource DataSet = CDSD1 Left = 464 end object Timer1: TTimer Interval = 1100 OnTimer = Timer1Timer Left = 488 Top = 72 end end unit FTst1U; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, FBas0U, ExtCtrls, DBCtrls, Grids, DBGrids ,DmBasU, StdCtrls, ComCtrls, DB, DBClient, MConnect, SConnect; type TFTst1 = class(TFBas0) PageControl1: TPageControl; TabSheet1: TTabSheet; TabSheet2: TTabSheet; Panel1: TPanel; Button1: TButton; Edit1: TEdit; Edit2: TEdit; DBGrid1: TDBGrid; DBNavigator1: TDBNavigator; Edit3: TEdit; CDSM: TClientDataSet; DSM: TDataSource; Button2: TButton; CheckBox1: TCheckBox; EdtPK: TEdit; Button3: TButton; PgCtrl0: TPageControl; TbSht01: TTabSheet; TbSht02: TTabSheet; TbSht04: TTabSheet; TbSht05: TTabSheet; Panel2: TPanel; Button4: TButton; Edit4: TEdit; Edit5: TEdit; DBNavigator2: TDBNavigator; Edit6: TEdit; Button5: TButton; CheckBox2: TCheckBox; EdtPK2: TEdit; TbSht06: TTabSheet; Memo1: TMemo; CDSM1: TClientDataSet; CDSD1: TClientDataSet; DBGrid2: TDBGrid; TbSht03: TTabSheet; Panel3: TPanel; Panel4: TPanel; Edit8: TEdit; Edit9: TEdit; DBNavigator3: TDBNavigator; DBGrid3: TDBGrid; DSM1: TDataSource; DSD1: TDataSource; Timer1: TTimer; procedure Button1Click(Sender: TObject); procedure FormCreate(Sender: TObject); procedure FormShow(Sender: TObject); procedure Button2Click(Sender: TObject); procedure Button3Click(Sender: TObject); procedure CDSMBeforeApplyUpdates(Sender: TObject; var OwnerData: OleVariant); procedure CDSMAfterGetRecords(Sender: TObject; var OwnerData: OleVariant); procedure CDSMBeforeGetRecords(Sender: TObject; var OwnerData: OleVariant); procedure Button4Click(Sender: TObject); procedure Button5Click(Sender: TObject); procedure Timer1Timer(Sender: TObject); procedure FormClose(Sender: TObject; var Action: TCloseAction); private { Private declarations } KeyFldsVals1,keyFieldsValues: Variant; protected procedure pCreatDm;override; public { Public declarations } end; procedure BeforeApplyUpdates(Sender: TObject; var OwnerData: OleVariant; var keyFieldsValues: Variant); var FTst1: TFTst1; implementation {$R *.dfm} procedure TFTst1.Button1Click(Sender: TObject); var aStrX,aStrPrvdr,aStrTBN,aStrKyFlds,aStrSQL:String; aT1,aT2,aTd:TTime; begin inherited; aT1:=Time; aStrX:=FormatDateTime('hh:nn:ss.zzz',aT1); Memo1.Lines.add('Begin:'+aStrX); CDSM.Close; aStrTBN:=Edit1.Text; aStrKyFlds:=Edit2.Text; aStrPrvdr:=Trim(CDSM.ProviderName); if aStrPrvdr='' then begin aStrPrvdr:=DmBas0.fRegPrivider('',aStrTBN,aStrKyFlds,'*',''); memo1.Lines.Add('Prvdr:'+aStrPrvdr); end; if CDSM.RemoteServer<>DmBas0.SC2 then //if CDSM.RemoteServer =nil then begin CDSM.RemoteServer:=DmBas0.SC2; end; if aStrPrvdr>'' then begin try aStrSQL:=Edit3.Text; CDSM.Close; CDSM.FetchOnDemand:=CheckBox1.Checked; CDSM.PacketRecords:=StrToInt(EdtPK.Text); CDSM.ProviderName:=aStrPrvdr; CDSM.CommandText:=aStrSQL; CDSM.Open; aStrX:=IntToStr(CDSM.RecordCount); Memo1.Lines.add('Recount:'+aStrX); except on E:Exception do begin ShowMessage(E.Message); end; end; end; aT2:=Time; aStrX:=FormatDateTime('hh:nn:ss.zzz',aT1); Memo1.Lines.add('E n d:'+aStrX); aTd:=aT2-aT1; aStrX:=FormatDateTime('hh:nn:ss.zzz',aTd); Memo1.Lines.add('Tatol:'+aStrX); end; procedure TFTst1.FormCreate(Sender: TObject); begin Self.gMem:=Memo1; Self.gDebug:=True; inherited FormCreate(Sender); end; procedure TFTst1.pCreatDm; begin //inherited; if not Assigned(DmBas0) then DmBas0:=TDmBas.Create(Self); DmBas0.gC_Corp:=Self.gC_Corp; DmBas0.gC_CpDB:=Self.gC_CpDB; DmBas0.gC_DBRQ:=Self.gC_DBRQ; DmBas0.gC_User:=Self.gC_User; DmBas0.gC_Pswd:=Self.gC_Pswd; if gS_APIP='' then gS_APIP:='127.0.0.1'; DmBas0.gS_APIP:=Self.gS_APIP; DmBas0.fInitAppRdm; end; procedure TFTst1.FormShow(Sender: TObject); begin inherited; if Assigned(DmBas0) then begin if not DmBas0.tBeDBCnnOK then begin Memo1.lines.Add('not cnn yet.'); DmBas0.pConnectDB; end; //DBGrid1.DataSource:=DmBas0.DS_CDST; //DBNavigator1.DataSource:=DmBas0.DS_CDST; end; end; procedure TFTst1.Button2Click(Sender: TObject); begin inherited; CDSM.ApplyUpdates(-1); end; procedure TFTst1.Button3Click(Sender: TObject); var aIc,aIx,aIdx:Integer; aStrPNo:String; begin if not CDSM.Active then Exit; aIc:=CDSM.RecordCount; CDSM.DisableControls; for aIdx:=1 to 2200 do begin aIx:=aIc+aIdx; CDSM.Append; aStrPNo:='0000'+IntToStr(aIx); aStrPNo:='P'+Copy(aStrPNo,Length(aStrPNo)-4,5); CDSM.FieldValues['MB001']:=aStrPNo; CDSM.FieldValues['MB002']:=aStrPNo+'N'; CDSM.FieldValues['CREATE_DATE']:=FormatDateTime('YYYYMMDD',Date); CDSM.Post; if (aIdx mod 100) =0 then begin CDSM.ApplyUpdates(0); Application.ProcessMessages; end; end; CDSM.ApplyUpdates(0); while CDSM.ControlsDisabled do CDSM.EnableControls; end; procedure BeforeApplyUpdates(Sender: TObject; var OwnerData: OleVariant; var keyFieldsValues: Variant); begin if TClientDataSet(Sender).Active then begin if VarIsEmpty(keyFieldsValues) then begin keyFieldsValues := VarArrayCreate([0,1],varVariant); keyFieldsValues[0] := TClientDataSet(Sender).CommandText; OwnerData := keyFieldsValues; end else begin keyFieldsValues[0] := TClientDataSet(Sender).CommandText; OwnerData := keyFieldsValues; end; end; end; procedure TFTst1.CDSMBeforeApplyUpdates(Sender: TObject; var OwnerData: OleVariant); begin //BeforeApplyUpdates(Sender,OwnerData,KeyFldsVals1); if TClientDataSet(Sender).Active then begin if VarIsEmpty(keyFieldsValues) then begin keyFieldsValues := VarArrayCreate([0,1],varVariant); keyFieldsValues[0] := TClientDataSet(Sender).CommandText; OwnerData := keyFieldsValues; Memo1.Lines.Add('VarIsEmpty(keyFieldsValues)'); Memo1.Lines.Add('keyFieldsValues[0]='+keyFieldsValues[0]); end else begin keyFieldsValues[0] := TClientDataSet(Sender).CommandText; OwnerData := keyFieldsValues; Memo1.Lines.Add('not VarIsEmpty(keyFieldsValues)'); Memo1.Lines.Add('keyFieldsValues[0]='+keyFieldsValues[0]); end; end; end; procedure TFTst1.CDSMAfterGetRecords(Sender: TObject; var OwnerData: OleVariant); begin //inherited; if not VarIsEmpty(OwnerData) then begin keyFieldsValues := OwnerData; TClientDataSet(Sender).Tag:=0; Memo1.Lines.Add('AfterGetRecords:'+keyFieldsValues[0]); end else begin TClientDataSet(Sender).tag:=1; keyFieldsValues := Unassigned; Memo1.Lines.Add('AfterGetRecords:Unassigned'); end; end; procedure TFTst1.CDSMBeforeGetRecords(Sender: TObject; var OwnerData: OleVariant); begin //inherited; if TClientDataSet(Sender).Active then begin if not VarIsEmpty(keyFieldsValues) then begin keyFieldsValues[0] := TClientDataSet(Sender).CommandText; OwnerData := keyFieldsValues; Memo1.Lines.Add('BeforeGetRecords:'+keyFieldsValues[0]); end else begin Memo1.Lines.Add('BeforeGetRecords:Abort'); Abort; end; end; end; procedure TFTst1.Button4Click(Sender: TObject); var aStrX,aStrPrvdr,aStrTBN,aStrKyFlds,aStrSQL:String; aT1,aT2,aTd:TTime; aStrTbnD,aStrKyFldsD:String; aICnt:Integer; begin inherited; aT1:=Time; aStrX:=FormatDateTime('hh:nn:ss.zzz',aT1); Memo1.Lines.add('Begin:'+aStrX); CDSM1.Close; aStrTBN:=Edit4.Text; aStrKyFlds:=Edit5.Text; aStrTbnD:=Edit8.Text; aStrKyFldsD:=Edit9.Text; aStrPrvdr:=Trim(CDSM1.ProviderName); //if CDSM1.ProviderName <> aStrPrvdr then begin //rsfRegPrvdrMD(const DBName, DSNAME, KEYFLDS, MDIFLDS, // PVNAME, RLMFLD, RLSFLD, SDNAME, SKEYFS, SMDIFS: WideString): OleVariant; aStrPrvdr:=DmBas0.fRegPrvdrMD('',aStrTBN,aStrKyFlds,'*','' ,aStrKyFlds,'TD001,TD002',aStrTbnD,aStrKyFldsD,'*'); memo1.Lines.Add('Prvdr:'+aStrPrvdr); end; if CDSM1.RemoteServer<>DmBas0.SC2 then //if CDSM1.RemoteServer =nil then begin CDSM1.RemoteServer:=DmBas0.SC2; end; if aStrPrvdr>'' then begin try aStrSQL:=Edit6.Text; CDSM1.Close; CDSM1.FetchOnDemand:=CheckBox2.Checked; CDSM1.PacketRecords:=StrToInt(EdtPK2.Text); CDSM1.ProviderName:=aStrPrvdr; CDSM1.CommandText:=aStrSQL; CDSM1.Open; aStrX:=IntToStr(CDSM1.RecordCount); Memo1.Lines.add('Recount:'+aStrX); if CDSM1.Active then begin CDSD1.Close; aICnt:=CDSM1.FieldCount; if CDSM1.Fields[aICnt-1] is TDatasetField then begin CDSD1.DataSetField:=TDatasetField(CDSM1.Fields[aICnt-1]); CDSM1.Fields[aICnt-1].Visible:=False; //CDSD1.Active :=True; end; end; except on E:Exception do begin ShowMessage(E.Message); end; end; end; aT2:=Time; aStrX:=FormatDateTime('hh:nn:ss.zzz',aT1); Memo1.Lines.add('E n d:'+aStrX); aTd:=aT2-aT1; aStrX:=FormatDateTime('hh:nn:ss.zzz',aTd); Memo1.Lines.add('Tatol:'+aStrX); end; procedure TFTst1.Button5Click(Sender: TObject); begin inherited; CDSM1.ApplyUpdates(-1); end; procedure TFTst1.Timer1Timer(Sender: TObject); begin //inherited; if CDSM.Active then Button1.Click; if CDSM.Active then begin CDSM.First; CDSM.Edit; CDSM.FieldValues['MODI_DATE']:=FormatDateTime('hh:nn:ss',Time); CDSM.ApplyUpdates(-1); end; if CDSM1.Active then Button4.Click; if CDSM1.Active then begin CDSM1.First; CDSM1.Edit; CDSM1.FieldValues['MODI_DATE']:=FormatDateTime('hh:nn:ss',Time); CDSM1.ApplyUpdates(-1); end; end; procedure TFTst1.FormClose(Sender: TObject; var Action: TCloseAction); begin inherited; CDSM.Close; CDSM1.Close; end; end.