基于Midas 技术的多层应用开发包！(0分)

各位老兄：
本人从事Delphi的多层开发多年，现已经开发了一套基于Midas技术的
多层数据库应用开发包（解决了接口发布的痛苦问题，对于应用业务逻辑修改，
开发设计人员不必再担心此问题！实现真正的应用层服务器对象无状态，
体现于在大量数据下栽的分段处理技术，实现了真正的事务同步处理，这可体现
在多表更新，同时执行触发代码！而且事务的控制是在应用层，不在后台数据库！
使用自有的协议数据包，安全性能得到提高！）
在这种架构下开发多层应用，和以前的C/S开发技术难度一样！
在这种架构下，可以将以前的C/S系统迅速移植到多层结构中！
但在我的开发包发布的问题上，我一直没有好的方案，麻烦各位
给点好注意。

{*************************************************************}
{ }
{ Universal Agent on demond SDK }
{ }
{ }
{ Copyright (c) 2001-2003 vinson zeng All Rights Reserved. }
{ }
{ }
{ }
{*************************************************************}
/// Bug report...

/// Modify History...

unit uaSrvObj;
interface
uses
Windows, Messages, SysUtils, Classes, ComServ, ComObj,
VCLCom,DataBkr,DBClient,StdVcl,AdoDb,Contnrs,Variants,
Provider,Forms,Db,
uaSrvObjDbConn,UADataPacket,UAServiceObjectPool;
type

TOperationType = (otRequest,otUpdate,otExecute);
CharSet = set of Char;

TUAUpdateType =(upModifyAll,upModifyOne,upInsert,
upDeleteAll,upDeleteOne);
TUAUpdateTypes = set of TUAUpdateType;
TUAUpdateErrorCode =(ueOk,
ueSelectSql,
ueModChanged,
ueModOneButMany,
ueModOneSql,
ueModManySql,
ueInsSql,
ueInsExit,
ueDelNonExit,
ueDelOneButMany,
ueDelOneSql,
ueDelManySql);

TuaServerObject = class(TComponent)
private
FPrepare:Boolean;
FOperationTypes:TOperationType;
FCurrServiceName:string;
FAliasSrvObjName: string;
procedure SetPrepare(const Value: Boolean);
procedure SetOperationType(const Value: TOperationType);
procedure SetCurrServiceName(const Value: string);
function GetCurrServiceName: string;
procedure SetAliasSrvObjName(const Value: string);
protected
FUARequestDataInPacket:TUARequestDataInPacket;
FUARequestDataOutPacket:TUARequestDataOutPacket;
FUAUpdateDataInPacket:TUAUpdateDataInPacket;
FUAUpdateDataOutPacket:TUAUpdateDataOutPacket;
FUAExecuteDataInPacket:TUAExecuteDataInPacket;
FUAExecuteDataOutPacket:TUAExecuteDataOutPacket;

function SubmitDelta(lAdoConn:TAdoConnection;sTblName:string;cdsSrc:TClientDataSet;
lFieldKeys:array of string;UpdateType:TUAUpdateTypes;
iFailMax:integer;var uaOut:TUAUpdateDataOutPacket):integer;virtual;

//分析不好
procedure AfterTriggerForDataSet(TableName:string;SrcDS:TDataSet;DestDS:TDataSet;var bHandle:Boolean);virtual;
procedure BeforeTriggerForDataSet(TableName:string;SrcDS:TDataSet;DestDS:TDataSet;var bHandle:Boolean);virtual;
// %% end of %% --------------

procedure BeforeRequest(Sender:TObject;var bHandle:Boolean);virtual;
procedure AfterRequest(Sender:TObject;var bContinue:Boolean);virtual;
procedure BeforeUpdate(Sender:TObject;var bHandle:Boolean);virtual;
procedure AfterUpdate(Sender:TObject;var bContinue:Boolean);virtual;
procedure BeforeExecute(Sender:TObject;var bHandle:Boolean);virtual;
procedure AfterExecute(Sender:TObject;var bContinue:Boolean);virtual;
procedure StartSyncTrans;
procedure CommitSyncTrans;
procedure RollbackSyncTrans;
function InSyncTrans:Boolean;
procedure LockDbConnection;
procedure UnLockDbConnection;
function SubmitAllDelta(bStartTrans:Boolean;AllDelta:OleVariant):integer;
function BuildDeltaArray(aUAUpdateDataInPacket:TUAUpdateDataInPacket):Variant;
function GetAllRecCount(var TableName:string;const sWhere:string= ''):integer;
function RequestData(Sender:TObject;var vOutData:OleVariant):integer;
function GetTableStru(vDataIn:OleVariant;var vOutData:OleVariant):integer;
//fix by vinson zeng at 2003-10-03
function BuildMasterLinkSqlScript(aUARequestInPacket:TUARequestDataInPacket):string;
function BuildRowSheetSqlScript(aUARequestInPacket:TUARequestDataInPacket):string;
function ReleaseAllDS(adoDS:TAdoDataSet;Dsp:TDataSetProvider;Cds:TClientDataSet):integer;
function RefreshData(Sender:TObject;var vOutData:OleVariant):integer;
function QueryData(Sender:TObject;var vOutData:OleVariant):integer;
function _GetBasicClientInfo(var vDataIn:OleVariant):string;

function OpenSrvData(adoDS:TAdoDataSet;Dsp:TDataSetProvider;Cds:TClientDataSet):integer;
function ExecAnySql(OperationType:TOperationType;sSql:string):integer;
function ExecuteProc(ProcName:string;DbConn:TAdoConnection;vParamField:array of string;
vParamValue: array of Variant;const iWait:integer = 0;const bStartTrans:Boolean = true):integer;
virtual;
//add on 2003-10-16
procedure CheckUAError(OperationType:TOperationType;iErrorCode:integer;sErrorMsg:string;var sErrorContext:string);
function GetUAErrorCount(OperationType:TOperationType):integer;
function RequestCustomData(ServiceName:WideString;vcInData:OleVariant;var vcOutData:OleVariant):integer;virtual;abstract;
function UpdateCustomDelta(ServiceName:WideString;vcInData:OleVariant;var vcOutData:OleVariant):integer;virtual;abstract;
procedure InitForRequest(var DataIn:OleVariant;var DataOut:OleVariant);virtual;
procedure InitForUpdate (var DataIn:OleVariant;var DataOut:OleVariant);virtual;
procedure InitForExecute(var DataIn:OleVariant;var DataOut:OleVariant);virtual;
public
FSyncTransaction:Boolean;
DbConnection:TAdoConnection;
constructor Create;
virtual;
destructor Destroy;
override;
proceduredo
WithSrvObj(SrvObjName:string;OperationType:TOperationType;ServiceName:string;const IpAddress:string = 'Local';const IsSyncTrans:Boolean = true);virtual;
procedure Request(ServiceName: WideString;
DataIn: OleVariant;var DataOut: OleVariant);
virtual;
procedure Update (ServiceName: WideString;
DataIn: OleVariant;var DataOut: OleVariant);
virtual;
procedure Execute(ServiceName: WideString;
DataIn: OleVariant;var DataOut: OleVariant);
virtual;
property Prepare:Boolean read FPrepare write SetPrepare default false;
property OperationTypes:TOperationType read FOperationTypes write SetOperationType;
property CurrServiceName:string read GetCurrServiceName write SetCurrServiceName;
property AliasSrvObjName:string read FAliasSrvObjName write SetAliasSrvObjName;
end;

const
TUAUpdateErrorMsg : array [0..11] of string =
('成功',
'原来选择的SQL语句执行错误',
'要修改的记录已经被修改',
'修改一条记录，但是存在多条记录',
'修改一条记录的时候，SQL语句执行错误',
'修改多条记录的时候，SQL语句执行错误',
'插入一条记录，SQL语句执行错误',
'插入的记录已经存在',
'要删除的记录不存在',
'删除一条记录，但是存在多条记录',
'删除一条记录，SQL语句执行错误',
'删除多条记录，SQL语句执行错误');
function FieldValueToSqlStr(lDataType: TFieldType;aValue: Variant): string;
function GenSelectDS(sTableName:string;cdsSrc:TClientDataSet;lFieldKeys: array of string):string;

{*************************************************************}
{ }
{ Universal Agent on demond SDK }
{ }
{ }
{ Copyright (c) 2001-2003 vinson zeng All Rights Reserved. }
{ }
{ }
{ }
{*************************************************************}
unit UAClientDataSet;
interface
uses
Windows, Variants, ActiveX, Classes,
Dialogs,DBClient,DB,SysUtils,DSIntf,
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;
CharSet = set of Char;
TUAClientDataSet = class;
TUAClientDataSet = class(TClientDataSet)
private
FAllRecCount:Integer;
FUAServiceClient:TUAServiceClient;
FAliasTableName:string;
FKeyFields:string;
FFetchNextDataPacket:Boolean;
FCanUpdate:Boolean;
FBeforeRequest:TNotifyEvent;
FAfterRequest:TRemoteServiceEvent;
FBeforeUpdate:TNotifyEvent;
FAfterUpadte:TNotifyEvent;
FUAOptions:TUAOptions;
FOperateOptions:TOperateOptions;
FUpdateErrorEvent:TUpdateErrorEvent;
FDesignTimeActive:Boolean;
FSqlScript:string;
FOpenAllData:Boolean;
FDataInfo:string;
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 SetDesignTimeActive(const Value: Boolean);
procedure SetSqlScript(const Value: string);
procedure SetOpenAllData(const Value: Boolean);
function GetDataInfo: string;
protected
FDataSheetList:TUAParams;
FRowSheetList:TUAParams;
FMasterLinkList:TUAParams;
function GetDataSetType:Integer;
procedure CheckNextDataPacket;
virtual;
procedure CheckForUpdate;
function CheckOperateState(const OperateIndex:integer = -1):Boolean;
procedure CancelSubmitAllDelta;
function GetMasterUAServiceClient:TUAServiceClient;
function DesignTimeRequest(const RequestIndex:Integer= -1):integer;
procedure DeleteDetailRecords(MasterDataSet:TUAClientDataSet);virtual;
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);
//----Inherited from TCustomClientDataSet---------
procedure DataEvent(Event: TDataEvent;
Info: Longint);
override;
procedure AddDataPacket(const Data: OleVariant;
HitEOF: Boolean);
override;
procedure GetDetailLinkFields(MasterFields, DetailFields: TList);
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 QueryData(Sender:TObject);
function do
Request(const RequestIndex:Integer= -1):OleVariant;virtual;
procedure do
Update (const UpdateIndex:Integer = -1);virtual;
procedure ClearAllParams;
procedure CloseAutoRequestNext(bClose:Boolean);
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[];
published
//-----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 DesignTimeActive:Boolean read FDesignTimeActive write SetDesignTimeActive default false;
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;
//-----------%% end of %%--------------------
end;

{*************************************************************}
{ }
{ Universal Agent on demond SDK }
{ }
{ }
{ Copyright (c) 2001-2003 vinson zeng All Rights Reserved. }
{ }
{ }
{ }
{*************************************************************}
unit UAServiceClient;

interface
uses
SysUtils, Messages, Classes, Dialogs,Forms,
UAServiceAdapter,UADataPacket,Variants,
UAUnits,uaErrorDlg;
type
TBeforeCallSrvObjService = procedure (Sender:TObject) of Object;
TAfterCallSrvObjService = procedure (Sender:TObject;
var bHandle:Boolean) of Object;

TUAServiceClient = class(TComponent)
private
FSrvObjName:string;
FUAServiceAdapter:TUAServiceAdapter;
FActive:Boolean;
FBeforeCallSrvObjForRequest:TBeforeCallSrvObjService;
FAfterCallSrvObjForRequest:TAfterCallSrvObjService;
FBeforeCallSrvObjForUpdate:TBeforeCallSrvObjService;
FAfterCallSrvObjForUpdate:TAfterCallSrvObjService;
FBeforeCallSrvObjForExecute:TBeforeCallSrvObjService;
FAfterCallSrvObjForExecute:TAfterCallSrvObjService;
FUARequestDataInPacket:TUARequestDataInPacket;
FUARequestDataOutPacket:TUARequestDataOutPacket;
FUAUpdateDataInPacket:TUAUpdateDataInPacket;
FUAUpdateDataOutPacket:TUAUpdateDataOutPacket;
FUAExecuteDataInPacket:TUAExecuteDataInPacket;
FUAExecuteDataOutPacket:TUAExecuteDataOutPacket;
function GetUAServiceAdapter: TUAServiceAdapter;
procedure SetUAServiceAdapter(const Value: TUAServiceAdapter);
function GetActive: Boolean;
procedure SetActive(const Value: Boolean);
function GetSrvObjName: string;
procedure SetSrvObjName(const Value: string);
function GetUAExecuteDataInPacket: TUAExecuteDataInPacket;
function GetUAExecuteDataOutPacket: TUAExecuteDataOutPacket;
function GetUARequestDataInPacket: TUARequestDataInPacket;
function GetUARequestDataOutPacket: TUARequestDataOutPacket;
function GetUAUpdateDataInPacket: TUAUpdateDataInPacket;
function GetUAUpdateDataOutPacket: TUAUpdateDataOutPacket;
protected
FuaErrorHandler:TuaErrorHandler;
procedure Notification(AComponent: TComponent;Operation: TOperation);
override;
function CheckServiceProp(Sender:TObject):Boolean;
function CheckErrorLevel(iType:integer;var vReturnValue:OleVariant):integer;
procedure RaiseUAErrorMsg(Sender:TObject;iType:integer;var vValue:OleVariant);
public
constructor Create(AOwner: TComponent);
override;
destructor Destroy;
override;
procedure ClearRequestParams;
procedure ClearUpdateParams;
procedure ClearExecueParams;
function do
Request(ServiceName:string;const RequestIndex:Integer= -1):integer;
function do
Update (ServiceName:string;const iUpdateIndex:Integer = -1):integer;virtual;
function do
Execute(ServiceName:string):integer;virtual;
property UARequestDataInPacket:TUARequestDataInPacket read GetUARequestDataInPacket;
property UARequestDataOutPacket:TUARequestDataOutPacket read GetUARequestDataOutPacket;
property UAUpdateDataInPacket:TUAUpdateDataInPacket read GetUAUpdateDataInPacket;
property UAUpdateDataOutPacket:TUAUpdateDataOutPacket read GetUAUpdateDataOutPacket;
property UAExecuteDataInPacket:TUAExecuteDataInPacket read GetUAExecuteDataInPacket;
property UAExecuteDataOutPacket:TUAExecuteDataOutPacket read GetUAExecuteDataOutPacket;
published
property Active:Boolean read GetActive write SetActive default false;
property UAServiceAdapter:TUAServiceAdapter read GetUAServiceAdapter write SetUAServiceAdapter;
property SrvObjName:string read GetSrvObjName write SetSrvObjName;
property BeforeCallSrvObjForRequest:TBeforeCallSrvObjService read FBeforeCallSrvObjForRequest write FBeforeCallSrvObjForRequest;
property AfterCallSrvObjForRequest:TAfterCallSrvObjService read FAfterCallSrvObjForRequest write FAfterCallSrvObjForRequest;
property BeforeCallSrvObjForUpdate:TBeforeCallSrvObjService read FBeforeCallSrvObjForUpdate write FBeforeCallSrvObjForUpdate;
property AfterCallSrvObjForUpdate:TAfterCallSrvObjService read FAfterCallSrvObjForUpdate write FAfterCallSrvObjForUpdate;
property BeforeCallSrvObjForExecute:TBeforeCallSrvObjService read FBeforeCallSrvObjForExecute write FBeforeCallSrvObjForExecute;
property AfterCallSrvObjForExecute:TAfterCallSrvObjService read FAfterCallSrvObjForExecute write FAfterCallSrvObjForExecute;
end;

implementation
{ TUAServiceClient }
function TUAServiceClient.CheckErrorLevel(iType: integer;var vReturnValue: OleVariant): integer;
var
aRequest:TUARequestDataOutPacket;
aUpdate:TUAUpdateDataOutPacket;
aExecute:TUAExecuteDataOutPacket;
begin

//0 Request 1 Update 2:Execute
case iType of
0: begin
aRequest := TUARequestDataOutPacket.Create;
try
try
aRequest.UAData := vReturnValue;
Result := aRequest.ResultCode;
except
Result := -10003
end
finally
if Assigned(aRequest) then
FreeAndNil(aRequest);
end;
end;
1: begin
aUpdate := TUAUpdateDataOutPacket.Create;
try
try
aUpdate.UAData := vReturnValue;
Result := aUpdate.ResultCode;
except
Result := -10003
end;
finally
if Assigned(aUpdate) then
FreeAndNil(aUpdate);
end;
end;
2: begin
aExecute := TUAExecuteDataOutPacket.Create;
try
try
aExecute.UAData := vReturnValue;
Result := aExecute.ResultCode;
except
Result := -10003
end;
finally
if Assigned(aExecute) then
FreeAndNil(aExecute);
end;
end;
end;

end;

function TUAServiceClient.CheckServiceProp(Sender: TObject): Boolean;
begin
Result := true;
if not Assigned(FUAServiceAdapter) then
Result := false;
end;

procedure TUAServiceClient.ClearExecueParams;
begin
UAExecuteDataInPacket.ClearAllUaData;
UAExecuteDataOutPacket.ClearAllUaData;
end;

procedure TUAServiceClient.ClearRequestParams;
begin
UARequestDataInPacket.ClearAllUaData;
UARequestDataOutPacket.ClearAllUaData;
end;

procedure TUAServiceClient.ClearUpdateParams;
begin
UAUpdateDataInPacket.ClearAllUaData;
UAUpdateDataOutPacket.ClearAllUaData;
end;

constructor TUAServiceClient.Create(AOwner: TComponent);
begin
inherited;
FActive := false;
FUARequestDataInPacket := TUARequestDataInPacket.Create;
FUARequestDataOutPacket:= TUARequestDataOutPacket.Create;
FUAUpdateDataInPacket := TUAUpdateDataInPacket.Create;
FUAUpdateDataOutPacket := TUAUpdateDataOutPacket.Create;
FUAExecuteDataInPacket := TUAExecuteDataInPacket.Create;
FUAExecuteDataOutPacket:= TUAExecuteDataOutPacket.Create;
FuaErrorHandler := TuaErrorHandler.Create(Self);
FuaErrorHandler.LogFile := Application.Name + '_ErrorLog';

end;

destructor TUAServiceClient.Destroy;
begin

FUARequestDataInPacket.Free ;
FUARequestDataOutPacket.Free;
FUAUpdateDataInPacket.Free ;
FUAUpdateDataOutPacket.Free ;
FUAExecuteDataInPacket.Free ;
FUAExecuteDataOutPacket.Free;
FuaErrorHandler.Free;
inherited;
end;

function TUAServiceClient.DoExecute(ServiceName:string):integer;
var
bContinue:Boolean;
vOut:OleVariant;
begin
bContinue := false;
if (trim(ServiceName) = '') or (trim(SrvObjName) ='') then
Exit;
if not CheckServiceProp(Self) then
begin
MessageDlg('do not finish service define,please check!', mtError,[mbOk], 0);
Exit;
end;

if Assigned(FBeforeCallSrvObjForExecute) then
FBeforeCallSrvObjForExecute(Self);
//do Execute in here
UAServiceAdapter.Execute(SrvObjName,ServiceName,UAExecuteDataInPacket.UAData,vOut);
if Assigned(FAfterCallSrvObjForExecute) then
FAfterCallSrvObjForExecute(Self,bContinue);
if CheckErrorLevel(2,vOut) <> 0 then
begin
RaiseUAErrorMsg(Application,2,vOut);
VarClear(vOut);
Result := -1;
end;

if not bContinue then
begin
if (VarCompareValue(vOut,Unassigned)<> vrEqual) and
(VarIsArray(vOut)) and (not VarIsEmpty(vOut)) then
UAExecuteDataOutPacket.UAData := vOut;
end;

end;

function TUAServiceClient.DoRequest(ServiceName:string;const RequestIndex:Integer= -1):integer;
var
bContinue:Boolean;
vOut:OleVariant;
begin

bContinue := false;
if (trim(ServiceName) = '') or (trim(SrvObjName) ='') then
Exit;
if not CheckServiceProp(Self) then
begin
MessageDlg('do not finish service define,please check!', mtError,[mbOk], 0);
Exit;
end;

// must clear all request params before call request service
UARequestDataInPacket.RequestType := RequestIndex;
if Assigned(FBeforeCallSrvObjForRequest) then
FBeforeCallSrvObjForRequest(Self);
//do request in here
UAServiceAdapter.Request(SrvObjName,ServiceName,UARequestDataInPacket.UAData,vOut);
if Assigned(FAfterCallSrvObjForRequest) then
FAfterCallSrvObjForRequest(Self,bContinue);
// can be handle all by for programerdo
he define code;
if CheckErrorLevel(0,vOut) <> 0 then
begin
RaiseUAErrorMsg(Application,0,vOut);
VarClear(vOut);
Result := -1;
end;

if not bContinue then
begin
if (VarCompareValue(vOut,Unassigned)<> vrEqual) and
(VarIsArray(vOut)) and (not VarIsEmpty(vOut)) then
UARequestDataOutPacket.UAData := vOut;
if (RequestIndex = -1 ) or (RequestIndex = 1) then
begin
// blank notdo
anything
end;
end;

end;

function TUAServiceClient.DoUpdate(ServiceName:string;const iUpdateIndex:Integer = -1):integer;
var
bContinue:Boolean;
vOut:OleVariant;
begin

bContinue := false;
if (trim(ServiceName) = '') or (trim(SrvObjName) ='') then
Exit;
if not CheckServiceProp(Self) then
begin
MessageDlg('do not finish service define,please check!', mtError,[mbOk], 0);
Exit;
end;

UAUpdateDataInPacket.UpdateIndex := iUpdateIndex;
if Assigned(FBeforeCallSrvObjForUpdate) then
FBeforeCallSrvObjForUpdate(Self);

//do update in here
UAServiceAdapter.Update(SrvObjName,ServiceName,UAUpdateDataInPacket.UAData,vOut);

if Assigned(FAfterCallSrvObjForUpdate) then
FAfterCallSrvObjForUpdate(Self,bContinue);
if CheckErrorLevel(1,vOut) <> 0 then
begin

RaiseUAErrorMsg(Application,1,vOut);
VarClear(vOut);
Result := -1;
end;

if not bContinue then
begin
if (VarCompareValue(vOut,Unassigned)<> vrEqual) and
(VarIsArray(vOut)) and (not VarIsEmpty(vOut)) then

UAUpdateDataOutPacket.UAData := vOut;
end;

end;

function TUAServiceClient.GetActive: Boolean;
begin
Result := FActive;
end;

function TUAServiceClient.GetSrvObjName: string;
begin
Result := FSrvObjName;
end;

function TUAServiceClient.GetUAExecuteDataInPacket: TUAExecuteDataInPacket;
begin
Result := FUAExecuteDataInPacket;
end;

function TUAServiceClient.GetUAExecuteDataOutPacket: TUAExecuteDataOutPacket;
begin
Result := FUAExecuteDataOutPacket;
end;

function TUAServiceClient.GetUARequestDataInPacket: TUARequestDataInPacket;
begin
Result := FUARequestDataInPacket;
end;

function TUAServiceClient.GetUARequestDataOutPacket: TUARequestDataOutPacket;
begin
Result := FUARequestDataOutPacket;
end;

function TUAServiceClient.GetUAServiceAdapter: TUAServiceAdapter;
begin
Result := FUAServiceAdapter;
end;

function TUAServiceClient.GetUAUpdateDataInPacket: TUAUpdateDataInPacket;
begin
Result := FUAUpdateDataInPacket;
end;

function TUAServiceClient.GetUAUpdateDataOutPacket: TUAUpdateDataOutPacket;
begin
Result := FUAUpdateDataOutPacket;
end;

procedure TUAServiceClient.Notification(AComponent: TComponent;
Operation: TOperation);
begin

inherited Notification(AComponent, Operation);
if (Operation = opRemove) and (AComponent = FUAServiceAdapter) then
FUAServiceAdapter := nil;
end;

procedure TUAServiceClient.RaiseUAErrorMsg(Sender:TObject;iType:integer;var vValue:OleVariant);
const
sRequestError :string = '远程数据下载请求发生错误！';
sUpdateError :string = '远程数据更新请求发生错误！';
sExecuteError :string = '远程事务执行请求发生错误！';
sCaption :string = 'UA 错误信息';
var
sDesc:string;
sMsg:string;
function BuildErrorDesc(iType:integer;var vValue:OleVariant;var sMsg:string):string;
var
aRequestValue:TUARequestDataOutPacket;
aUpdateValue:TUAUpdateDataOutPacket;
aExecuteValue:TUAExecuteDataOutPacket;
i:integer;
aErrorParam:TErrorParam;
begin
case iType of
0: begin
aRequestValue := TUARequestDataOutPacket.Create;
try
aRequestValue.UAData := vValue;
if aRequestValue.CountErrorParam <> 0 then
begin
for i := 0 to aRequestValue.CountErrorParam -1do
begin
aErrorParam := aRequestValue.GetItemErrorParam(i);
if Trim(Result) <> '' then
Result := Result + #13#10;
Result := Result + '错误提示'+ IntToStr(i)+'：'+ '['+aErrorParam.ErrorMsg+']' + #13#10 +
Format('Error Code : %s ,Error Comtext Is : %s',[IntToStr(aErrorParam.ErrorCode),aErrorParam.ErrorContext]);
end;
end;

finally
if Assigned(aRequestValue) then
FreeAndNil(aRequestValue);
end;

end;
1: begin
aUpdateValue := TUAUpdateDataOutPacket.Create;
try
aUpdateValue.UAData := vValue;
if aUpdateValue.CountErrorParam <> 0 then
begin
for i := 0 to aUpdateValue.CountErrorParam -1do
begin
aErrorParam := aUpdateValue.GetItemErrorParam(i);
if Trim(Result) <> '' then
Result := Result + #13#10;
Result := Result + '错误提示'+ IntToStr(i)+'：'+ '['+aErrorParam.ErrorMsg+']' + #13#10 +
Format('Error Code : %s ,Error Context Is : %s',[IntToStr(aErrorParam.ErrorCode),aErrorParam.ErrorContext]);
end;
end;

finally
if Assigned(aUpdateValue) then
FreeAndNil(aUpdateValue);
end;

end;
2: begin
aExecuteValue := TUAExecuteDataOutPacket.Create;
try
aExecuteValue.UAData := vValue;
if aExecuteValue.CountErrorParam <> 0 then
begin
for i := 0 to aExecuteValue.CountErrorParam -1do
begin
aErrorParam := aExecuteValue.GetItemErrorParam(i);
if Trim(Result) <> '' then
Result := Result + #13#10;
Result := Result + '错误提示'+ IntToStr(i)+'：'+ '['+aErrorParam.ErrorMsg+']' + #13#10 +
Format('Error Code : %s ,Error Context Is : %s',[IntToStr(aErrorParam.ErrorCode),aErrorParam.ErrorContext]);
end;
end;

finally
if Assigned(aUpdateValue) then
FreeAndNil(aUpdateValue);
end;

end;
end;

end;
begin

sDesc := BuildErrorDesc(iType,vValue,sMsg);
Application.ProcessMessages;
case iType of
0:FuaErrorHandler.ShowMessage(sCaption,sRequestError,sMsg,sDesc);
1:FuaErrorHandler.ShowMessage(sCaption,sUpdateError,sMsg,sDesc);
2:FuaErrorHandler.ShowMessage(sCaption,sExecuteError,sMsg,sDesc);
end;

end;

procedure TUAServiceClient.SetActive(const Value: Boolean);
begin

if Assigned(FUAServiceAdapter) then
begin
FActive := Value;
if FActive then
FUAServiceAdapter.Connected := true
else
FUAServiceAdapter.Connected := false;
end
else
begin
MessageDlg('can not active because no exist UAServiceAdapter Object!', mtWarning ,[mbOk], 0);
Exit;
end;

end;

procedure TUAServiceClient.SetSrvObjName(const Value: string);
begin
if Trim(Value) <> '' then
FSrvObjName := Value
else
FSrvObjName := '';
end;

procedure TUAServiceClient.SetUAServiceAdapter(
const Value: TUAServiceAdapter);
begin
if Value <> nil then
FUAServiceAdapter := Value
else
FUAServiceAdapter := nil;

end;

end.

{*************************************************************}
{ }
{ Universal Agent on demond SDK }
{ }
{ }
{ Copyright (c) 2001-2003 vinson zeng All Rights Reserved. }
{ }
{ }
{ }
{*************************************************************}

unit UAServiceAdapter;
interface
uses
SysUtils, Messages, Classes, Sconnect,Dialogs,
Windows,Controls{$ifdef Ver140},Variants{$endif}
,Forms,UAUnits,Registry;
type
TInternetProtocol = (ipFtp,ipHttp,ipSocks4,ipSocks5);
TCompressType = (ctHigh,ctNormal,ctFast);
TDataPacketType = (dptUA,dptXML,dptBinary);
TUAServiceAdapter = class;
TProxyServer = class(TPersistent)
private
FServerName:string;
FPort:string;
FUserName:string;
FPassword:string;
FInternetProtocol:TInternetProtocol;
function GetInternetProtocol: TInternetProtocol;
procedure SetInternetProtocol(const Value: TInternetProtocol);
procedure SetPassword(const Value: string);
procedure SetPort(const Value: string);
procedure SetServerName(const Value: string);
procedure SetUserName(const Value: string);
public

procedure Assign(Source: TPersistent);
override;

published
property ServerName:string read FServerName write SetServerName;
property Port:string read FPort write SetPort;
property UserName:string read FUserName write SetUserName;
property Password:string read FPassword write SetPassword;
property InternetProtocol:TInternetProtocol read GetInternetProtocol write SetInternetProtocol ;
end;

TuaSocketThread = class(TThread)
private
FUAServiceAdapter:TUAServiceAdapter;
FSemaphore: THandle;
protected
proceduredo
Terminate;
override;
public
constructor Create(CreateSuspended: Boolean;aUAServiceAdapter:TUAServiceAdapter);
destructor Destroy;
override;
property Semaphore: THandle read FSemaphore;
procedure Execute;
override;
end;

TusSocket = class(TObject)
protected
public

end;


TUAServiceAdapter = class(TComponent)
private
FSckt: TSocketConnection;
FError: string;
FWaitTimes:Cardinal;
FTryConnectTimes:LongInt;
FConnected:Boolean;
FProxyServer:TProxyServer;
FDataPacketEncrypt:Boolean;
FCompressType: TCompressType;
FIsLocalNet:Boolean;
FDataPacketType:TDataPacketType;
FOleObject:Variant;
function GetAddress: string;
function GetIntercept: string;
function GetOleObject: Variant;
function GetServer: string;
procedure SetAddress(const Value: string);
procedure SetIntercept(const Value: string);
procedure SetServer(const Value: string);
function GetPort: integer;
procedure SetPort(const Value: integer);
procedure SetOleObject(const Value: Variant);
function GetDispatchObject: IDispatch;
procedure SetDispatchObject(const Value: IDispatch);
function GetTryConnectTimes: LongInt;
function GetWaitTimes: Cardinal;
procedure SetTryConnectTimes(const Value: LongInt);
procedure SetWaitTimes(const Value: Cardinal);
procedure SetConnected(const Value: Boolean);
function GetConnected: Boolean;
procedure SetProxyServer(const Value: TProxyServer);
procedure SetDataPacketEncrypt(const Value: Boolean);
procedure SetCompressType(const Value: TCompressType);
procedure SetIsLocalNet(const Value: Boolean);
function GetDataPacketType: TDataPacketType;
procedure SetDataPacketType(const Value: TDataPacketType);
protected
FuaSocketThread:TuaSocketThread;
function do
Connect:Boolean;
function do
DisConnect:Boolean;
function TryConnectToServer:Boolean;
property OleObject: Variant read GetOleObject write SetOleObject;
property DispatchObject: IDispatch read GetDispatchObject write SetDispatchObject;
property Intercept: string read GetIntercept write SetIntercept;
public
constructor Create(AOwner: TComponent);
override;
destructor Destroy;
override;
procedure Loaded;
override;
function ExecuteNetworkSetting(Sender:TComponent):Boolean;
function ReadClientSetting(Sender:TComponent):Boolean;
{not Support Tin Client Direct Call Server, and Developer can Call It By UAServiceClient(Component)}
//memo 01 : by vinson zeng for second version N-Tier Application Developer Kit
//------------%% end of %% -------------------------------------------------------------
procedure Request(const SrvObjName,ServiceName: WideString;DataIn: OleVariant;
var DataOut: OleVariant);
safecall;
procedure Update (const SrvObjName,ServiceName: WideString;DataIn: OleVariant;
var DataOut: OleVariant);
safecall;
procedure Execute(const SrvObjName,ServiceName: WideString;DataIn: OleVariant;
var DataOut: OleVariant);
safecall;

property Error: string read FError;
property IsLocalNet:Boolean read FIsLocalNet write SetIsLocalNet;
published
property Address: string read GetAddress write SetAddress;
property ProxyServer:TProxyServer read FProxyServer write SetProxyServer;
property DataPacketEncrypt:Boolean read FDataPacketEncrypt write SetDataPacketEncrypt;
property DataPacketCompressType:TCompressType read FCompressType write SetCompressType;
property Port: integer read GetPort write SetPort default 2108;
property Server: string read GetServer write SetServer;
property Connected :Boolean read GetConnected write SetConnected;
property WaitTimes:Cardinal read GetWaitTimes write SetWaitTimes default 5000;
property TryConnectTimes:LongInt read GetTryConnectTimes write SetTryConnectTimes default 3;
property DataPacketType:TDataPacketType read GetDataPacketType write SetDataPacketType default dptXML;
end;

以上是部分代码，谢谢各位！

好，研究

论坛里面问的都是我已经解决的问题，但为什么就没人对 我的 SDK
有兴趣呢，闭门造车？ 郁闷！！！

好,研究, 谢谢!

to 楼上两位，如果你们有兴趣的话，我可以发一个组件包给你们，
多谢你们了！

不错, 我想看看, yyanghhong@yahoo.com, 谢谢

我也有兴趣 shiningplus@citiz.net 谢谢

如果不麻烦你的话，请：
labelsoft@163.com

学习学习
delphierp@tom.com

楼上几为兄弟，我会在星期日进行整理工作，到时会发给你们，
多谢你们的支持！

很好的学习机会
xmuzxs@hotmail.com

呵呵，看了一下，挺不错的，学习~
麻烦给我也发一份
rm81@163.com

急需一份。再给个QQ号交流一下。
chyx96@sina.com

to vinson_zeng:
老大：能否发一份给我学习学习。谢谢！
e-mail:zhao6982118@yahoo.com.cn

to vinson_zeng:
能否发一份。谢谢！
e-mail:ltzyf@163.com