V
vinson_zeng
Unregistered / Unconfirmed
GUEST, unregistred user!
{******************************************************************************************}
{ }
{ Universal Agent on demond SDK }
{ }
{ }
{ COPYRIGHT }
{ ========= }
{ The UA SDK (software) is Copyright (C) 2001-2003, by vinson zeng(曾胡龙). }
{ All rights reserved. }
{ The authors - vinson zeng (曾胡龙), }
{ exclusively own all copyrights to the Advanced Application }
{ Controls (AppControls) and all other products distributed by Utilmind Solutions(R). }
{ }
{ LIABILITY DISCLAIMER }
{ ==================== }
{ THIS SOFTWARE IS DISTRIBUTED "AS IS" AND WITHOUT WARRANTIES AS TO PERFORMANCE }
{ OF MERCHANTABILITY OR ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. }
{ YOU USE IT AT YOUR OWN RISK. THE AUTHOR WILL NOT BE LIABLE FOR DATA LOSS, }
{ DAMAGES, LOSS OF PROFITS OR ANY OTHER KIND OF LOSS WHILE USING OR MISUSING THIS SOFTWARE.}
{ }
{ RESTRICTIONS }
{ ============ }
{ You may not attempt to reverse compile, modify, }
{ translate or disassemble the software in whole or in part. }
{ You may not remove or modify any copyright notice or the method by which }
{ it may be invoked. }
{******************************************************************************************}
unit UAClientDataSet;
interface
uses
Windows, Variants, ActiveX, Classes,
Dialogs,DBClient,DB,SysUtils,DSIntf,Forms,
Controls,UADataPacket,UAServiceClient;
{$I UaSdk.inc}
type
TRemoteServiceEvent = procedure (Sender:TObject;var CustomData:OleVariant) of Object;
TUpdateErrorEvent = procedure (Sender:TObject;ErrorCode:integer;
var bContinue:Boolean) of Object;
TUAOption = (uoAutoRequestNext,uoAutoUpdate,uoAutoCatchError,uoAutoMergeAll);
TUAOptions = set of TUAOption;
TOperateOption = (ooRequest,ooRequestNext,ooRequestCustom,ooUpdate,ooUpdateCustom,ooRefreshAllData,
ooRefreshSelected,ooQueryData);
TOperateOptions= set of TOperateOption;
TDataSetType = (dtSingle,dtMaster,dtDetail,dtBoth,dtNone);
// add define for multi table process by vinson zeng
CharSet = set of Char;
TUAClientDataSet = class;
TUAFieldsDesigner = class(TPersistent)
private
FOwnerDataSet:TUAClientDataSet;
function GetOwnerDataSet: TUAClientDataSet;
procedure SetOwnerDataSet(const Value: TUAClientDataSet);
protected
public
constructor Create;
published
property OwnerDataSet:TUAClientDataSet read GetOwnerDataSet write SetOwnerDataSet;
end;
TUAClientDataSet = class(TClientDataSet)
private
FAllRecCount:Integer;
FUAServiceClient:TUAServiceClient;
FMasterUAServiceClient:TUAServiceClient;
// add by vinson zeng
FAliasTableName:string;
FKeyFields:string;
FFetchNextDataPacket:Boolean;
FCanUpdate:Boolean;
FBeforeRequest:TNotifyEvent;
FAfterRequest:TRemoteServiceEvent;
FBeforeUpdate:TNotifyEvent;
FAfterUpadte:TNotifyEvent;
FUAOptions:TUAOptions;
FOperateOptions:TOperateOptions;
FUpdateErrorEvent:TUpdateErrorEvent;
FSqlScript:string;
FOpenAllData:Boolean;
FFieldsDesigner:TUAFieldsDesigner;
FDataInfo:string;
FConfirmNotFound:Boolean;
FRelaCheck:Boolean;
FDataSetType:TDataSetType;
FUAAutoRequestNext:Boolean;
FDesignActive:Boolean;
function GetUAServiceClient: TUAServiceClient;
procedure SetUAServiceClient(const Value: TUAServiceClient);
function GetAllRecCount: Integer;
procedure SetAllRecCount(const Value: Integer);
function GetAliasTableName: string;
procedure SetAliasTableName(const Value: string);
function GetFetchNextDataPacket: Boolean;
procedure SetFetchNextDataPacket(const Value: Boolean);
function GetKeyFields: string;
procedure SetKeyFields(const Value: string);
function GetCanUpdate: Boolean;
procedure SetUAOptions(const Value: TUAOptions);
procedure SetSqlScript(const Value: string);
procedure SetOpenAllData(const Value: Boolean);
function GetDataInfo: string;
// add by vinson zeng 2004-01-05
function GetConfirmNotFound: Boolean;
procedure SetConfirmNotFound(const Value: Boolean);
//--------%% end of %% -----------------
procedure SetUAAutoRequestNext(const Value: Boolean);
procedure SetDesignActive(const Value: Boolean);
//2004-03-07
protected
FDataSheetList:TUAParams;
FRowSheetList:TUAParams;
FMasterLinkList:TUAParams;
function GetDataSetType:TDataSetType;
procedure CheckNextDataPacket;
virtual;
procedure CheckForUpdate;
//??
function CheckOperateState(const OperateIndex:integer = -1):Boolean;
function GetMasterUAServiceClient:TUAServiceClient;
procedure DeleteDetailRecords(MasterDataSet:TUAClientDataSet);virtual;
//????
procedure do
DesignActive;
//2004-3-26 modify by vinson zeng
function GetMasterLinkScript(Sender:TObject):string;
function BuildRequestDataParam(Sender:TObject):integer;
function BuildDeltaParam(UAClientDataSet:TUAClientDataSet):Boolean;
function BuildRefreshDataScript(Sender:TObject;var sSqlScript:string;const bAll :Boolean = false):Boolean;
procedure AddReturnDataPacket(const vData:OleVariant);
function GetIndexFields(DataSet:TDataSet):string;
// add by vinson zeng for multi table applyupdates process
//----Inherited from TCustomClientDataSet---------
procedure DataEvent(Event: TDataEvent;
Info: Longint);
override;
procedure AddDataPacket(const Data: OleVariant;
HitEOF: Boolean);
override;
procedure CheckDetailRecords;
override;
procedure InternalDelete;
override;
procedure InternalPost;
override;
procedure InternalCancel;
override;
procedure InternalOpen;
override;
procedure InternalInsert;
override;
procedure InternalEdit;
override;
procedure InternalRefresh;
override;
procedure do
OnNewRecord;
override;
procedure Notification(AComponent: TComponent;
Operation: TOperation);override;
//-------%% end of %%---------------------
public
constructor Create(AOwner: TComponent);
override;
destructor Destroy;
override;
procedure Loaded;
override;
procedure RefreshAllData(Sender:TObject;
const bAll :Boolean = false);
procedure MergeAllChangeLog;
///???
procedure CancelSubmitAllDelta;
virtual;///?????
procedure ClearAllData;virtual;
procedure QueryData(Sender:TObject;const ClearData:Boolean = false);
function do
Request(const RequestIndex:Integer= -1):OleVariant;virtual;
procedure do
Update (const UpdateIndex:Integer = -1);virtual;
procedure ClearAllParams;
procedure CloseAutoRequestNext(const bClose:Boolean = true);
property DataInfo:string read GetDataInfo;
property AllRecCount:Integer read GetAllRecCount write SetAllRecCount;
property CanUpdate:Boolean read GetCanUpdate default false;
property FetchNextDataPacket:Boolean read GetFetchNextDataPacket write SetFetchNextDataPacket default false;
property OperateOptions:TOperateOptions read FOperateOptions default[];
property ConfirmNotFound:Boolean read GetConfirmNotFound write SetConfirmNotFound default false;
property DataSetType:TDataSetType read GetDataSetType;
property MasterUAServiceClient:TUAServiceClient read GetMasterUAServiceClient;
// add by vinson zeng
property UAAutoRequestNext:Boolean read FUAAutoRequestNext write SetUAAutoRequestNext;
published
property FieldsDesigner:TUAFieldsDesigner read FFieldsDesigner;
//-----extenal with UA-----------------
property OpenAllData:Boolean read FOpenAllData write SetOpenAllData;
property UAOptions:TUAOptions read FUAOptions write SetUAOptions default [uoAutoRequestNext];
property UAServiceClient:TUAServiceClient read GetUAServiceClient write SetUAServiceClient;
property AliasTableName:string read GetAliasTableName write SetAliasTableName;
property KeyFields:string read GetKeyFields write SetKeyFields;
property BeforeRequest:TNotifyEvent read FBeforeRequest write FBeforeRequest;
property AfterRequest:TRemoteServiceEvent read FAfterRequest write FAfterRequest;
property BeforeUpdate:TNotifyEvent read FBeforeUpdate write FBeforeUpdate;
property AfterUpadte:TNotifyEvent read FAfterUpadte write FAfterUpadte;
property UpdateErrorEvent:TUpdateErrorEvent read FUpdateErrorEvent write FUpdateErrorEvent;
property SqlScript:string read FSqlScript write SetSqlScript;
property DesignActive:Boolean read FDesignActive write SetDesignActive;
//-----------%% end of %%--------------------
end;
const
crUAWait = 5;
SupportFieldTypes = [ftString, ftWideString, ftSmallint, ftInteger, ftAutoInc, ftWord, ftBoolean, ftLargeint, ftFloat, ftCurrency, ftDate, ftTime, ftDateTime, ftBlob, ftMemo];
SNotSupportFieldType = 'Field type is not supported by TUAClientDataSet. '#13 +
'Valid types is String, WideString, Smallint, Integer, Word, Boolean, Largeint, Float, Currency, Date, Time, DateTime, Blob, Memo';
function xStrSplit(str:String;
chars:CharSet;
tsStrs:TStrings;AutoClear: Boolean;
bTrim:Boolean):integer;
implementation
function xStrSplit(str:String;
chars:CharSet;
tsStrs:TStrings;AutoClear: Boolean;
bTrim:Boolean):integer;
var
n, i, k : integer;
s : string;
begin
Result := 0;
if chars=[] then
chars := [',',';'];
if tsStrs=nil then
Exit;
if AutoClear then
tsStrs.Clear;
k := Length(str);
if (k=0) then
Exit;
i := 1;
for n:=1 to kdo
if str[n] in chars then
begin
s := Copy(Str, i, n-i);
if bTrim then
s:=Trim(s);
tsStrs.Add(s);
i := n+1;
Inc(Result);
end;
if i<=k then
begin
s := Copy(Str, i, n-i);
if bTrim then
s:=Trim(s);
tsStrs.Add(s);
Inc(Result);
end;
end;
{ TUAClientDataSet }
procedure TUAClientDataSet.AddDataPacket(const Data: OleVariant;HitEOF: Boolean);
begin
inherited;
end;
{-----------------------------------------------------------------------------
Procedure: TUAClientDataSet.CheckForUpdate
Author: vinson zeng
Date: 05-三月-2003
Arguments: None
Result: None
-----------------------------------------------------------------------------}
procedure TUAClientDataSet.CheckForUpdate;
var
i:integer;
lList:TList;
bCheckDetail:Boolean;
function CheckForUpdateWithDetail(aDetail:TUAClientDataSet):Boolean;
var
j:integer;
lList1:TList;
bSubDetail:Boolean;
begin
bSubDetail := false;
with aDetaildo
begin
CheckBrowseMode;
Result := ChangeCount > 0;
lList1 := TList.Create;
GetDetailDataSets(lList1);
try
for j := 0 to lList1.Count -1do
bSubDetail := CheckForUpdateWithDetail(TUAClientDataSet(lList1.Items[j]));
Result := Result or bSubDetail;
finally
if Assigned(lList1) then
FreeAndNil(lList1);
end;
end;
end;
begin
bCheckDetail := false;
lList := TList.Create;
try
try
case DataSetType of
dtSingle,dtDetail: begin
CheckBrowseMode;
FCanUpdate := ChangeCount > 0;
end;
dtMaster,dtBoth:
begin
CheckBrowseMode;
FCanUpdate := ChangeCount > 0;
GetDetailDataSets(lList);
for i := 0 to lList.Count -1do
bCheckDetail := CheckForUpdateWithDetail(TUAClientDataSet(lList.Items));
FCanUpdate := FCanUpdate or bCheckDetail;
end;
end;
except
FCanUpdate := false;
end;
finally
if Assigned(lList) then
FreeAndNil(lList);
end;
// Assert(FCanUpdate,'check for update is false');
end;
{-----------------------------------------------------------------------------
Procedure: TUAClientDataSet.CheckNextDataPacket
Author: vinson zeng
Date: 05-三月-2003
Arguments: None
Result: None
-----------------------------------------------------------------------------}
procedure TUAClientDataSet.CheckNextDataPacket;
begin
if not UAAutoRequestNext then
Exit;
UpdateCursorPos;
FetchNextDataPacket := (MasterUAServiceClient <> nil) and Eof
and (RecordCount < AllRecCount)
and Active and (not (State in [dsInsert,dsEdit,dsInactive]))
and (ChangeCount = 0);
try
if FetchNextDataPacket and (uoAutoRequestNext in FUAOptions)
and ( (DataSetType = dtMaster) or (DataSetType = dtSingle)) then
begin
Include(FOperateOptions,ooRequestNext);
do
Request(1);
end;
except
//do notdo
anything ,reverse event for catch error!
end;
end;
constructor TUAClientDataSet.Create(AOwner: TComponent);
begin
inherited;
FAllRecCount := 0;
FFetchNextDataPacket := false;
FCanUpdate := false;
FDataSheetList := TUAParams.Create(true);
FRowSheetList:= TUAParams.Create(true);
FMasterLinkList := TUAParams.Create(true);
FFieldsDesigner := TUAFieldsDesigner.Create;
FFieldsDesigner.OwnerDataSet := Self;
Include(FUAOptions,uoAutoRequestNext);
Include(FUAOptions,uoAutoUpdate);
FOperateOptions := [];
FConfirmNotFound := false;
FRelaCheck := true;
FDataSetType := dtNone;
FUAAutoRequestNext := true;
Screen.Cursors[crUAWait] := LoadCursor(HInstance, 'UAWait');
end;
procedure TUAClientDataSet.DataEvent(Event: TDataEvent;
Info: Integer);
begin
{$define chineseinfo}
try
case Event of
deCheckBrowseMode: // add by vinson zeng for bug on delete record not effect
begin
end;
deDataSetScroll:
begin
CheckNextDataPacket;
if Active then
begin
{$ifdef chineseinfo}
FDataInfo := Format('共计 %s 条记录，当前为已打开 %s条中的第 %s 条记录',[IntToStr(AllRecCount),IntToStr(RecordCount),IntToStr(RecNo)]);
{$else
}
FDataInfo := Format('Total RecordCount Is %s , Local RecordCount Is %s Currrent RecNo Is %s ',[IntToStr(AllRecCount),IntToStr(RecordCount),IntToStr(RecNo)]);
{$endif}
end
else
begin
{$ifdef chineseinfo}
FDataInfo := '当前数据集没有激活！';
{$else
}
FDataInfo := 'not current dataset active！';
{$endif}
end;
end;
deParentScroll:
begin
end;
deDataSetChange:
begin
end;
deUpdateState: //2004-3-10 wait bug fix for ?????
begin
end;
end;
inherited;
except
on E:Exceptiondo
begin
Showmessage('Native Error:'+E.Message+#13#10+ 'Event Code Is:'+IntToStr(Ord(Event)));
end;
end;
end;
destructor TUAClientDataSet.Destroy;
begin
FDataSheetList.Free;;
FRowSheetList.Free;
FMasterLinkList.Free;
FFieldsDesigner.Free;
inherited;
end;
function TUAClientDataSet.GetAliasTableName: string;
begin
Result := FAliasTableName;
end;
function TUAClientDataSet.GetAllRecCount: Integer;
begin
Result := FAllRecCount;
end;
function TUAClientDataSet.GetFetchNextDataPacket: Boolean;
begin
Result := FFetchNextDataPacket;
end;
function TUAClientDataSet.GetCanUpdate: Boolean;
begin
Result := FCanUpdate;
end;
function TUAClientDataSet.GetKeyFields: string;
begin
Result := FKeyFields;
end;
function TUAClientDataSet.GetUAServiceClient: TUAServiceClient;
begin
Result := FUAServiceClient;
end;
procedure TUAClientDataSet.InternalDelete;
begin
DeleteDetailRecords(Self);
inherited;
end;
procedure TUAClientDataSet.InternalPost;
begin
inherited;
end;
procedure TUAClientDataSet.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if (Operation = opRemove) and (FUAServiceClient <> nil) and
(AComponent = UAServiceClient) then
UAServiceClient := nil;
end;
procedure TUAClientDataSet.SetAliasTableName(const Value: string);
begin
if Trim(Value) <> '' then
FAliasTableName := Value;
end;
procedure TUAClientDataSet.SetAllRecCount(const Value: Integer);
begin
FAllRecCount := Value;
end;
procedure TUAClientDataSet.SetFetchNextDataPacket(
const Value: Boolean);
begin
FFetchNextDataPacket := Value;
end;
procedure TUAClientDataSet.SetKeyFields(const Value: string);
begin
if Trim(Value) <> '' then
FKeyFields := Value;
end;
procedure TUAClientDataSet.SetUAServiceClient(
const Value: TUAServiceClient);
begin
if Value <> nil then
FUAServiceClient := Value
else
FUAServiceClient := nil;
end;
{-----------------------------------------------------------------------------
Procedure: TUAClientDataSet.DoUpdate
Author: vinson zeng
Date: 05-三月-2003
Arguments: const UpdateIndex: Integer
Result: None
-----------------------------------------------------------------------------}
procedure TUAClientDataSet.DoUpdate(const UpdateIndex: Integer);
var
sErrorCode:string;
bCando:Boolean;
bDoOnError:Boolean;
iError:integer;
iMaxError:integer;
begin
bCando := false;
bDoOnError := true;
iError := 0;
iMaxError := 0;
CheckForUpdate;
Screen.Cursor := crSqlWait;
try
if CanUpdate then
begin
try
if Assigned(FBeforeUpdate) then
FBeforeUpdate(Self);
if BuildDeltaParam(Self) then
begin
iMaxError := MasterUAServiceClient.DoUpdate('SubmitAllDelta',UpdateIndex);
//Normal ServiceName
if UpdateIndex = -1 then
Include(FOperateOptions,ooUpdate);
if UpdateIndex = 1 then
Include(FOperateOptions,ooUpdateCustom);
bCando := true;
end
else
begin
bCando := false;
iError := -7;
//Local Error on Add Delta
end;
if Assigned(FAfterUpadte) then
FAfterUpadte(Self);
except
on E:Exceptiondo
begin
iError := -1;
//Remote Process Error on ApplyUpdates
sErrorCode := '-30002';
if UpdateIndex = -1 then
Exclude(FOperateOptions,ooUpdate);
if UpdateIndex = 1 then
Exclude(FOperateOptions,ooUpdateCustom);
Showmessage('data update error!'+#13+'error code is:'+sErrorCode
+#13#10+'native error information is:'+E.Message);
end;
end;
end;
finally
Screen.Cursor := crDefault;
end;
if bCando and (iError = 0) and (MasterUAServiceClient.UAUpdateDataOutPacket.ResultCode = 0) and (iMaxError = 0) then
begin
if not CheckOperateState(1) then
// iError := -9 // Local Error On MergeData
else
begin
MergeAllChangeLog;
// MessageDlg('执行远程数据更新成功！', mtInformation,[mbOk], 0);
Application.MessageBox('执行远程数据更新成功！',PChar(Application.Title),MB_OK);
end;
end
else
begin
if Assigned(FUpdateErrorEvent) then
FUpdateErrorEvent(Self,iError,bDoOnError);
if bDoOnError then
begin
// if MessageDlg('执行远程数据更新失败，确认继续当前业务数据编辑工作吗？',mtWarning, [mbYes, mbNo], 0) = mrYes then
if Application.MessageBox('执行远程数据更新失败，确认继续当前业务数据编辑工作吗？',PChar(Application.Title),
MB_YESNO) = IDYES then
Exit
else
CancelSubmitAllDelta;
end
else
begin
//do nothing in here
end;
end;
end;
{-----------------------------------------------------------------------------
Procedure: TUAClientDataSet.DoRequest
Author: vinson zeng
Date: 05-三月-2003
Arguments: const RequestIndex: Integer
Result: OleVariant
-----------------------------------------------------------------------------}
function TUAClientDataSet.DoRequest( const RequestIndex: Integer): OleVariant;
var
sErrorCode:string;
iMaxError:integer;
begin
//Normal ServiceName Is : RequestAllData;
iMaxError := 0;
Result := Unassigned;
Screen.Cursor := crSqlWait;
try
try
case RequestIndex of
-1 : //标准数据请求：只记录数据分页键值
begin
if BuildRequestDataParam(Self) <> -1 then
begin
try
iMaxError := MasterUAServiceClient.DoRequest('RequestAllData',-1);
Result := MasterUAServiceClient.UARequestDataOutPacket.UAData;
Include(FOperateOptions,ooRequest);
except
on E:Exceptiondo
begin
Exclude(FOperateOptions,ooRequest);
end;
end;
end;
end;
1: //请求下一个数据包：只记录数据分页键值
begin
if Assigned(FBeforeRequest) then
FBeforeRequest(Self);
if BuildRequestDataParam(Self) <> -1 then
begin
try
iMaxError := MasterUAServiceClient.DoRequest('RequestAllData',1);
Result := MasterUAServiceClient.UARequestDataOutPacket.UAData;
except
on E:Exceptiondo
begin
Exclude(FOperateOptions,ooRequestNext);
end;
end;
end;
end;
0: //用户自定义的数据请求：只记录数据集合所有行数据键值
begin
if ooQueryData In FOperateOptions then
begin
if Assigned(FBeforeRequest) then
FBeforeRequest(Self);
if BuildRequestDataParam(Self) <> -1 then
begin
try
iMaxError := MasterUAServiceClient.DoRequest('QueryData',1);
Result := MasterUAServiceClient.UARequestDataOutPacket.UAData;
except
on E:Exceptiondo
begin
end;
end;
end;
end
else
if (ooRefreshAllData In FOperateOptions) or (ooRefreshSelected in FOperateOptions) then
begin
if Assigned(FBeforeRequest) then
FBeforeRequest(Self);
if BuildRequestDataParam(Self) <> -1 then
begin
try
iMaxError := MasterUAServiceClient.DoRequest('RefreshData',1);
Result := MasterUAServiceClient.UARequestDataOutPacket.UAData;
except
on E:Exceptiondo
begin
end;
end;
end;
end;
end;
else
MessageDlg('can not support service request!', mtWarning,[mbOk], 0)
end;
if Assigned(FAfterRequest) then
FAfterRequest(Self,Result);
if (not VarIsEmpty(Result)) and VarIsArray(Result) and
(VarCompareValue(Result,Unassigned) <> vrEqual) and (iMaxError = 0) then
AddReturnDataPacket(Result);
except
on E:Exceptiondo
begin
sErrorCode := '-30001';
Showmessage('data request error!'+#13+'error code is:'+sErrorCode
+#13#10+'native error information is:'+E.Message);
end;
end;
finally
Screen.Cursor := crDefault;
end;
end;
function TUAClientDataSet.GetDataSetType: TDataSetType;
var
lList:TList;
HaveParent:Boolean;
HaveDetail:Boolean;
begin
if (FDataSetType <> dtNone) then
begin
Result := FDataSetType;
Exit;
end
else
begin
HaveParent := (MasterSource <> nil) and (Trim(MasterFields) <>'');
lList := TList.Create;
try
GetDetailDataSets(lList);
HaveDetail := lList.Count > 0;
finally
if Assigned(lList) then
lList.Free;
end;
if (not HaveParent) and HaveDetail then
FDataSetType := dtMaster;
if HaveParent and (not HaveDetail) then
FDataSetType := dtDetail;
if (not HaveParent) and (not HaveDetail) then
FDataSetType := dtSingle;
if HaveParent and HaveDetail then
FDataSetType := dtBoth;
Result := FDataSetType;
end;
// Assert(FDataSetType = dtNone,'can not get UAClientDataSet DataSetType!');
end;
procedure TUAClientDataSet.ClearAllParams;
begin
FDataSheetList.Clear;
FRowSheetList.Clear;
FMasterLinkList.Clear;
end;
procedure TUAClientDataSet.CheckDetailRecords;
var
i,RecCount:integer;
lList:TList;
aMasterLink:TMasterLinkParam;
aMasterDataSet:TDataSet;
Status: DBResult;
begin
Status := DSCursor.GetRecordCount(RecCount);
aMasterDataSet := MasterSource.DataSet;
if DataSetField <> nil then
begin
end
else
begin
if (RecCount = 0) and
(PacketRecords = 0) and not aMasterDataSet.IsEmpty and
(aMasterDataSet.State <> dsInsert) and (TUAClientDataSet(aMasterDataSet).ChangeCount = 0) then
begin
lList := TList.Create;
FMasterLinkList.Clear;
try
try
aMasterDataSet.GetFieldList(lList,MasterFields);
for i := 0 to lList.Count -1do
begin
aMasterLink := TMasterLinkParam.Create;
with TField(lList.Items)do
begin
aMasterLink.MasterAliasTableName := TUAClientDataSet(aMasterDataSet).AliasTableName;
aMasterLink.MasterField := IndexFields.FieldName;
aMasterLink.DataType := IndexFields.DataType;
if not VarIsNull(Value) then
aMasterLink.MasterFieldValue := Value
else
aMasterLink.MasterFieldValue := Null;
end;
FMasterLinkList.Add(aMasterLink);
end;
do
Request;
if Active then
First;
except
on E:Exceptiondo
begin
Showmessage('internal error at check detail records!'+#13+'Native Msg:'+E.Message);
end;
end;
finally
if Assigned(lList) then
FreeAndNil(lList);
end;
end;
end;
end;
procedure TUAClientDataSet.Loaded;
begin
inherited;
if (csLoading in ComponentState) then
//do otherting
end;
procedure TUAClientDataSet.InternalRefresh;
begin
// inherited;
end;
procedure TUAClientDataSet.SetUAOptions(const Value: TUAOptions);
begin
FUAOptions := Value;
end;
function TUAClientDataSet.CheckOperateState(const OperateIndex: integer):Boolean;
begin
Result := false;
// -1 代表数据请求申请；
// 1 代表数据更新申请；
try
case OperateIndex of
-1 :begin
if ooRequest in FOperateOptions then
begin
Exclude(FOperateOptions,ooRequest);
end;
if ooRequestNext in FOperateOptions then
begin
Exclude(FOperateOptions,ooRequestNext);
end;
if ooRequestCustom in FOperateOptions then
begin
Exclude(FOperateOptions,ooRequestCustom);
end;
end;
1: begin
if ooUpdateCustom in FOperateOptions then
begin
MergeAllChangeLog;
Exclude(FOperateOptions,ooUpdateCustom);
end;
if ooUpdate in FOperateOptions then
begin
MergeAllChangeLog;
Exclude(FOperateOptions,ooUpdate);
end;
end;
else
MessageDlg('can not support this operation!', mtWarning,[mbOk], 0);
end;
Result := true;
except
on E:Exceptiondo
begin
Showmessage('UAClientDataSet internal error,please try again!');
end;
end;
end;
procedure TUAClientDataSet.MergeAllChangeLog;
var
lList:TList;
i:integer;
sErrorCode:string;
begin
lList := TList.Create;
try
try
case GetDataSetType of
dtDetail,dtSingle:
MergeChangeLog;
dtMaster,dtBoth:
begin
MergeChangeLog;
GetDetailDataSets(lList);
for i := 0 to lList.Count -1do
begin
if not (TComponent(lList.Items) is TUAClientDataSet) then
Continue;
TUAClientDataSet(lList.Items).MergeAllChangeLog;
end;
end;
end;
except
on E:Exceptiondo
begin
sErrorCode := '-30007';
Showmessage('merge data error!'+#13+'error code is:'+sErrorCode
+#13#10+'native error information is:'+E.Message);
end;
end;
finally
lList.Free;
end;
end;
procedure TUAClientDataSet.InternalEdit;
begin
inherited;
end;
procedure TUAClientDataSet.InternalInsert;
begin
inherited;
end;
procedure TUAClientDataSet.InternalOpen;
begin
inherited;
end;
{-----------------------------------------------------------------------------
Procedure: TUAClientDataSet.GetMasterUAServiceClient
Author: vinson zeng
Date: 05-三月-2003
Arguments: None
Result: TUAServiceClient
-----------------------------------------------------------------------------}
function TUAClientDataSet.GetMasterUAServiceClient: TUAServiceClient;
var
aMaster:TUAClientDataSet;
DSMaster:TDataSource;
begin
if Assigned(FMasterUAServiceClient) then
begin
Result := FMasterUAServiceClient;
Exit;
end;
case DataSetType of
dtSingle,dtMaster:
if UAServiceClient <> nil then
begin
FMasterUAServiceClient := UAServiceClient;
Result := FMasterUAServiceClient;
end;
dtBoth,dtDetail:
begin
if MasterSource.DataSet is TUAClientDataSet then
begin
// modify by vinson zeng 2004-01-06
aMaster := TUAClientDataSet(MasterSource.DataSet);
//改进算法 vinson zeng
while (FMasterUAServiceClient = nil) and (Assigned(aMaster))do
begin
if aMaster.MasterUAServiceClient <> nil then
begin
FMasterUAServiceClient := aMaster.MasterUAServiceClient;
Result := FMasterUAServiceClient;
end;
if (not Assigned(Result)) and (aMaster.MasterSource <> nil ) then
begin
DSMaster := aMaster.MasterSource;
aMaster := TUAClientDataSet(DSMaster.DataSet);
end
else
aMaster := nil;
end;
end;
end;
end;
end;
{-----------------------------------------------------------------------------
Procedure: TUAClientDataSet.CancelSubmitAllDelta
Author: vinson zeng
Date: 05-三月-2003
Arguments: None
Result: None
-----------------------------------------------------------------------------}
procedure TUAClientDataSet.CancelSubmitAllDelta;
var
lList:TList;
i:integer;
sErrorCode:string;
procedure CancelSubmitDetail(aDetail:TUAClientDataSet);
var
j:integer;
lList1:TList;
begin
with aDetaildo
begin
CancelUpdates;
lList1 := TList.Create;
GetDetailDataSets(lList1);
try
for j := 0 to lList1.Count -1do
CancelSubmitDetail(TUAClientDataSet(lList1.Items[j]));
finally
if Assigned(lList1) then
FreeAndNil(lList1);
end;
end;
end;
begin
lList := TList.Create;
try
try
case GetDataSetType of
dtDetail,dtSingle:
CancelUpdates;
dtMaster,dtBoth:
begin
CancelUpdates;
GetDetailDataSets(lList);
for i := 0 to lList.Count -1do
CancelSubmitDetail(TUAClientDataSet(lList.Items));
end;
end;
except
on E:Exceptiondo
begin
sErrorCode := '-40001';
Showmessage('merge data error!'+#13+'error code is:'+sErrorCode
+#13#10+'native error information is:'+E.Message);
end;
end;
finally
if Assigned(lList) then
FreeAndNil(lList);
end;
end;
{-----------------------------------------------------------------------------
Procedure: TUAClientDataSet.BuildDeltaParam
Author: vinson zeng
Date: 05-三月-2003
Arguments: UAClientDataSet:TUAClientDataSet
Result: Boolean
-----------------------------------------------------------------------------}
function TUAClientDataSet.BuildDeltaParam(UAClientDataSet:TUAClientDataSet):Boolean;
var
aDelta:TDeltaParam;
aDetailDS:TUAClientDataSet;
lList:TList;
i:integer;
function BuildDetailDeltaPacket(UACds:TUAClientDataSet):Boolean;
var
i:integer;
lList1:TList;
aDetailDS1:TUAClientDataSet;
bSubDetail:Boolean;
begin
Result := true;
// bSubDetail := false;
lList1 := TList.Create;
try
try
with UACdsdo
begin
if ChangeCount <> 0 then
//add Detail
begin
aDelta := TDeltaParam.Create;
aDelta.AliasTableName := AliasTableName;
aDelta.KeyFields := KeyFields + GetIndexFields(nil);
aDelta.Delta := Delta;
MasterUAServiceClient.UAUpdateDataInPacket.AddItemDelta(aDelta);
end;
GetDetailDataSets(lList1);
for i := 0 to lList1.Count -1do
begin
aDetailDS1 := TUAClientDataSet(lList1.Items);
case aDetailDS1.DataSetType of
dtDetail:
begin
if aDetailDS1.ChangeCount <> 0 then
begin
aDelta := TDeltaParam.Create;
aDelta.AliasTableName := aDetailDS1.AliasTableName;
aDelta.KeyFields := aDetailDS1.KeyFields + aDetailDS1.GetIndexFields(nil);;
aDelta.Delta := aDetailDS1.Delta;
MasterUAServiceClient.UAUpdateDataInPacket.AddItemDelta(aDelta);
end;
end;
dtBoth:
begin
bSubDetail := BuildDetailDeltaPacket(aDetailDS1);
Result := Result and bSubDetail;
end;
end;
end;
end;
except
on E:Exceptiondo
begin
Result := false;
end;
end;
finally
if Assigned(lList1) then
FreeAndNil(lList1);
end;
end;
begin
// bug : for Master/Detail/SubDetail rela struc stack overflow :Loop error vinson zeng 2003-12-29
// fix : check GetDetailDataSets method
// modify by vinson zeng for Master/Detail Add Delta Seq
Result := true;
if not Assigned(UAClientDataSet) then
begin
Result := false;
Exit;
end;
if MasterUAServiceClient = nil then
begin
Result := false;
Exit;
end;
try
with MasterUAServiceClientdo
begin
// if not FCurrentUpdate then
//fix by vinson zeng for delete affect delta
UAUpdateDataInPacket.ClearAllUaData;
case UAClientDataSet.DataSetType of
dtMaster:
begin
lList := TList.Create;
try
if ChangeCount <> 0 then
//Master Is First Add
begin
aDelta := TDeltaParam.Create;
aDelta.AliasTableName := AliasTableName;
aDelta.KeyFields := KeyFields + GetIndexFields(nil);
aDelta.Delta := Delta;
UAUpdateDataInPacket.AddItemDelta(aDelta);
end;
GetDetailDataSets(lList);
for i := 0 to lList.Count -1do
begin
aDetailDS := TUAClientDataSet(lList.Items);
Result := Result and BuildDetailDeltaPacket(aDetailDS);
// modify by visnon zeng 2004-01-06
end;
finally
if Assigned(lList) then
FreeAndNil(lList);
end;
end;
dtSingle,dtDetail:
begin
if ChangeCount <> 0 then
begin
aDelta := TDeltaParam.Create;
aDelta.AliasTableName := AliasTableName;
aDelta.KeyFields := KeyFields + GetIndexFields(nil);
aDelta.Delta := Delta;
UAUpdateDataInPacket.AddItemDelta(aDelta);
end;
end;
end;
end;
except
Result := false;
end;
end;
procedure TUAClientDataSet.SetSqlScript(const Value: string);
begin
FSqlScript := Value;
end;
{-----------------------------------------------------------------------------
Procedure: TUAClientDataSet.BuildRequestDataParam
Author: vinson zeng
Date: 05-三月-2003
Arguments: Sender: TObject
Result: integer
-----------------------------------------------------------------------------}
function TUAClientDataSet.BuildRequestDataParam(Sender: TObject): integer;
var
aDataRequestParam:TDataRequestParam;
i:integer;
aDataSheetParam:TDataSheetParam;
aMasterLinkParam:TMasterLinkParam;
aRowSheetParam:TRowSheetParam;
begin
with MasterUAServiceClientdo
begin
aDataRequestParam := TDataRequestParam.Create;
try
try
ClearRequestParams;
aDataRequestParam.AliasTableName := AliasTableName;
aDataRequestParam.KeyFields := KeyFields;
aDataRequestParam.RequestRecCount := PacketRecords;
aDataRequestParam.SqlParams := SqlScript;
if Active then
aDataRequestParam.CurrRecCount := RecordCount;
if FMasterLinkList.Count <> 0 then
begin
for i := 0 to FMasterLinkList.Count -1do
begin
aMasterLinkParam := TMasterLinkParam.Create;
aMasterLinkParam.UAData := TMasterLinkParam(FMasterLinkList.Items).UAData;
UARequestDataInPacket.AddItemMasterLink(aMasterLinkParam);
end;
end;
if FRowSheetList.Count <> 0 then
begin
for i := 0 to FRowSheetList.Count -1do
begin
aRowSheetParam := TRowSheetParam.Create;
aRowSheetParam.UAData := TRowSheetParam(FRowSheetList.Items).UAData;
UARequestDataInPacket.AddItemRowSheet(aRowSheetParam);
end;
end;
if (ooRequestNext in FOperateOptions) and (FDataSheetList.Count <> 0) then
begin
for i := 0 to FDataSheetList.Count -1do
begin
aDataSheetParam := TDataSheetParam.Create;
aDataSheetParam.UAData := TDataSheetParam(FDataSheetList.Items).UAData;
UARequestDataInPacket.AddItemDataSheet(aDataSheetParam);
end;
end;
except
Result := -1;
end;
UARequestDataInPacket.AddItemRequestData(aDataRequestParam);
Result := 1;
finally
end;
end;
end;
{-----------------------------------------------------------------------------
Procedure: TUAClientDataSet.AddReturnDataPacket
Author: vinson zeng
Date: 05-三月-2003
Arguments: const vData: OleVariant
Result: None
-----------------------------------------------------------------------------}
procedure TUAClientDataSet.AddReturnDataPacket(const vData: OleVariant);
var
UAReturnPacket:TUARequestDataOutPacket;
rData:OleVariant;
aReturnData:TDataReturnParam;
aDataSheet:TDataSheetParam;
aRowSheet:TRowSheetParam;
i:integer;
aCds:TClientDataSet;
bFindRec,bCanAppend:Boolean;
// sKeys:string;
// vLocateValue:Variant;
iOldRecCount:integer;
iOpenRecCount:integer;
begin
//2004-03-05 bug fix for record cursor point error
iOldRecCount := RecordCount;
//2004-03-05 记录当前记录计数
bFindRec := false;
bCanAppend := false;
if not Assigned(MasterUAServiceClient) then
Exit;
UAReturnPacket := TUARequestDataOutPacket.Create;
try
UAReturnPacket.UAData := MasterUAServiceClient.UARequestDataOutPacket.UAData;
aReturnData := UAReturnPacket.GetItemReturnData(0);
if Assigned(aReturnData) and (not VarIsEmpty(aReturnData.UAData)) and
(VarIsArray(aReturnData.UAData)) and (not (VarCompareValue(aReturnData.UAData,Unassigned) = vrEqual)) then
begin
rData := aReturnData.Data;
AllRecCount := aReturnData.AllRecCount;
iOpenRecCount := aReturnData.CurrRecCount - iOldRecCount;
// 2004-03-05 fix by vinson zeng for location curren record
end;
if UAReturnPacket.CountRowSheet <> 0 then
//duplicate check
begin
for i := 0 to UAReturnPacket.CountRowSheet - 1do
begin
aRowSheet := TRowSheetParam.Create;
aRowSheet.UAData:= UAReturnPacket.GetItemRowSheet(i).UAData;
FRowSheetList.Add(aRowSheet);
end;
end;
if UAReturnPacket.CountDataSheet <> 0 then
begin
if not (ooQueryData in FOperateOptions) then
begin
FDataSheetList.Clear;
for i := 0 to UAReturnPacket.CountDataSheet -1do
begin
aDataSheet := TDataSheetParam.Create;
aDataSheet.UAData := UAReturnPacket.GetItemDataSheet(i).UAData;
FDataSheetList.Add(aDataSheet);
end;
end
else
begin
if FDataSheetList.Count = 1 then
// begin
process
begin
end;
end;
end;
if CheckOperateState(-1) then
begin
if ooQueryData in FOperateOptions then
begin
DisableControls;
//duplicate key value process
CloseAutoRequestNext(true);
aCds := TClientDataSet.Create(nil);
try
aCds.Data := rData;
if not aCds.Active then
aCds.Open;
aCds.First;
try
while not aCds.Eofdo
begin
if Pos(',',KeyFields) <> 0 then
begin
// raise Exception.Create('UA SDK not support data type'!);
//Multi PrimaryKey not Support
//2004-03-05 fix Multi Key Locate
end
else
begin
bFindRec := Self.Locate(KeyFields, aCds.FindField(KeyFields).Value, [loPartialKey]);
end;
if bFindRec then
begin
Self.Delete;
Self.MergeChangeLog;
end
else
aCds.Next;
end;
bCanAppend := true;
except
on E:Exceptiondo
begin
bCanAppend := false;
Showmessage('query data error!'+#13#10+ 'native error information is:'+E.Message);
end;
end;
finally
if bCanAppend then
begin
VarClear(rData);
rData := aCds.Data;
end;
if aCds.RecordCount = 0 then
begin
// modify by vinson zeng on 2004-01-02
if FConfirmNotFound then
// modify by vinson zeng on 2004-01-05
// MessageDlg('系统不存在与查询条件相匹配的记录，请确认！', mtInformation,[mbOk], 0);
Application.MessageBox('系统不存在与查询条件相匹配的记录，请确认！',PChar(Application.Title),MB_OK);
end;
if Assigned(aCds) then
FreeAndNil(aCds);
CloseAutoRequestNext(false);
EnableControls;
end;
end;
if ooRefreshAllData in FOperateOptions then
begin
CloseAutoRequestNext(true);
DisableControls;
try
try
EmptyDataSet;
MergeChangeLog;
except
end;
finally
CloseAutoRequestNext(false);
EnableControls;
end;
end;
if ooRefreshSelected in FOperateOptions then
begin
CloseAutoRequestNext(true);
DisableControls;
try
try
Delete;
MergeChangeLog;
except
end;
finally
CloseAutoRequestNext(false);
EnableControls;
end;
end;
if (not VarIsNull(rData)) and (not VarIsEmpty(rData)) then
begin
// modify by vinson zeng on 2004-01-02
AppendData(rData,false);
MergeChangeLog;
end;
// 2004-03-05 fix by vinson zeng not Sing
DisableControls;
CloseAutoRequestNext(true);
if ooQueryData in FOperateOptions then
MoveBy(iOldRecCount + 1);
// Rec Position OffSet Is 1
if ooRefreshAllData in FOperateOptions then
First;
if ooRefreshSelected in FOperateOptions then
Last;
CloseAutoRequestNext(false);
EnableControls;
end;
finally
if Assigned(UAReturnPacket) then
FreeAndNil(UAReturnPacket);
end;
end;
{-----------------------------------------------------------------------------
Procedure: TUAClientDataSet.RefreshAllData
Author: vinson zeng
Date: 05-三月-2003
Arguments: Sender: TObject;
const bAll :Boolean = false
Result: None
-----------------------------------------------------------------------------}
procedure TUAClientDataSet.RefreshAllData(Sender: TObject;
const bAll :Boolean = false);
var
sTmp:string;
begin
// bug fix by vinson zeng at 2003-11-03
if (RecordCount = 0 ) or (State = dsInactive) then
begin
{$ifdef CHNDEBUG}
// MessageDlg('不能执行此项操作，因为数据集没有激活或者记录为空！', mtWarning,[mbOk], 0);
Application.MessageBox('不能执行此项操作，因为数据集没有激活或者记录为空！',PChar(Application.Title),MB_OK);
{$else
}
MessageDlg('can notdo
operation，bacause not dataset active or dataset is empty!', mtWarning,[mbOk], 0);
{$endif}
Exit;
end;
if bAll then
Include(FOperateOptions,ooRefreshAllData)
else
Include(FOperateOptions,ooRefreshSelected);
try
if BuildRefreshDataScript(Sender,sTmp,bAll) then
begin
if Trim(sTmp) <> '' then
begin
try
SqlScript := '';
SqlScript := sTmp;
do
Request(0);
SqlScript := '';
except
end;
end;
end;
finally
if bAll then
Exclude(FOperateOptions,ooRefreshAllData)
else
Exclude(FOperateOptions,ooRefreshSelected);
end;
end;
procedure TUAClientDataSet.SetOpenAllData(const Value: Boolean);
begin
if ( csDesigning in ComponentState )then
Exit;
FOpenAllData := Value;
if FOpenAllData then
do
Request
else
begin
//do
other thing in here ,maybe close all uaclientdataset
end;
end;
procedure TUAClientDataSet.InternalCancel;
begin
inherited;
end;
procedure TUAClientDataSet.DoOnNewRecord;
begin
inherited;
end;
function TUAClientDataSet.GetDataInfo: string;
begin
Result := FDataInfo;
end;
procedure TUAClientDataSet.CloseAutoRequestNext(const bClose:Boolean = true);
begin
if bClose then
Exclude(FUAOptions,uoAutoRequestNext)
else
Include(FUAOptions,uoAutoRequestNext);
end;
procedure TUAClientDataSet.QueryData(Sender: TObject;const ClearData:Boolean = false);
begin
Include(FOperateOptions,ooQueryData);
try
try
if ClearData then
ClearAllData;
do
Request(0);
except
end;
finally
Exclude(FOperateOptions,ooQueryData);
end;
end;
{-----------------------------------------------------------------------------
Procedure: TUAClientDataSet.BuildRefreshDataScript
Author: vinson zeng
Date: 05-三月-2003
Arguments: Sender: TObject;var sSqlScript:string;const bAll :Boolean = false
Result: Boolean
-----------------------------------------------------------------------------}
function TUAClientDataSet.BuildRefreshDataScript(Sender: TObject;var sSqlScript:string;const bAll :Boolean = false):Boolean;
var
WhereClause,sTmp,s2:string;
lList:TStringList;
i:integer;
lField:TField;
SavePlace: TBookmark;
begin
// Result := false;
DisableControls;
CloseAutoRequestNext(true);
lList := TStringList.Create;
try
try
SavePlace := GetBookmark;
if bAll then
begin
First;
while not Eofdo
begin
if Trim(sSqlScript) <> '' then
sSqlScript := sSqlScript + ' or ';
WhereClause := '';
xStrSplit(KeyFields,[','],lList,true,true);
for i := 0 to lList.Count -1do
begin
sTmp := '';
if Trim(WhereClause) <> '' then
WhereClause := WhereClause + ' and ';
lField := FindField(lList.Strings);
sTmp := ' ('+ lField.FieldName + ' =';
if Assigned(lField) then
begin
if lField.DataType in [ftString, ftWideString] then
sTmp := sTmp + #39 + lField.AsString + #39 + ' )'
else
if lField.DataType in [ftDate,ftDateTime] then
begin
sTmp := sTmp + DateToStr(lField.AsDateTime) +' )';
end
else
sTmp := sTmp + VarToStr(lField.Value) +' )';
end;
if Trim(sTmp) <> '' then
WhereClause := WhereClause + sTmp;
end;
if Trim(WhereClause) <> '' then
begin
s2 := GetMasterLinkScript(Self);
if Trim(s2) <> '' then
WhereClause := ' ('+ WhereClause +' and '+ s2 +' )'
else
WhereClause := ' ('+ WhereClause +' )';
end;
sSqlScript := sSqlScript + WhereClause ;
Next;
end;
end;
if not bAll then
//如果是子表刷新
begin
xStrSplit(KeyFields,[','],lList,true,true);
for i := 0 to lList.Count -1do
begin
sTmp := '';
if Trim(WhereClause) <> '' then
WhereClause := WhereClause + ' and ';
lField := FindField(lList.Strings);
sTmp := ' ('+ lField.FieldName + ' =';
if Assigned(lField) then
begin
if lField.DataType in [ftString, ftWideString] then
sTmp := sTmp + #39 + lField.AsString + #39 + ' )'
else
if lField.DataType in [ftDate,ftDateTime] then
begin
sTmp := sTmp + DateToStr(lField.AsDateTime) +' )';
end
else
sTmp := sTmp + VarToStr(lField.Value) +' )';
end;
if Trim(sTmp) <> '' then
WhereClause := WhereClause + sTmp;
end;
if Trim(WhereClause) <> '' then
begin
s2 := GetMasterLinkScript(Self);
if Trim(s2) <> '' then
WhereClause := ' ('+ WhereClause +' and '+ s2 +' )'
else
WhereClause := ' ('+ WhereClause +' )';
end;
sSqlScript := sSqlScript + WhereClause ;
end;
Result := true;
except
on E:Exceptiondo
begin
Result := false;
end;
end;
finally
if Assigned(lList) then
FreeAndNil(lList);
GotoBookmark(SavePlace);
FreeBookmark(SavePlace);
EnableControls;
CloseAutoRequestNext(false);
end;
end;
{-----------------------------------------------------------------------------
Procedure: TUAClientDataSet.GetMasterLinkScript
Author: vinson zeng
Date: 05-三月-2003
Arguments: Sender: TObject
Result: string
-----------------------------------------------------------------------------}
function TUAClientDataSet.GetMasterLinkScript(Sender: TObject): string;
var
i:integer;
lList:TList;
aMasterDataSet:TDataSet;
MasterClause,s1:string;
begin
if (DataSetType = dtDetail) or (DataSetType = dtBoth) then
begin
aMasterDataSet := MasterSource.DataSet;
if Assigned(aMasterDataSet) then
begin
if DataSetField <> nil then
begin
end
else
begin
lList := TList.Create;
FMasterLinkList.Clear;
try
try
aMasterDataSet.GetFieldList(lList,MasterFields);
for i := 0 to lList.Count -1do
begin
with TField(lList.Items)do
begin
if Trim(MasterClause) <> '' then
MasterClause := MasterClause + ' and ';
if VarIsNull(Value) then
begin
s1 := ' ('+MasterClause + IndexFields.FieldName + ' Is Null'+' )';
Continue;
end
else
s1 := ' ('+ IndexFields.FieldName +' =';
if IndexFields.DataType in [ftString,ftWideString] then
begin
s1 := s1 + #39 + VarToStr(Value) + #39 +' )'
end
else
if IndexFields.DataType in [ftDate,ftDateTime] then
begin
s1 := s1 + DateToStr(VarToDateTime(Value)) +' )'
end
else
s1 := s1 + VarToStr(Value) +' )'
end;
MasterClause := MasterClause +s1;
end;
if Trim(MasterClause) <> '' then
MasterClause := '( '+ MasterClause +' )';
except
end;
finally
if Assigned(lList) then
FreeAndNil(lList);
if Trim(MasterClause) <> '' then
Result := MasterClause;
end;
end;
end;
end;
end;
{-----------------------------------------------------------------------------
Procedure: TUAClientDataSet.DeleteDetailRecords
Author: vinson zeng
Date: 05-三月-2003
Arguments: MasterDataSet:TUAClientDataSet
Result: None
-----------------------------------------------------------------------------}
procedure TUAClientDataSet.DeleteDetailRecords(MasterDataSet:TUAClientDataSet);
var
lList:TList;
i:integer;
lCds:TUAClientDataSet;
procedure DeleteAllSubDetailRecords(lDetail:TUAClientDataSet);
var
lSubDetail:TUAClientDataSet;
j:integer;
lList1:TList;
begin
lList1 := TList.Create;
try
with lDetaildo
begin
case DataSetType of
dtDetail:
begin
DisableControls;
CloseAutoRequestNext(true);
First;
while not Eofdo
Delete;
CloseAutoRequestNext(false);
EnableControls;
end;
dtBoth:
begin
GetDetailDataSets(lList1);
for j := 0 to lList1.Count -1do
begin
lSubDetail := TUAClientDataSet(lList1.Items[j]);
DeleteAllSubDetailRecords(lSubDetail);
end;
DisableControls;
CloseAutoRequestNext(true);
First;
while not Eofdo
Delete;
CloseAutoRequestNext(false);
EnableControls;
end;
end;
end;
finally
if Assigned(lList1) then
FreeAndNil(lList1);
end;
end;
begin
// must fix bug
if not Assigned(MasterDataSet) then
Exit;
if not MasterDataSet.Active then
Exit;
if MasterDataSet.RecordCount = 0 then
Exit;
lList := TList.Create;
try
try
MasterDataSet.GetDetailDataSets(lList);
for i := 0 to lList.Count -1do
begin
lCds := TUAClientDataSet(lList.Items);
with lCdsdo
begin
case DataSetType of
dtDetail:
begin
DisableControls;
CloseAutoRequestNext(true);
First;
while not Eofdo
Delete;
CloseAutoRequestNext(false);
EnableControls;
end;
dtBoth:
DeleteAllSubDetailRecords(lCds);
end;
end;
end;
except
on E:Exceptiondo
begin
Showmessage('Delete Detail Records Effect Error;Native Msg:'+E.Message);
end;
end;
finally
if Assigned(lList) then
FreeAndNil(lList);
end;
end;
function TUAClientDataSet.GetConfirmNotFound: Boolean;
begin
Result := FConfirmNotFound;
end;
procedure TUAClientDataSet.SetConfirmNotFound(const Value: Boolean);
begin
FConfirmNotFound := Value;
end;
function TUAClientDataSet.GetIndexFields(DataSet: TDataSet): string;
var
i:integer;
sTmp:string;
begin
for i := 0 to IndexFieldCount -1do
begin
if trim(sTmp) <> '' then
sTmp := sTmp + ',';
sTmp := sTmp + IndexFields.FieldName;
end;
if trim(sTmp) <> '' then
Result := ','+sTmp;
end;
{-----------------------------------------------------------------------------
Procedure: TUAClientDataSet.ClearAllData
Author: vinson zeng
Date: 05-三月-2003
Arguments: None
Result: None
-----------------------------------------------------------------------------}
procedure TUAClientDataSet.ClearAllData;
var
lList:TList;
i:integer;
sErrorCode:string;
procedure ClearDetailData(aDetail:TUAClientDataSet);
var
j:integer;
lList1:TList;
begin
with aDetaildo
begin
EmptyDataSet;
ClearAllParams;
//2004-03-13 add by vinson zeng
MergeChangeLog;
lList1 := TList.Create;
GetDetailDataSets(lList1);
try
for j := 0 to lList1.Count -1do
ClearDetailData(TUAClientDataSet(lList1.Items[j]));
finally
if Assigned(lList1) then
FreeAndNil(lList1);
end;
end;
end;
begin
lList := TList.Create;
try
try
case GetDataSetType of
dtDetail,dtSingle:
begin
EmptyDataSet;
ClearAllParams;
//2004-03-13 add by vinson zeng
MergeChangeLog;
end;
dtMaster,dtBoth:
begin
EmptyDataSet;
ClearAllParams;
//2004-03-13 add by vinson zeng
MergeChangeLog;
GetDetailDataSets(lList);
for i := 0 to lList.Count -1do
ClearDetailData(TUAClientDataSet(lList.Items));
end;
end;
except
on E:Exceptiondo
begin
sErrorCode := '-40001';
Showmessage('clear data error!'+#13+'error code is:'+sErrorCode
+#13#10+'native error information is:'+E.Message);
end;
end;
finally
if Assigned(lList) then
FreeAndNil(lList);
end;
end;
procedure TUAClientDataSet.SetUAAutoRequestNext(const Value: Boolean);
begin
FUAAutoRequestNext := Value;
end;
procedure TUAClientDataSet.SetDesignActive(const Value: Boolean);
begin
if not Value then
begin
FDesignActive := Value;
Exit;
end;
if Value <> FDesignActive then
begin
if Value then
begin
try
do
DesignActive;
FDesignActive := Value;
except
on E:Exceptiondo
begin
end;
end;
end;
end;
end;
procedure TUAClientDataSet.DoDesignActive;
var
i:integer;
vOut:OleVariant;
aTmpCDS:TClientDataSet;
begin
if not (csDesigning in ComponentState) then
Exit;
aTmpCDS := TClientDataSet.Create(nil);
try
MasterUAServiceClient.UAServiceAdapter.Request('srvobjdesign','requesttblstrus',AliasTableName+'-'+MasterUAServiceClient.UAServiceAdapter.DefaultDBName,vOut);
if (not VarIsEmpty(vOut)) and (VarCompareValue(vOut,Unassigned)<>vrEqual) then
begin
aTmpCDS.Data := vOut;
aTmpCDS.Active := true;
if Self.FieldDefs.Count = 0 then
begin
for i := 0 to aTmpCDS.FieldDefs.Count -1do
begin
with Self.FieldDefs.AddFieldDefdo
begin
Name := aTmpCDS.FieldDefs.Name;
DataType := aTmpCDS.FieldDefs.DataType;
Size := aTmpCDS.FieldDefs.Size;
Precision := aTmpCDS.FieldDefs.Size;
Attributes := aTmpCDS.FieldDefs.Attributes;
Required := aTmpCDS.FieldDefs.Required;
DisplayName := aTmpCDS.FieldDefs.DisplayName;
end;
end;
end
else
begin
for i := 0 to aTmpCDS.FieldDefs.Count -1do
begin
if Self.FieldDefs.Find(aTmpCDS.FieldDefs.Name) = nil then
begin
with Self.FieldDefs.AddFieldDefdo
begin
Name := aTmpCDS.FieldDefs.Name;
DataType := aTmpCDS.FieldDefs.DataType;
Size := aTmpCDS.FieldDefs.Size;
Precision := aTmpCDS.FieldDefs.Size;
Attributes := aTmpCDS.FieldDefs.Attributes;
Required := aTmpCDS.FieldDefs.Required;
DisplayName := aTmpCDS.FieldDefs.DisplayName;
end;
end;
end;
end;
Self.CreateDataSet;
end;
finally
if Assigned(aTmpCDS) then
FreeAndNil(aTmpCDS);
if MasterUAServiceClient.UAServiceAdapter.Connected then
MasterUAServiceClient.UAServiceAdapter.Connected := false;
if Self.FieldDefs.Count <> 0 then
else
begin
MessageDlg('request table structure fail,please try again!',mtWarning,[mbOk], 0);
FDesignActive := false;
end;
end;
end;
{ TUAFieldsDesigner }
constructor TUAFieldsDesigner.Create;
begin
inherited;
end;
function TUAFieldsDesigner.GetOwnerDataSet: TUAClientDataSet;
begin
Result := FOwnerDataSet;
end;
procedure TUAFieldsDesigner.SetOwnerDataSet(const Value: TUAClientDataSet);
begin
FOwnerDataSet := Value;
end;
end.
{ }
{ Universal Agent on demond SDK }
{ }
{ }
{ COPYRIGHT }
{ ========= }
{ The UA SDK (software) is Copyright (C) 2001-2003, by vinson zeng(曾胡龙). }
{ All rights reserved. }
{ The authors - vinson zeng (曾胡龙), }
{ exclusively own all copyrights to the Advanced Application }
{ Controls (AppControls) and all other products distributed by Utilmind Solutions(R). }
{ }
{ LIABILITY DISCLAIMER }
{ ==================== }
{ THIS SOFTWARE IS DISTRIBUTED "AS IS" AND WITHOUT WARRANTIES AS TO PERFORMANCE }
{ OF MERCHANTABILITY OR ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. }
{ YOU USE IT AT YOUR OWN RISK. THE AUTHOR WILL NOT BE LIABLE FOR DATA LOSS, }
{ DAMAGES, LOSS OF PROFITS OR ANY OTHER KIND OF LOSS WHILE USING OR MISUSING THIS SOFTWARE.}
{ }
{ RESTRICTIONS }
{ ============ }
{ You may not attempt to reverse compile, modify, }
{ translate or disassemble the software in whole or in part. }
{ You may not remove or modify any copyright notice or the method by which }
{ it may be invoked. }
{******************************************************************************************}
unit UAClientDataSet;
interface
uses
Windows, Variants, ActiveX, Classes,
Dialogs,DBClient,DB,SysUtils,DSIntf,Forms,
Controls,UADataPacket,UAServiceClient;
{$I UaSdk.inc}
type
TRemoteServiceEvent = procedure (Sender:TObject;var CustomData:OleVariant) of Object;
TUpdateErrorEvent = procedure (Sender:TObject;ErrorCode:integer;
var bContinue:Boolean) of Object;
TUAOption = (uoAutoRequestNext,uoAutoUpdate,uoAutoCatchError,uoAutoMergeAll);
TUAOptions = set of TUAOption;
TOperateOption = (ooRequest,ooRequestNext,ooRequestCustom,ooUpdate,ooUpdateCustom,ooRefreshAllData,
ooRefreshSelected,ooQueryData);
TOperateOptions= set of TOperateOption;
TDataSetType = (dtSingle,dtMaster,dtDetail,dtBoth,dtNone);
// add define for multi table process by vinson zeng
CharSet = set of Char;
TUAClientDataSet = class;
TUAFieldsDesigner = class(TPersistent)
private
FOwnerDataSet:TUAClientDataSet;
function GetOwnerDataSet: TUAClientDataSet;
procedure SetOwnerDataSet(const Value: TUAClientDataSet);
protected
public
constructor Create;
published
property OwnerDataSet:TUAClientDataSet read GetOwnerDataSet write SetOwnerDataSet;
end;
TUAClientDataSet = class(TClientDataSet)
private
FAllRecCount:Integer;
FUAServiceClient:TUAServiceClient;
FMasterUAServiceClient:TUAServiceClient;
// add by vinson zeng
FAliasTableName:string;
FKeyFields:string;
FFetchNextDataPacket:Boolean;
FCanUpdate:Boolean;
FBeforeRequest:TNotifyEvent;
FAfterRequest:TRemoteServiceEvent;
FBeforeUpdate:TNotifyEvent;
FAfterUpadte:TNotifyEvent;
FUAOptions:TUAOptions;
FOperateOptions:TOperateOptions;
FUpdateErrorEvent:TUpdateErrorEvent;
FSqlScript:string;
FOpenAllData:Boolean;
FFieldsDesigner:TUAFieldsDesigner;
FDataInfo:string;
FConfirmNotFound:Boolean;
FRelaCheck:Boolean;
FDataSetType:TDataSetType;
FUAAutoRequestNext:Boolean;
FDesignActive:Boolean;
function GetUAServiceClient: TUAServiceClient;
procedure SetUAServiceClient(const Value: TUAServiceClient);
function GetAllRecCount: Integer;
procedure SetAllRecCount(const Value: Integer);
function GetAliasTableName: string;
procedure SetAliasTableName(const Value: string);
function GetFetchNextDataPacket: Boolean;
procedure SetFetchNextDataPacket(const Value: Boolean);
function GetKeyFields: string;
procedure SetKeyFields(const Value: string);
function GetCanUpdate: Boolean;
procedure SetUAOptions(const Value: TUAOptions);
procedure SetSqlScript(const Value: string);
procedure SetOpenAllData(const Value: Boolean);
function GetDataInfo: string;
// add by vinson zeng 2004-01-05
function GetConfirmNotFound: Boolean;
procedure SetConfirmNotFound(const Value: Boolean);
//--------%% end of %% -----------------
procedure SetUAAutoRequestNext(const Value: Boolean);
procedure SetDesignActive(const Value: Boolean);
//2004-03-07
protected
FDataSheetList:TUAParams;
FRowSheetList:TUAParams;
FMasterLinkList:TUAParams;
function GetDataSetType:TDataSetType;
procedure CheckNextDataPacket;
virtual;
procedure CheckForUpdate;
//??
function CheckOperateState(const OperateIndex:integer = -1):Boolean;
function GetMasterUAServiceClient:TUAServiceClient;
procedure DeleteDetailRecords(MasterDataSet:TUAClientDataSet);virtual;
//????
procedure do
DesignActive;
//2004-3-26 modify by vinson zeng
function GetMasterLinkScript(Sender:TObject):string;
function BuildRequestDataParam(Sender:TObject):integer;
function BuildDeltaParam(UAClientDataSet:TUAClientDataSet):Boolean;
function BuildRefreshDataScript(Sender:TObject;var sSqlScript:string;const bAll :Boolean = false):Boolean;
procedure AddReturnDataPacket(const vData:OleVariant);
function GetIndexFields(DataSet:TDataSet):string;
// add by vinson zeng for multi table applyupdates process
//----Inherited from TCustomClientDataSet---------
procedure DataEvent(Event: TDataEvent;
Info: Longint);
override;
procedure AddDataPacket(const Data: OleVariant;
HitEOF: Boolean);
override;
procedure CheckDetailRecords;
override;
procedure InternalDelete;
override;
procedure InternalPost;
override;
procedure InternalCancel;
override;
procedure InternalOpen;
override;
procedure InternalInsert;
override;
procedure InternalEdit;
override;
procedure InternalRefresh;
override;
procedure do
OnNewRecord;
override;
procedure Notification(AComponent: TComponent;
Operation: TOperation);override;
//-------%% end of %%---------------------
public
constructor Create(AOwner: TComponent);
override;
destructor Destroy;
override;
procedure Loaded;
override;
procedure RefreshAllData(Sender:TObject;
const bAll :Boolean = false);
procedure MergeAllChangeLog;
///???
procedure CancelSubmitAllDelta;
virtual;///?????
procedure ClearAllData;virtual;
procedure QueryData(Sender:TObject;const ClearData:Boolean = false);
function do
Request(const RequestIndex:Integer= -1):OleVariant;virtual;
procedure do
Update (const UpdateIndex:Integer = -1);virtual;
procedure ClearAllParams;
procedure CloseAutoRequestNext(const bClose:Boolean = true);
property DataInfo:string read GetDataInfo;
property AllRecCount:Integer read GetAllRecCount write SetAllRecCount;
property CanUpdate:Boolean read GetCanUpdate default false;
property FetchNextDataPacket:Boolean read GetFetchNextDataPacket write SetFetchNextDataPacket default false;
property OperateOptions:TOperateOptions read FOperateOptions default[];
property ConfirmNotFound:Boolean read GetConfirmNotFound write SetConfirmNotFound default false;
property DataSetType:TDataSetType read GetDataSetType;
property MasterUAServiceClient:TUAServiceClient read GetMasterUAServiceClient;
// add by vinson zeng
property UAAutoRequestNext:Boolean read FUAAutoRequestNext write SetUAAutoRequestNext;
published
property FieldsDesigner:TUAFieldsDesigner read FFieldsDesigner;
//-----extenal with UA-----------------
property OpenAllData:Boolean read FOpenAllData write SetOpenAllData;
property UAOptions:TUAOptions read FUAOptions write SetUAOptions default [uoAutoRequestNext];
property UAServiceClient:TUAServiceClient read GetUAServiceClient write SetUAServiceClient;
property AliasTableName:string read GetAliasTableName write SetAliasTableName;
property KeyFields:string read GetKeyFields write SetKeyFields;
property BeforeRequest:TNotifyEvent read FBeforeRequest write FBeforeRequest;
property AfterRequest:TRemoteServiceEvent read FAfterRequest write FAfterRequest;
property BeforeUpdate:TNotifyEvent read FBeforeUpdate write FBeforeUpdate;
property AfterUpadte:TNotifyEvent read FAfterUpadte write FAfterUpadte;
property UpdateErrorEvent:TUpdateErrorEvent read FUpdateErrorEvent write FUpdateErrorEvent;
property SqlScript:string read FSqlScript write SetSqlScript;
property DesignActive:Boolean read FDesignActive write SetDesignActive;
//-----------%% end of %%--------------------
end;
const
crUAWait = 5;
SupportFieldTypes = [ftString, ftWideString, ftSmallint, ftInteger, ftAutoInc, ftWord, ftBoolean, ftLargeint, ftFloat, ftCurrency, ftDate, ftTime, ftDateTime, ftBlob, ftMemo];
SNotSupportFieldType = 'Field type is not supported by TUAClientDataSet. '#13 +
'Valid types is String, WideString, Smallint, Integer, Word, Boolean, Largeint, Float, Currency, Date, Time, DateTime, Blob, Memo';
function xStrSplit(str:String;
chars:CharSet;
tsStrs:TStrings;AutoClear: Boolean;
bTrim:Boolean):integer;
implementation
function xStrSplit(str:String;
chars:CharSet;
tsStrs:TStrings;AutoClear: Boolean;
bTrim:Boolean):integer;
var
n, i, k : integer;
s : string;
begin
Result := 0;
if chars=[] then
chars := [',',';'];
if tsStrs=nil then
Exit;
if AutoClear then
tsStrs.Clear;
k := Length(str);
if (k=0) then
Exit;
i := 1;
for n:=1 to kdo
if str[n] in chars then
begin
s := Copy(Str, i, n-i);
if bTrim then
s:=Trim(s);
tsStrs.Add(s);
i := n+1;
Inc(Result);
end;
if i<=k then
begin
s := Copy(Str, i, n-i);
if bTrim then
s:=Trim(s);
tsStrs.Add(s);
Inc(Result);
end;
end;
{ TUAClientDataSet }
procedure TUAClientDataSet.AddDataPacket(const Data: OleVariant;HitEOF: Boolean);
begin
inherited;
end;
{-----------------------------------------------------------------------------
Procedure: TUAClientDataSet.CheckForUpdate
Author: vinson zeng
Date: 05-三月-2003
Arguments: None
Result: None
-----------------------------------------------------------------------------}
procedure TUAClientDataSet.CheckForUpdate;
var
i:integer;
lList:TList;
bCheckDetail:Boolean;
function CheckForUpdateWithDetail(aDetail:TUAClientDataSet):Boolean;
var
j:integer;
lList1:TList;
bSubDetail:Boolean;
begin
bSubDetail := false;
with aDetaildo
begin
CheckBrowseMode;
Result := ChangeCount > 0;
lList1 := TList.Create;
GetDetailDataSets(lList1);
try
for j := 0 to lList1.Count -1do
bSubDetail := CheckForUpdateWithDetail(TUAClientDataSet(lList1.Items[j]));
Result := Result or bSubDetail;
finally
if Assigned(lList1) then
FreeAndNil(lList1);
end;
end;
end;
begin
bCheckDetail := false;
lList := TList.Create;
try
try
case DataSetType of
dtSingle,dtDetail: begin
CheckBrowseMode;
FCanUpdate := ChangeCount > 0;
end;
dtMaster,dtBoth:
begin
CheckBrowseMode;
FCanUpdate := ChangeCount > 0;
GetDetailDataSets(lList);
for i := 0 to lList.Count -1do
bCheckDetail := CheckForUpdateWithDetail(TUAClientDataSet(lList.Items));
FCanUpdate := FCanUpdate or bCheckDetail;
end;
end;
except
FCanUpdate := false;
end;
finally
if Assigned(lList) then
FreeAndNil(lList);
end;
// Assert(FCanUpdate,'check for update is false');
end;
{-----------------------------------------------------------------------------
Procedure: TUAClientDataSet.CheckNextDataPacket
Author: vinson zeng
Date: 05-三月-2003
Arguments: None
Result: None
-----------------------------------------------------------------------------}
procedure TUAClientDataSet.CheckNextDataPacket;
begin
if not UAAutoRequestNext then
Exit;
UpdateCursorPos;
FetchNextDataPacket := (MasterUAServiceClient <> nil) and Eof
and (RecordCount < AllRecCount)
and Active and (not (State in [dsInsert,dsEdit,dsInactive]))
and (ChangeCount = 0);
try
if FetchNextDataPacket and (uoAutoRequestNext in FUAOptions)
and ( (DataSetType = dtMaster) or (DataSetType = dtSingle)) then
begin
Include(FOperateOptions,ooRequestNext);
do
Request(1);
end;
except
//do notdo
anything ,reverse event for catch error!
end;
end;
constructor TUAClientDataSet.Create(AOwner: TComponent);
begin
inherited;
FAllRecCount := 0;
FFetchNextDataPacket := false;
FCanUpdate := false;
FDataSheetList := TUAParams.Create(true);
FRowSheetList:= TUAParams.Create(true);
FMasterLinkList := TUAParams.Create(true);
FFieldsDesigner := TUAFieldsDesigner.Create;
FFieldsDesigner.OwnerDataSet := Self;
Include(FUAOptions,uoAutoRequestNext);
Include(FUAOptions,uoAutoUpdate);
FOperateOptions := [];
FConfirmNotFound := false;
FRelaCheck := true;
FDataSetType := dtNone;
FUAAutoRequestNext := true;
Screen.Cursors[crUAWait] := LoadCursor(HInstance, 'UAWait');
end;
procedure TUAClientDataSet.DataEvent(Event: TDataEvent;
Info: Integer);
begin
{$define chineseinfo}
try
case Event of
deCheckBrowseMode: // add by vinson zeng for bug on delete record not effect
begin
end;
deDataSetScroll:
begin
CheckNextDataPacket;
if Active then
begin
{$ifdef chineseinfo}
FDataInfo := Format('共计 %s 条记录，当前为已打开 %s条中的第 %s 条记录',[IntToStr(AllRecCount),IntToStr(RecordCount),IntToStr(RecNo)]);
{$else
}
FDataInfo := Format('Total RecordCount Is %s , Local RecordCount Is %s Currrent RecNo Is %s ',[IntToStr(AllRecCount),IntToStr(RecordCount),IntToStr(RecNo)]);
{$endif}
end
else
begin
{$ifdef chineseinfo}
FDataInfo := '当前数据集没有激活！';
{$else
}
FDataInfo := 'not current dataset active！';
{$endif}
end;
end;
deParentScroll:
begin
end;
deDataSetChange:
begin
end;
deUpdateState: //2004-3-10 wait bug fix for ?????
begin
end;
end;
inherited;
except
on E:Exceptiondo
begin
Showmessage('Native Error:'+E.Message+#13#10+ 'Event Code Is:'+IntToStr(Ord(Event)));
end;
end;
end;
destructor TUAClientDataSet.Destroy;
begin
FDataSheetList.Free;;
FRowSheetList.Free;
FMasterLinkList.Free;
FFieldsDesigner.Free;
inherited;
end;
function TUAClientDataSet.GetAliasTableName: string;
begin
Result := FAliasTableName;
end;
function TUAClientDataSet.GetAllRecCount: Integer;
begin
Result := FAllRecCount;
end;
function TUAClientDataSet.GetFetchNextDataPacket: Boolean;
begin
Result := FFetchNextDataPacket;
end;
function TUAClientDataSet.GetCanUpdate: Boolean;
begin
Result := FCanUpdate;
end;
function TUAClientDataSet.GetKeyFields: string;
begin
Result := FKeyFields;
end;
function TUAClientDataSet.GetUAServiceClient: TUAServiceClient;
begin
Result := FUAServiceClient;
end;
procedure TUAClientDataSet.InternalDelete;
begin
DeleteDetailRecords(Self);
inherited;
end;
procedure TUAClientDataSet.InternalPost;
begin
inherited;
end;
procedure TUAClientDataSet.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if (Operation = opRemove) and (FUAServiceClient <> nil) and
(AComponent = UAServiceClient) then
UAServiceClient := nil;
end;
procedure TUAClientDataSet.SetAliasTableName(const Value: string);
begin
if Trim(Value) <> '' then
FAliasTableName := Value;
end;
procedure TUAClientDataSet.SetAllRecCount(const Value: Integer);
begin
FAllRecCount := Value;
end;
procedure TUAClientDataSet.SetFetchNextDataPacket(
const Value: Boolean);
begin
FFetchNextDataPacket := Value;
end;
procedure TUAClientDataSet.SetKeyFields(const Value: string);
begin
if Trim(Value) <> '' then
FKeyFields := Value;
end;
procedure TUAClientDataSet.SetUAServiceClient(
const Value: TUAServiceClient);
begin
if Value <> nil then
FUAServiceClient := Value
else
FUAServiceClient := nil;
end;
{-----------------------------------------------------------------------------
Procedure: TUAClientDataSet.DoUpdate
Author: vinson zeng
Date: 05-三月-2003
Arguments: const UpdateIndex: Integer
Result: None
-----------------------------------------------------------------------------}
procedure TUAClientDataSet.DoUpdate(const UpdateIndex: Integer);
var
sErrorCode:string;
bCando:Boolean;
bDoOnError:Boolean;
iError:integer;
iMaxError:integer;
begin
bCando := false;
bDoOnError := true;
iError := 0;
iMaxError := 0;
CheckForUpdate;
Screen.Cursor := crSqlWait;
try
if CanUpdate then
begin
try
if Assigned(FBeforeUpdate) then
FBeforeUpdate(Self);
if BuildDeltaParam(Self) then
begin
iMaxError := MasterUAServiceClient.DoUpdate('SubmitAllDelta',UpdateIndex);
//Normal ServiceName
if UpdateIndex = -1 then
Include(FOperateOptions,ooUpdate);
if UpdateIndex = 1 then
Include(FOperateOptions,ooUpdateCustom);
bCando := true;
end
else
begin
bCando := false;
iError := -7;
//Local Error on Add Delta
end;
if Assigned(FAfterUpadte) then
FAfterUpadte(Self);
except
on E:Exceptiondo
begin
iError := -1;
//Remote Process Error on ApplyUpdates
sErrorCode := '-30002';
if UpdateIndex = -1 then
Exclude(FOperateOptions,ooUpdate);
if UpdateIndex = 1 then
Exclude(FOperateOptions,ooUpdateCustom);
Showmessage('data update error!'+#13+'error code is:'+sErrorCode
+#13#10+'native error information is:'+E.Message);
end;
end;
end;
finally
Screen.Cursor := crDefault;
end;
if bCando and (iError = 0) and (MasterUAServiceClient.UAUpdateDataOutPacket.ResultCode = 0) and (iMaxError = 0) then
begin
if not CheckOperateState(1) then
// iError := -9 // Local Error On MergeData
else
begin
MergeAllChangeLog;
// MessageDlg('执行远程数据更新成功！', mtInformation,[mbOk], 0);
Application.MessageBox('执行远程数据更新成功！',PChar(Application.Title),MB_OK);
end;
end
else
begin
if Assigned(FUpdateErrorEvent) then
FUpdateErrorEvent(Self,iError,bDoOnError);
if bDoOnError then
begin
// if MessageDlg('执行远程数据更新失败，确认继续当前业务数据编辑工作吗？',mtWarning, [mbYes, mbNo], 0) = mrYes then
if Application.MessageBox('执行远程数据更新失败，确认继续当前业务数据编辑工作吗？',PChar(Application.Title),
MB_YESNO) = IDYES then
Exit
else
CancelSubmitAllDelta;
end
else
begin
//do nothing in here
end;
end;
end;
{-----------------------------------------------------------------------------
Procedure: TUAClientDataSet.DoRequest
Author: vinson zeng
Date: 05-三月-2003
Arguments: const RequestIndex: Integer
Result: OleVariant
-----------------------------------------------------------------------------}
function TUAClientDataSet.DoRequest( const RequestIndex: Integer): OleVariant;
var
sErrorCode:string;
iMaxError:integer;
begin
//Normal ServiceName Is : RequestAllData;
iMaxError := 0;
Result := Unassigned;
Screen.Cursor := crSqlWait;
try
try
case RequestIndex of
-1 : //标准数据请求：只记录数据分页键值
begin
if BuildRequestDataParam(Self) <> -1 then
begin
try
iMaxError := MasterUAServiceClient.DoRequest('RequestAllData',-1);
Result := MasterUAServiceClient.UARequestDataOutPacket.UAData;
Include(FOperateOptions,ooRequest);
except
on E:Exceptiondo
begin
Exclude(FOperateOptions,ooRequest);
end;
end;
end;
end;
1: //请求下一个数据包：只记录数据分页键值
begin
if Assigned(FBeforeRequest) then
FBeforeRequest(Self);
if BuildRequestDataParam(Self) <> -1 then
begin
try
iMaxError := MasterUAServiceClient.DoRequest('RequestAllData',1);
Result := MasterUAServiceClient.UARequestDataOutPacket.UAData;
except
on E:Exceptiondo
begin
Exclude(FOperateOptions,ooRequestNext);
end;
end;
end;
end;
0: //用户自定义的数据请求：只记录数据集合所有行数据键值
begin
if ooQueryData In FOperateOptions then
begin
if Assigned(FBeforeRequest) then
FBeforeRequest(Self);
if BuildRequestDataParam(Self) <> -1 then
begin
try
iMaxError := MasterUAServiceClient.DoRequest('QueryData',1);
Result := MasterUAServiceClient.UARequestDataOutPacket.UAData;
except
on E:Exceptiondo
begin
end;
end;
end;
end
else
if (ooRefreshAllData In FOperateOptions) or (ooRefreshSelected in FOperateOptions) then
begin
if Assigned(FBeforeRequest) then
FBeforeRequest(Self);
if BuildRequestDataParam(Self) <> -1 then
begin
try
iMaxError := MasterUAServiceClient.DoRequest('RefreshData',1);
Result := MasterUAServiceClient.UARequestDataOutPacket.UAData;
except
on E:Exceptiondo
begin
end;
end;
end;
end;
end;
else
MessageDlg('can not support service request!', mtWarning,[mbOk], 0)
end;
if Assigned(FAfterRequest) then
FAfterRequest(Self,Result);
if (not VarIsEmpty(Result)) and VarIsArray(Result) and
(VarCompareValue(Result,Unassigned) <> vrEqual) and (iMaxError = 0) then
AddReturnDataPacket(Result);
except
on E:Exceptiondo
begin
sErrorCode := '-30001';
Showmessage('data request error!'+#13+'error code is:'+sErrorCode
+#13#10+'native error information is:'+E.Message);
end;
end;
finally
Screen.Cursor := crDefault;
end;
end;
function TUAClientDataSet.GetDataSetType: TDataSetType;
var
lList:TList;
HaveParent:Boolean;
HaveDetail:Boolean;
begin
if (FDataSetType <> dtNone) then
begin
Result := FDataSetType;
Exit;
end
else
begin
HaveParent := (MasterSource <> nil) and (Trim(MasterFields) <>'');
lList := TList.Create;
try
GetDetailDataSets(lList);
HaveDetail := lList.Count > 0;
finally
if Assigned(lList) then
lList.Free;
end;
if (not HaveParent) and HaveDetail then
FDataSetType := dtMaster;
if HaveParent and (not HaveDetail) then
FDataSetType := dtDetail;
if (not HaveParent) and (not HaveDetail) then
FDataSetType := dtSingle;
if HaveParent and HaveDetail then
FDataSetType := dtBoth;
Result := FDataSetType;
end;
// Assert(FDataSetType = dtNone,'can not get UAClientDataSet DataSetType!');
end;
procedure TUAClientDataSet.ClearAllParams;
begin
FDataSheetList.Clear;
FRowSheetList.Clear;
FMasterLinkList.Clear;
end;
procedure TUAClientDataSet.CheckDetailRecords;
var
i,RecCount:integer;
lList:TList;
aMasterLink:TMasterLinkParam;
aMasterDataSet:TDataSet;
Status: DBResult;
begin
Status := DSCursor.GetRecordCount(RecCount);
aMasterDataSet := MasterSource.DataSet;
if DataSetField <> nil then
begin
end
else
begin
if (RecCount = 0) and
(PacketRecords = 0) and not aMasterDataSet.IsEmpty and
(aMasterDataSet.State <> dsInsert) and (TUAClientDataSet(aMasterDataSet).ChangeCount = 0) then
begin
lList := TList.Create;
FMasterLinkList.Clear;
try
try
aMasterDataSet.GetFieldList(lList,MasterFields);
for i := 0 to lList.Count -1do
begin
aMasterLink := TMasterLinkParam.Create;
with TField(lList.Items)do
begin
aMasterLink.MasterAliasTableName := TUAClientDataSet(aMasterDataSet).AliasTableName;
aMasterLink.MasterField := IndexFields.FieldName;
aMasterLink.DataType := IndexFields.DataType;
if not VarIsNull(Value) then
aMasterLink.MasterFieldValue := Value
else
aMasterLink.MasterFieldValue := Null;
end;
FMasterLinkList.Add(aMasterLink);
end;
do
Request;
if Active then
First;
except
on E:Exceptiondo
begin
Showmessage('internal error at check detail records!'+#13+'Native Msg:'+E.Message);
end;
end;
finally
if Assigned(lList) then
FreeAndNil(lList);
end;
end;
end;
end;
procedure TUAClientDataSet.Loaded;
begin
inherited;
if (csLoading in ComponentState) then
//do otherting
end;
procedure TUAClientDataSet.InternalRefresh;
begin
// inherited;
end;
procedure TUAClientDataSet.SetUAOptions(const Value: TUAOptions);
begin
FUAOptions := Value;
end;
function TUAClientDataSet.CheckOperateState(const OperateIndex: integer):Boolean;
begin
Result := false;
// -1 代表数据请求申请；
// 1 代表数据更新申请；
try
case OperateIndex of
-1 :begin
if ooRequest in FOperateOptions then
begin
Exclude(FOperateOptions,ooRequest);
end;
if ooRequestNext in FOperateOptions then
begin
Exclude(FOperateOptions,ooRequestNext);
end;
if ooRequestCustom in FOperateOptions then
begin
Exclude(FOperateOptions,ooRequestCustom);
end;
end;
1: begin
if ooUpdateCustom in FOperateOptions then
begin
MergeAllChangeLog;
Exclude(FOperateOptions,ooUpdateCustom);
end;
if ooUpdate in FOperateOptions then
begin
MergeAllChangeLog;
Exclude(FOperateOptions,ooUpdate);
end;
end;
else
MessageDlg('can not support this operation!', mtWarning,[mbOk], 0);
end;
Result := true;
except
on E:Exceptiondo
begin
Showmessage('UAClientDataSet internal error,please try again!');
end;
end;
end;
procedure TUAClientDataSet.MergeAllChangeLog;
var
lList:TList;
i:integer;
sErrorCode:string;
begin
lList := TList.Create;
try
try
case GetDataSetType of
dtDetail,dtSingle:
MergeChangeLog;
dtMaster,dtBoth:
begin
MergeChangeLog;
GetDetailDataSets(lList);
for i := 0 to lList.Count -1do
begin
if not (TComponent(lList.Items) is TUAClientDataSet) then
Continue;
TUAClientDataSet(lList.Items).MergeAllChangeLog;
end;
end;
end;
except
on E:Exceptiondo
begin
sErrorCode := '-30007';
Showmessage('merge data error!'+#13+'error code is:'+sErrorCode
+#13#10+'native error information is:'+E.Message);
end;
end;
finally
lList.Free;
end;
end;
procedure TUAClientDataSet.InternalEdit;
begin
inherited;
end;
procedure TUAClientDataSet.InternalInsert;
begin
inherited;
end;
procedure TUAClientDataSet.InternalOpen;
begin
inherited;
end;
{-----------------------------------------------------------------------------
Procedure: TUAClientDataSet.GetMasterUAServiceClient
Author: vinson zeng
Date: 05-三月-2003
Arguments: None
Result: TUAServiceClient
-----------------------------------------------------------------------------}
function TUAClientDataSet.GetMasterUAServiceClient: TUAServiceClient;
var
aMaster:TUAClientDataSet;
DSMaster:TDataSource;
begin
if Assigned(FMasterUAServiceClient) then
begin
Result := FMasterUAServiceClient;
Exit;
end;
case DataSetType of
dtSingle,dtMaster:
if UAServiceClient <> nil then
begin
FMasterUAServiceClient := UAServiceClient;
Result := FMasterUAServiceClient;
end;
dtBoth,dtDetail:
begin
if MasterSource.DataSet is TUAClientDataSet then
begin
// modify by vinson zeng 2004-01-06
aMaster := TUAClientDataSet(MasterSource.DataSet);
//改进算法 vinson zeng
while (FMasterUAServiceClient = nil) and (Assigned(aMaster))do
begin
if aMaster.MasterUAServiceClient <> nil then
begin
FMasterUAServiceClient := aMaster.MasterUAServiceClient;
Result := FMasterUAServiceClient;
end;
if (not Assigned(Result)) and (aMaster.MasterSource <> nil ) then
begin
DSMaster := aMaster.MasterSource;
aMaster := TUAClientDataSet(DSMaster.DataSet);
end
else
aMaster := nil;
end;
end;
end;
end;
end;
{-----------------------------------------------------------------------------
Procedure: TUAClientDataSet.CancelSubmitAllDelta
Author: vinson zeng
Date: 05-三月-2003
Arguments: None
Result: None
-----------------------------------------------------------------------------}
procedure TUAClientDataSet.CancelSubmitAllDelta;
var
lList:TList;
i:integer;
sErrorCode:string;
procedure CancelSubmitDetail(aDetail:TUAClientDataSet);
var
j:integer;
lList1:TList;
begin
with aDetaildo
begin
CancelUpdates;
lList1 := TList.Create;
GetDetailDataSets(lList1);
try
for j := 0 to lList1.Count -1do
CancelSubmitDetail(TUAClientDataSet(lList1.Items[j]));
finally
if Assigned(lList1) then
FreeAndNil(lList1);
end;
end;
end;
begin
lList := TList.Create;
try
try
case GetDataSetType of
dtDetail,dtSingle:
CancelUpdates;
dtMaster,dtBoth:
begin
CancelUpdates;
GetDetailDataSets(lList);
for i := 0 to lList.Count -1do
CancelSubmitDetail(TUAClientDataSet(lList.Items));
end;
end;
except
on E:Exceptiondo
begin
sErrorCode := '-40001';
Showmessage('merge data error!'+#13+'error code is:'+sErrorCode
+#13#10+'native error information is:'+E.Message);
end;
end;
finally
if Assigned(lList) then
FreeAndNil(lList);
end;
end;
{-----------------------------------------------------------------------------
Procedure: TUAClientDataSet.BuildDeltaParam
Author: vinson zeng
Date: 05-三月-2003
Arguments: UAClientDataSet:TUAClientDataSet
Result: Boolean
-----------------------------------------------------------------------------}
function TUAClientDataSet.BuildDeltaParam(UAClientDataSet:TUAClientDataSet):Boolean;
var
aDelta:TDeltaParam;
aDetailDS:TUAClientDataSet;
lList:TList;
i:integer;
function BuildDetailDeltaPacket(UACds:TUAClientDataSet):Boolean;
var
i:integer;
lList1:TList;
aDetailDS1:TUAClientDataSet;
bSubDetail:Boolean;
begin
Result := true;
// bSubDetail := false;
lList1 := TList.Create;
try
try
with UACdsdo
begin
if ChangeCount <> 0 then
//add Detail
begin
aDelta := TDeltaParam.Create;
aDelta.AliasTableName := AliasTableName;
aDelta.KeyFields := KeyFields + GetIndexFields(nil);
aDelta.Delta := Delta;
MasterUAServiceClient.UAUpdateDataInPacket.AddItemDelta(aDelta);
end;
GetDetailDataSets(lList1);
for i := 0 to lList1.Count -1do
begin
aDetailDS1 := TUAClientDataSet(lList1.Items);
case aDetailDS1.DataSetType of
dtDetail:
begin
if aDetailDS1.ChangeCount <> 0 then
begin
aDelta := TDeltaParam.Create;
aDelta.AliasTableName := aDetailDS1.AliasTableName;
aDelta.KeyFields := aDetailDS1.KeyFields + aDetailDS1.GetIndexFields(nil);;
aDelta.Delta := aDetailDS1.Delta;
MasterUAServiceClient.UAUpdateDataInPacket.AddItemDelta(aDelta);
end;
end;
dtBoth:
begin
bSubDetail := BuildDetailDeltaPacket(aDetailDS1);
Result := Result and bSubDetail;
end;
end;
end;
end;
except
on E:Exceptiondo
begin
Result := false;
end;
end;
finally
if Assigned(lList1) then
FreeAndNil(lList1);
end;
end;
begin
// bug : for Master/Detail/SubDetail rela struc stack overflow :Loop error vinson zeng 2003-12-29
// fix : check GetDetailDataSets method
// modify by vinson zeng for Master/Detail Add Delta Seq
Result := true;
if not Assigned(UAClientDataSet) then
begin
Result := false;
Exit;
end;
if MasterUAServiceClient = nil then
begin
Result := false;
Exit;
end;
try
with MasterUAServiceClientdo
begin
// if not FCurrentUpdate then
//fix by vinson zeng for delete affect delta
UAUpdateDataInPacket.ClearAllUaData;
case UAClientDataSet.DataSetType of
dtMaster:
begin
lList := TList.Create;
try
if ChangeCount <> 0 then
//Master Is First Add
begin
aDelta := TDeltaParam.Create;
aDelta.AliasTableName := AliasTableName;
aDelta.KeyFields := KeyFields + GetIndexFields(nil);
aDelta.Delta := Delta;
UAUpdateDataInPacket.AddItemDelta(aDelta);
end;
GetDetailDataSets(lList);
for i := 0 to lList.Count -1do
begin
aDetailDS := TUAClientDataSet(lList.Items);
Result := Result and BuildDetailDeltaPacket(aDetailDS);
// modify by visnon zeng 2004-01-06
end;
finally
if Assigned(lList) then
FreeAndNil(lList);
end;
end;
dtSingle,dtDetail:
begin
if ChangeCount <> 0 then
begin
aDelta := TDeltaParam.Create;
aDelta.AliasTableName := AliasTableName;
aDelta.KeyFields := KeyFields + GetIndexFields(nil);
aDelta.Delta := Delta;
UAUpdateDataInPacket.AddItemDelta(aDelta);
end;
end;
end;
end;
except
Result := false;
end;
end;
procedure TUAClientDataSet.SetSqlScript(const Value: string);
begin
FSqlScript := Value;
end;
{-----------------------------------------------------------------------------
Procedure: TUAClientDataSet.BuildRequestDataParam
Author: vinson zeng
Date: 05-三月-2003
Arguments: Sender: TObject
Result: integer
-----------------------------------------------------------------------------}
function TUAClientDataSet.BuildRequestDataParam(Sender: TObject): integer;
var
aDataRequestParam:TDataRequestParam;
i:integer;
aDataSheetParam:TDataSheetParam;
aMasterLinkParam:TMasterLinkParam;
aRowSheetParam:TRowSheetParam;
begin
with MasterUAServiceClientdo
begin
aDataRequestParam := TDataRequestParam.Create;
try
try
ClearRequestParams;
aDataRequestParam.AliasTableName := AliasTableName;
aDataRequestParam.KeyFields := KeyFields;
aDataRequestParam.RequestRecCount := PacketRecords;
aDataRequestParam.SqlParams := SqlScript;
if Active then
aDataRequestParam.CurrRecCount := RecordCount;
if FMasterLinkList.Count <> 0 then
begin
for i := 0 to FMasterLinkList.Count -1do
begin
aMasterLinkParam := TMasterLinkParam.Create;
aMasterLinkParam.UAData := TMasterLinkParam(FMasterLinkList.Items).UAData;
UARequestDataInPacket.AddItemMasterLink(aMasterLinkParam);
end;
end;
if FRowSheetList.Count <> 0 then
begin
for i := 0 to FRowSheetList.Count -1do
begin
aRowSheetParam := TRowSheetParam.Create;
aRowSheetParam.UAData := TRowSheetParam(FRowSheetList.Items).UAData;
UARequestDataInPacket.AddItemRowSheet(aRowSheetParam);
end;
end;
if (ooRequestNext in FOperateOptions) and (FDataSheetList.Count <> 0) then
begin
for i := 0 to FDataSheetList.Count -1do
begin
aDataSheetParam := TDataSheetParam.Create;
aDataSheetParam.UAData := TDataSheetParam(FDataSheetList.Items).UAData;
UARequestDataInPacket.AddItemDataSheet(aDataSheetParam);
end;
end;
except
Result := -1;
end;
UARequestDataInPacket.AddItemRequestData(aDataRequestParam);
Result := 1;
finally
end;
end;
end;
{-----------------------------------------------------------------------------
Procedure: TUAClientDataSet.AddReturnDataPacket
Author: vinson zeng
Date: 05-三月-2003
Arguments: const vData: OleVariant
Result: None
-----------------------------------------------------------------------------}
procedure TUAClientDataSet.AddReturnDataPacket(const vData: OleVariant);
var
UAReturnPacket:TUARequestDataOutPacket;
rData:OleVariant;
aReturnData:TDataReturnParam;
aDataSheet:TDataSheetParam;
aRowSheet:TRowSheetParam;
i:integer;
aCds:TClientDataSet;
bFindRec,bCanAppend:Boolean;
// sKeys:string;
// vLocateValue:Variant;
iOldRecCount:integer;
iOpenRecCount:integer;
begin
//2004-03-05 bug fix for record cursor point error
iOldRecCount := RecordCount;
//2004-03-05 记录当前记录计数
bFindRec := false;
bCanAppend := false;
if not Assigned(MasterUAServiceClient) then
Exit;
UAReturnPacket := TUARequestDataOutPacket.Create;
try
UAReturnPacket.UAData := MasterUAServiceClient.UARequestDataOutPacket.UAData;
aReturnData := UAReturnPacket.GetItemReturnData(0);
if Assigned(aReturnData) and (not VarIsEmpty(aReturnData.UAData)) and
(VarIsArray(aReturnData.UAData)) and (not (VarCompareValue(aReturnData.UAData,Unassigned) = vrEqual)) then
begin
rData := aReturnData.Data;
AllRecCount := aReturnData.AllRecCount;
iOpenRecCount := aReturnData.CurrRecCount - iOldRecCount;
// 2004-03-05 fix by vinson zeng for location curren record
end;
if UAReturnPacket.CountRowSheet <> 0 then
//duplicate check
begin
for i := 0 to UAReturnPacket.CountRowSheet - 1do
begin
aRowSheet := TRowSheetParam.Create;
aRowSheet.UAData:= UAReturnPacket.GetItemRowSheet(i).UAData;
FRowSheetList.Add(aRowSheet);
end;
end;
if UAReturnPacket.CountDataSheet <> 0 then
begin
if not (ooQueryData in FOperateOptions) then
begin
FDataSheetList.Clear;
for i := 0 to UAReturnPacket.CountDataSheet -1do
begin
aDataSheet := TDataSheetParam.Create;
aDataSheet.UAData := UAReturnPacket.GetItemDataSheet(i).UAData;
FDataSheetList.Add(aDataSheet);
end;
end
else
begin
if FDataSheetList.Count = 1 then
// begin
process
begin
end;
end;
end;
if CheckOperateState(-1) then
begin
if ooQueryData in FOperateOptions then
begin
DisableControls;
//duplicate key value process
CloseAutoRequestNext(true);
aCds := TClientDataSet.Create(nil);
try
aCds.Data := rData;
if not aCds.Active then
aCds.Open;
aCds.First;
try
while not aCds.Eofdo
begin
if Pos(',',KeyFields) <> 0 then
begin
// raise Exception.Create('UA SDK not support data type'!);
//Multi PrimaryKey not Support
//2004-03-05 fix Multi Key Locate
end
else
begin
bFindRec := Self.Locate(KeyFields, aCds.FindField(KeyFields).Value, [loPartialKey]);
end;
if bFindRec then
begin
Self.Delete;
Self.MergeChangeLog;
end
else
aCds.Next;
end;
bCanAppend := true;
except
on E:Exceptiondo
begin
bCanAppend := false;
Showmessage('query data error!'+#13#10+ 'native error information is:'+E.Message);
end;
end;
finally
if bCanAppend then
begin
VarClear(rData);
rData := aCds.Data;
end;
if aCds.RecordCount = 0 then
begin
// modify by vinson zeng on 2004-01-02
if FConfirmNotFound then
// modify by vinson zeng on 2004-01-05
// MessageDlg('系统不存在与查询条件相匹配的记录，请确认！', mtInformation,[mbOk], 0);
Application.MessageBox('系统不存在与查询条件相匹配的记录，请确认！',PChar(Application.Title),MB_OK);
end;
if Assigned(aCds) then
FreeAndNil(aCds);
CloseAutoRequestNext(false);
EnableControls;
end;
end;
if ooRefreshAllData in FOperateOptions then
begin
CloseAutoRequestNext(true);
DisableControls;
try
try
EmptyDataSet;
MergeChangeLog;
except
end;
finally
CloseAutoRequestNext(false);
EnableControls;
end;
end;
if ooRefreshSelected in FOperateOptions then
begin
CloseAutoRequestNext(true);
DisableControls;
try
try
Delete;
MergeChangeLog;
except
end;
finally
CloseAutoRequestNext(false);
EnableControls;
end;
end;
if (not VarIsNull(rData)) and (not VarIsEmpty(rData)) then
begin
// modify by vinson zeng on 2004-01-02
AppendData(rData,false);
MergeChangeLog;
end;
// 2004-03-05 fix by vinson zeng not Sing
DisableControls;
CloseAutoRequestNext(true);
if ooQueryData in FOperateOptions then
MoveBy(iOldRecCount + 1);
// Rec Position OffSet Is 1
if ooRefreshAllData in FOperateOptions then
First;
if ooRefreshSelected in FOperateOptions then
Last;
CloseAutoRequestNext(false);
EnableControls;
end;
finally
if Assigned(UAReturnPacket) then
FreeAndNil(UAReturnPacket);
end;
end;
{-----------------------------------------------------------------------------
Procedure: TUAClientDataSet.RefreshAllData
Author: vinson zeng
Date: 05-三月-2003
Arguments: Sender: TObject;
const bAll :Boolean = false
Result: None
-----------------------------------------------------------------------------}
procedure TUAClientDataSet.RefreshAllData(Sender: TObject;
const bAll :Boolean = false);
var
sTmp:string;
begin
// bug fix by vinson zeng at 2003-11-03
if (RecordCount = 0 ) or (State = dsInactive) then
begin
{$ifdef CHNDEBUG}
// MessageDlg('不能执行此项操作，因为数据集没有激活或者记录为空！', mtWarning,[mbOk], 0);
Application.MessageBox('不能执行此项操作，因为数据集没有激活或者记录为空！',PChar(Application.Title),MB_OK);
{$else
}
MessageDlg('can notdo
operation，bacause not dataset active or dataset is empty!', mtWarning,[mbOk], 0);
{$endif}
Exit;
end;
if bAll then
Include(FOperateOptions,ooRefreshAllData)
else
Include(FOperateOptions,ooRefreshSelected);
try
if BuildRefreshDataScript(Sender,sTmp,bAll) then
begin
if Trim(sTmp) <> '' then
begin
try
SqlScript := '';
SqlScript := sTmp;
do
Request(0);
SqlScript := '';
except
end;
end;
end;
finally
if bAll then
Exclude(FOperateOptions,ooRefreshAllData)
else
Exclude(FOperateOptions,ooRefreshSelected);
end;
end;
procedure TUAClientDataSet.SetOpenAllData(const Value: Boolean);
begin
if ( csDesigning in ComponentState )then
Exit;
FOpenAllData := Value;
if FOpenAllData then
do
Request
else
begin
//do
other thing in here ,maybe close all uaclientdataset
end;
end;
procedure TUAClientDataSet.InternalCancel;
begin
inherited;
end;
procedure TUAClientDataSet.DoOnNewRecord;
begin
inherited;
end;
function TUAClientDataSet.GetDataInfo: string;
begin
Result := FDataInfo;
end;
procedure TUAClientDataSet.CloseAutoRequestNext(const bClose:Boolean = true);
begin
if bClose then
Exclude(FUAOptions,uoAutoRequestNext)
else
Include(FUAOptions,uoAutoRequestNext);
end;
procedure TUAClientDataSet.QueryData(Sender: TObject;const ClearData:Boolean = false);
begin
Include(FOperateOptions,ooQueryData);
try
try
if ClearData then
ClearAllData;
do
Request(0);
except
end;
finally
Exclude(FOperateOptions,ooQueryData);
end;
end;
{-----------------------------------------------------------------------------
Procedure: TUAClientDataSet.BuildRefreshDataScript
Author: vinson zeng
Date: 05-三月-2003
Arguments: Sender: TObject;var sSqlScript:string;const bAll :Boolean = false
Result: Boolean
-----------------------------------------------------------------------------}
function TUAClientDataSet.BuildRefreshDataScript(Sender: TObject;var sSqlScript:string;const bAll :Boolean = false):Boolean;
var
WhereClause,sTmp,s2:string;
lList:TStringList;
i:integer;
lField:TField;
SavePlace: TBookmark;
begin
// Result := false;
DisableControls;
CloseAutoRequestNext(true);
lList := TStringList.Create;
try
try
SavePlace := GetBookmark;
if bAll then
begin
First;
while not Eofdo
begin
if Trim(sSqlScript) <> '' then
sSqlScript := sSqlScript + ' or ';
WhereClause := '';
xStrSplit(KeyFields,[','],lList,true,true);
for i := 0 to lList.Count -1do
begin
sTmp := '';
if Trim(WhereClause) <> '' then
WhereClause := WhereClause + ' and ';
lField := FindField(lList.Strings);
sTmp := ' ('+ lField.FieldName + ' =';
if Assigned(lField) then
begin
if lField.DataType in [ftString, ftWideString] then
sTmp := sTmp + #39 + lField.AsString + #39 + ' )'
else
if lField.DataType in [ftDate,ftDateTime] then
begin
sTmp := sTmp + DateToStr(lField.AsDateTime) +' )';
end
else
sTmp := sTmp + VarToStr(lField.Value) +' )';
end;
if Trim(sTmp) <> '' then
WhereClause := WhereClause + sTmp;
end;
if Trim(WhereClause) <> '' then
begin
s2 := GetMasterLinkScript(Self);
if Trim(s2) <> '' then
WhereClause := ' ('+ WhereClause +' and '+ s2 +' )'
else
WhereClause := ' ('+ WhereClause +' )';
end;
sSqlScript := sSqlScript + WhereClause ;
Next;
end;
end;
if not bAll then
//如果是子表刷新
begin
xStrSplit(KeyFields,[','],lList,true,true);
for i := 0 to lList.Count -1do
begin
sTmp := '';
if Trim(WhereClause) <> '' then
WhereClause := WhereClause + ' and ';
lField := FindField(lList.Strings);
sTmp := ' ('+ lField.FieldName + ' =';
if Assigned(lField) then
begin
if lField.DataType in [ftString, ftWideString] then
sTmp := sTmp + #39 + lField.AsString + #39 + ' )'
else
if lField.DataType in [ftDate,ftDateTime] then
begin
sTmp := sTmp + DateToStr(lField.AsDateTime) +' )';
end
else
sTmp := sTmp + VarToStr(lField.Value) +' )';
end;
if Trim(sTmp) <> '' then
WhereClause := WhereClause + sTmp;
end;
if Trim(WhereClause) <> '' then
begin
s2 := GetMasterLinkScript(Self);
if Trim(s2) <> '' then
WhereClause := ' ('+ WhereClause +' and '+ s2 +' )'
else
WhereClause := ' ('+ WhereClause +' )';
end;
sSqlScript := sSqlScript + WhereClause ;
end;
Result := true;
except
on E:Exceptiondo
begin
Result := false;
end;
end;
finally
if Assigned(lList) then
FreeAndNil(lList);
GotoBookmark(SavePlace);
FreeBookmark(SavePlace);
EnableControls;
CloseAutoRequestNext(false);
end;
end;
{-----------------------------------------------------------------------------
Procedure: TUAClientDataSet.GetMasterLinkScript
Author: vinson zeng
Date: 05-三月-2003
Arguments: Sender: TObject
Result: string
-----------------------------------------------------------------------------}
function TUAClientDataSet.GetMasterLinkScript(Sender: TObject): string;
var
i:integer;
lList:TList;
aMasterDataSet:TDataSet;
MasterClause,s1:string;
begin
if (DataSetType = dtDetail) or (DataSetType = dtBoth) then
begin
aMasterDataSet := MasterSource.DataSet;
if Assigned(aMasterDataSet) then
begin
if DataSetField <> nil then
begin
end
else
begin
lList := TList.Create;
FMasterLinkList.Clear;
try
try
aMasterDataSet.GetFieldList(lList,MasterFields);
for i := 0 to lList.Count -1do
begin
with TField(lList.Items)do
begin
if Trim(MasterClause) <> '' then
MasterClause := MasterClause + ' and ';
if VarIsNull(Value) then
begin
s1 := ' ('+MasterClause + IndexFields.FieldName + ' Is Null'+' )';
Continue;
end
else
s1 := ' ('+ IndexFields.FieldName +' =';
if IndexFields.DataType in [ftString,ftWideString] then
begin
s1 := s1 + #39 + VarToStr(Value) + #39 +' )'
end
else
if IndexFields.DataType in [ftDate,ftDateTime] then
begin
s1 := s1 + DateToStr(VarToDateTime(Value)) +' )'
end
else
s1 := s1 + VarToStr(Value) +' )'
end;
MasterClause := MasterClause +s1;
end;
if Trim(MasterClause) <> '' then
MasterClause := '( '+ MasterClause +' )';
except
end;
finally
if Assigned(lList) then
FreeAndNil(lList);
if Trim(MasterClause) <> '' then
Result := MasterClause;
end;
end;
end;
end;
end;
{-----------------------------------------------------------------------------
Procedure: TUAClientDataSet.DeleteDetailRecords
Author: vinson zeng
Date: 05-三月-2003
Arguments: MasterDataSet:TUAClientDataSet
Result: None
-----------------------------------------------------------------------------}
procedure TUAClientDataSet.DeleteDetailRecords(MasterDataSet:TUAClientDataSet);
var
lList:TList;
i:integer;
lCds:TUAClientDataSet;
procedure DeleteAllSubDetailRecords(lDetail:TUAClientDataSet);
var
lSubDetail:TUAClientDataSet;
j:integer;
lList1:TList;
begin
lList1 := TList.Create;
try
with lDetaildo
begin
case DataSetType of
dtDetail:
begin
DisableControls;
CloseAutoRequestNext(true);
First;
while not Eofdo
Delete;
CloseAutoRequestNext(false);
EnableControls;
end;
dtBoth:
begin
GetDetailDataSets(lList1);
for j := 0 to lList1.Count -1do
begin
lSubDetail := TUAClientDataSet(lList1.Items[j]);
DeleteAllSubDetailRecords(lSubDetail);
end;
DisableControls;
CloseAutoRequestNext(true);
First;
while not Eofdo
Delete;
CloseAutoRequestNext(false);
EnableControls;
end;
end;
end;
finally
if Assigned(lList1) then
FreeAndNil(lList1);
end;
end;
begin
// must fix bug
if not Assigned(MasterDataSet) then
Exit;
if not MasterDataSet.Active then
Exit;
if MasterDataSet.RecordCount = 0 then
Exit;
lList := TList.Create;
try
try
MasterDataSet.GetDetailDataSets(lList);
for i := 0 to lList.Count -1do
begin
lCds := TUAClientDataSet(lList.Items);
with lCdsdo
begin
case DataSetType of
dtDetail:
begin
DisableControls;
CloseAutoRequestNext(true);
First;
while not Eofdo
Delete;
CloseAutoRequestNext(false);
EnableControls;
end;
dtBoth:
DeleteAllSubDetailRecords(lCds);
end;
end;
end;
except
on E:Exceptiondo
begin
Showmessage('Delete Detail Records Effect Error;Native Msg:'+E.Message);
end;
end;
finally
if Assigned(lList) then
FreeAndNil(lList);
end;
end;
function TUAClientDataSet.GetConfirmNotFound: Boolean;
begin
Result := FConfirmNotFound;
end;
procedure TUAClientDataSet.SetConfirmNotFound(const Value: Boolean);
begin
FConfirmNotFound := Value;
end;
function TUAClientDataSet.GetIndexFields(DataSet: TDataSet): string;
var
i:integer;
sTmp:string;
begin
for i := 0 to IndexFieldCount -1do
begin
if trim(sTmp) <> '' then
sTmp := sTmp + ',';
sTmp := sTmp + IndexFields.FieldName;
end;
if trim(sTmp) <> '' then
Result := ','+sTmp;
end;
{-----------------------------------------------------------------------------
Procedure: TUAClientDataSet.ClearAllData
Author: vinson zeng
Date: 05-三月-2003
Arguments: None
Result: None
-----------------------------------------------------------------------------}
procedure TUAClientDataSet.ClearAllData;
var
lList:TList;
i:integer;
sErrorCode:string;
procedure ClearDetailData(aDetail:TUAClientDataSet);
var
j:integer;
lList1:TList;
begin
with aDetaildo
begin
EmptyDataSet;
ClearAllParams;
//2004-03-13 add by vinson zeng
MergeChangeLog;
lList1 := TList.Create;
GetDetailDataSets(lList1);
try
for j := 0 to lList1.Count -1do
ClearDetailData(TUAClientDataSet(lList1.Items[j]));
finally
if Assigned(lList1) then
FreeAndNil(lList1);
end;
end;
end;
begin
lList := TList.Create;
try
try
case GetDataSetType of
dtDetail,dtSingle:
begin
EmptyDataSet;
ClearAllParams;
//2004-03-13 add by vinson zeng
MergeChangeLog;
end;
dtMaster,dtBoth:
begin
EmptyDataSet;
ClearAllParams;
//2004-03-13 add by vinson zeng
MergeChangeLog;
GetDetailDataSets(lList);
for i := 0 to lList.Count -1do
ClearDetailData(TUAClientDataSet(lList.Items));
end;
end;
except
on E:Exceptiondo
begin
sErrorCode := '-40001';
Showmessage('clear data error!'+#13+'error code is:'+sErrorCode
+#13#10+'native error information is:'+E.Message);
end;
end;
finally
if Assigned(lList) then
FreeAndNil(lList);
end;
end;
procedure TUAClientDataSet.SetUAAutoRequestNext(const Value: Boolean);
begin
FUAAutoRequestNext := Value;
end;
procedure TUAClientDataSet.SetDesignActive(const Value: Boolean);
begin
if not Value then
begin
FDesignActive := Value;
Exit;
end;
if Value <> FDesignActive then
begin
if Value then
begin
try
do
DesignActive;
FDesignActive := Value;
except
on E:Exceptiondo
begin
end;
end;
end;
end;
end;
procedure TUAClientDataSet.DoDesignActive;
var
i:integer;
vOut:OleVariant;
aTmpCDS:TClientDataSet;
begin
if not (csDesigning in ComponentState) then
Exit;
aTmpCDS := TClientDataSet.Create(nil);
try
MasterUAServiceClient.UAServiceAdapter.Request('srvobjdesign','requesttblstrus',AliasTableName+'-'+MasterUAServiceClient.UAServiceAdapter.DefaultDBName,vOut);
if (not VarIsEmpty(vOut)) and (VarCompareValue(vOut,Unassigned)<>vrEqual) then
begin
aTmpCDS.Data := vOut;
aTmpCDS.Active := true;
if Self.FieldDefs.Count = 0 then
begin
for i := 0 to aTmpCDS.FieldDefs.Count -1do
begin
with Self.FieldDefs.AddFieldDefdo
begin
Name := aTmpCDS.FieldDefs.Name;
DataType := aTmpCDS.FieldDefs.DataType;
Size := aTmpCDS.FieldDefs.Size;
Precision := aTmpCDS.FieldDefs.Size;
Attributes := aTmpCDS.FieldDefs.Attributes;
Required := aTmpCDS.FieldDefs.Required;
DisplayName := aTmpCDS.FieldDefs.DisplayName;
end;
end;
end
else
begin
for i := 0 to aTmpCDS.FieldDefs.Count -1do
begin
if Self.FieldDefs.Find(aTmpCDS.FieldDefs.Name) = nil then
begin
with Self.FieldDefs.AddFieldDefdo
begin
Name := aTmpCDS.FieldDefs.Name;
DataType := aTmpCDS.FieldDefs.DataType;
Size := aTmpCDS.FieldDefs.Size;
Precision := aTmpCDS.FieldDefs.Size;
Attributes := aTmpCDS.FieldDefs.Attributes;
Required := aTmpCDS.FieldDefs.Required;
DisplayName := aTmpCDS.FieldDefs.DisplayName;
end;
end;
end;
end;
Self.CreateDataSet;
end;
finally
if Assigned(aTmpCDS) then
FreeAndNil(aTmpCDS);
if MasterUAServiceClient.UAServiceAdapter.Connected then
MasterUAServiceClient.UAServiceAdapter.Connected := false;
if Self.FieldDefs.Count <> 0 then
else
begin
MessageDlg('request table structure fail,please try again!',mtWarning,[mbOk], 0);
FDesignActive := false;
end;
end;
end;
{ TUAFieldsDesigner }
constructor TUAFieldsDesigner.Create;
begin
inherited;
end;
function TUAFieldsDesigner.GetOwnerDataSet: TUAClientDataSet;
begin
Result := FOwnerDataSet;
end;
procedure TUAFieldsDesigner.SetOwnerDataSet(const Value: TUAClientDataSet);
begin
FOwnerDataSet := Value;
end;
end.