Universal Agent on demond SDK --UAUnits(100分)

{******************************************************************************************}
{ }
{ 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 Name: UAUnits
Author: vinson zeng
Purpose:
History:
-----------------------------------------------------------------------------}

unit UAUnits;
interface
uses
Windows, Variants, ActiveX, Classes,SysUtils,
Forms,Controls,Registry,Dialogs,WinSock,ADODB,
DB,StdCtrls,DbClient,Messages,NB30;
const
UA_DataPacket_Major_Version = $AF501;
KEY_UA_Client = '/SOFTWARE/UA/UA Client';
csSettings = 'Settings';
ckIP = 'IP';
ckPort = 'Port';
ckWaitTimes = 'WaitTimes';
ckTryConnectTimes = 'TryConnectTimes';
ckIsLocalNet = 'IsLocalNet';

type
StringArray = array of string;
TUADataPacketType = (dtpRequest,dtpUpdate,dtpExecute);
TUAErrorRespone = (ureRetry,ureAbout,ureHelp,ureSendErrorReport,ureDetail);
TGUID128 = Array[0..3] of LongWord;

TOperationType = (otRequest,otUpdate,otExecute);
// add for srvobj type define 2003-12-29 by vinson zeng
// 业务， 事务， 功能， 调度， 数据库连接，安全，日志，扩展
TSrvObjMgrType = (sotBiz,sotTrans,sotFuncs,sotSche,sotDbConn,sotSec,sotLog,sotExt);
TUAErrorProcType = (eptSend,eptIgnore,eptAbort);
TUADebugDefine = (ddRequest,ddUpdate,ddExecute,ddLockObj,ddUnLockObj,ddCatchException,ddStartTrans,ddRollbackTrans,ddCommitTrans);
TUADebugDefines = set of TUADebugDefine;
CharSet = set of Char;

TUAUpdateType =(upModifyAll,upModifyOne,upInsert,
upDeleteAll,upDeleteOne);

TUAUpdateTypes = set of TUAUpdateType;
TUAExcetionType = (etSystem ,etSql,etCustom);
// UA SrvObj Exception Define // add by vinson 2003-12-03
TUAExcepions = (UA_E_INVOKE_TIMEOUT,
UA_E_TRAN_ROLLBACK,
UA_E_UNKNOW_SERVICE,
UA_E_UNKNOW_METHOD,
UA_E_PARAMS,
UA_E_INTERNAL,
UA_E_DB_CONNECT,
UA_E_NOPERMISSION,
UA_E_UNKNOW,
UA_E_EXEC_STPREDPROC,
UA_E_FATUALERROR,
UA_E_EXEC_SQL_STATEMENTS,
UA_E_GET_TABLE_STRUC,
UA_E_OPEN_TABLE,
UA_E_PHY_RECCOUNT,
UA_E_EXEC_MODIFY_SQL,
UA_E_EXEC_DELETE_SQL,
UA_E_EXEC_INSERT_SQL,
UA_E_DB_DISCONNECT);
//-----------------------------------------
TUAUpdateErrorCode =(ueOk,
ueSelectSql,
ueModChanged,
ueModOneButMany,
ueModOneSql,
ueModManySql,
ueInsSql,
ueInsExit,
ueDelNonExit,
ueDelOneButMany,
ueDelOneSql,
ueDelManySql);
// Local Exception Params
TUALocalErrorParam = class(TPersistent)
private
// FError:Exception;
protected
public
destructor Destroy;
override;
end;

TCliUserInfo = class(TObject)
public
FIp:string;
FProxyIp:string;
FWorkAccName:string;
FUserId:string;
FUserName:string;
FLastActivity:TDateTime;
end;

TAccountObj = class(TObject)
public
DBName:string;
AccName:string;
DCreate:TDateTime;
StorePath:string;
IsDisable:integer;
IsDefault:integer;
end;

//UA Error Define for AppServer
const
s_HexDigitsUpper: String [16] = '0123456789ABCDEF';
AutoRunRegistryKey = 'SOFTWARE/Microsoft/Windows/CurrentVersion/Run';
TUAUpdateErrorMsg : array [0..11] of string =
('成功',
'原来选择的SQL语句执行错误',
'要修改的记录已经被修改',
'修改一条记录，但是存在多条记录',
'修改一条记录的时候，SQL语句执行错误',
'修改多条记录的时候，SQL语句执行错误',
'插入一条记录，SQL语句执行错误',
'插入的记录已经存在',
'要删除的记录不存在',
'删除一条记录，但是存在多条记录',
'删除一条记录，SQL语句执行错误',
'删除多条记录，SQL语句执行错误');
// add by vinson zeng 2003-12-03
TUAExceptionMsg :array [0..18] of string =
('无法调用服务对象',
'执行数据库事务处理发生错误，已经回滚',
'不存在的服务对象名称',
'不存在的服务处理方法',
'对协议数据包进行解析发生错误',
'服务对象内部错误',
'连接数据库发生错误',
'操作未经授权',
'发生无法确认的错误',
'执行后台存储过程 [%s] 发生错误',
'服务器端发生严重错误',
'执行Sql语句发生错误',
'提取物理表记录计数发生错误',
'服务器尝试打开一个数据表时发生错误',
'提取物理表记录计数发生错误',
'执行UA数据更新SQL语句发生错误',
'执行UA数据删除SQL语句发生错误',
'执行UA数据插入SQL语句发生错误',
'断开与数据库服务器连接发生错误'
);
// Normal UA Error Code {Range: -$AF1091 To -$AF9999}
TUAExceptionCode :array [0..18] of integer =
(
-$C101,-$C102,-$C103,-$C104,
-$C105,-$C106,-$C107,-$C108,
-$C110,-$C111,-$C112,-$C113,
-$C114,-$C115,-$C116,-$C117,
-$C118,-$C119,-$C120
);
//------------------------------
var
UADebugMemo:TMemo;
AdoDs_UALog:TAdoQuery;
UA_SiteID:LongWord;
UA_Debug:Boolean;

function ShowNetworkSetting(Sender:TComponent):Boolean;
procedure WriteClientSetting(Sender: TComponent);
function RandomSeed: LongWord;
function RandomUniform: LongWord;
function RandomHex(const Digits: Integer = 8): String;
procedure RandomUniformInit(const Seed: LongWord);
procedure InitGUID;
function GenerateGUID32: LongWord;
{NetWork }
function GetHostEnt: PHostEnt;
function GetHostEntByName(const HostName: string): PHostEnt;
function LocalIP: string;
function GetComputerName: string;
function GetUserName: string;
function UniqueName(Instance: TComponent;
const Name: string;
Owner: TComponent): string;
function GenUniqueId: string;
function HadWhiteSpace(const S: string): Boolean;
function WinExecute(const ExeName, Params: String;
const ShowWin: Word;
const Wait: Boolean): Boolean;
// for MS-Sql2000 Procedure ADO
procedure _AssignParamValues(Source,Destiny: TParams);
procedure ParametersAssignedToParams(Parameters:TParameters;Params:TParams);
procedure ParamsAssignedToParameters(Params:TParams;Parameters:TParameters);
function StoredProcParamsToVariant(Params:TParams):Variant;
procedure VariantToStoredProcParams(Source:Variant;Dest:TParams);
function _GetBasicClientInfo(var vDataIn: OleVariant): string;
//-----------------------------------
procedure UA_variantToStream(AVariant:Variant;
AStream:TStream);
function UA_StreamToVariant(AStream:TStream):Variant;
//--------for debug -------------
procedure InitUADebugMemo(LMemo:TMemo);
procedure UADebugEx(UADebugDefine:TUADebugDefine;dRec:TDateTime;LObj:TObject;sMsg:string);
procedure UARunLogToDb(LAdoConn:TAdoConnection;dRec:TDateTime;vDataIn:OleVariant;sSrvObj:string;sService:string;OpMsg:string);
//----------------------------
functiondo
ubleQuote(Value : string) : string;
forward;
function BlobFieldValueAsString(lField:TField):string;
function FieldValueToSqlStr(lDataType: TFieldType;aValue: Variant): string;
function GenSelectDS(sTableName:string;cdsSrc:TClientDataSet;lFieldKeys: array of string):string;
//-----For Sql Server 2000
function ExistsTable(AdoConn:TAdoConnection;sTableName: string): Boolean;
//判断表是否存在
function CreateUA_SysTable(AdoConn:TAdoConnection):Boolean;
procedure EncryptString(var S: string);
procedure DecryptString(var S: string);
function StringToPChar(const S: string): PChar;
function PCharToString(P: PChar): string;
function LongWordToBase(const I: LongWord;
const Digits, Base: Byte): String;
function LongWordToHex(const I: LongWord;
const Digits: Byte): String;

implementation
uses uaNetworkSetting{,Lzh};
const
N = 624;
// Period parameters
M = 397;
var
mti : Integer;
mt : Array[0..N - 1] of LongWord;
// the array for the state vector
RandomUniformInitialized : Boolean = False;
var
GUIDInit : Boolean = False;
GUIDBase : TGUID128 = (0, 0, 0, 0);

{-----------------------------------------------------------------------------
Procedure: WriteClientSetting
Author: administrator
Date: 04-三月-2004
Arguments: Sender: TComponent
Result: None
-----------------------------------------------------------------------------}
procedure WriteClientSetting(Sender: TComponent);
var
Reg: TRegINIFile;
Sections: TStringList;
i: Integer;
begin
with Sender as TNetworkSettingFormdo
begin
Reg := TRegINIFile.Create('');
try
Reg.RootKey := HKEY_LOCAL_MACHINE;
Reg.OpenKey(KEY_UA_Client, True);
Sections := TStringList.Create;
try
Reg.ReadSections(Sections);
for i := 0 to Sections.Count - 1do
TRegistry(Reg).DeleteKey(Sections);
finally
Sections.Free;
end;
Reg.WriteString(csSettings,ckIP,edt_AppServerIP.Text);
Reg.WriteInteger(csSettings,ckPort,StrToInt(edt_AppServerPort.Text));
Reg.WriteInteger(csSettings,ckWaitTimes,StrToInt(sedt_Timout.Text));
Reg.WriteInteger(csSettings,ckTryConnectTimes,StrToInt(sedt_tryconnections.Text));
Reg.WriteBool(csSettings,ckIsLocalNet,cb_LocateNet.Checked);
finally
Reg.Free;
end;

MessageDlg('建议在修改网络参数成功后，退出当前应用程序。', mtInformation,[mbOk], 0);
end;
end;

{-----------------------------------------------------------------------------
Procedure: ShowNetworkSetting
Author: administrator
Date: 04-三月-2004
Arguments: Sender:TComponent
Result: Boolean
-----------------------------------------------------------------------------}
function ShowNetworkSetting(Sender:TComponent):Boolean;
var
aFrm: TNetworkSettingForm;
begin

aFrm := TNetworkSettingForm.Create(Sender);
try
aFrm.ShowModal;
Result := (aFrm.ModalResult = mrOk);
if Result and aFrm.FPassed then
begin
WriteClientSetting(aFrm);
end;
finally
if Assigned(aFrm) then
FreeAndNil(aFrm);
end;
end;

{-----------------------------------------------------------------------------
Procedure: RandomSeed
Author: vinosn zeng
Date: 04-三月-2004
Arguments: None
Result: LongWord
-----------------------------------------------------------------------------}
function RandomSeed: LongWord;
var
I : Int64;
Ye, Mo, Da : Word;
H, Mi, S, S1 : Word;
begin
Result := $A5F04182;
// Date
DecodeDate(Date, Ye, Mo, Da);
Result := Result xor Ye xor (Mo shl 16) xor (Da shl 24);
// Time
DecodeTime(Time, H, Mi, S, S1);
Result := Result xor H xor (Mi shl 8) xor (S1 shl 16) xor (S shl 24);
// {$IFDEF OS_WIN32}
// Ticks since start-up
Result := Result xor GetTickCount;
// CPU Frequency
if QueryPerformanceFrequency(I) then
Result := Result xor LongWord(I) xor LongWord(I shr 32);
// CPU Counter
if QueryPerformanceCounter(I) then
Result := Result xor LongWord(I) xor LongWord(I shr 32);
// Process
Result := Result xor GetCurrentProcess xor GetCurrentThreadID;
// {$ENDIF}
end;

{-----------------------------------------------------------------------------
Procedure: RandomUniformInit
Author: administrator
Date: 04-三月-2004
Arguments: const Seed: LongWord
Result: None
-----------------------------------------------------------------------------}
procedure RandomUniformInit(const Seed: LongWord);
var I : Integer;
begin
mt[0] := Seed;
For I := 1 to N - 1do
mt := LongWord(Int64(69069) * mt[I - 1]);
mti := N;
RandomUniformInitialized := True
end;


{-----------------------------------------------------------------------------
Procedure: RandomUniform
Author: vinson zeng
Date: 04-三月-2004
Arguments: None
Result: LongWord
-----------------------------------------------------------------------------}
function RandomUniform: LongWord;
const
Matrix_A = $9908B0DF;
// constant vector a
T_Mask_B = $9D2C5680;
// Tempering parameters
T_Mask_C = $EFC60000;
Up_Mask = $80000000;
// most significant w-r bits
Low_Mask = $7FFFFFFF;
// least significant r bits
mag01 : Array[0..1] of LongWord = (0, Matrix_A);
var
y : LongWord;
kk : Integer;
begin
if not RandomUniformInitialized then
RandomUniformInit(RandomSeed);
if mti >= N then
{ generate N words at one time }
begin
For kk := 0 to N - M - 1do
begin
y := (mt[kk] and Up_Mask) or (mt[kk + 1] and Low_Mask);
mt[kk] := mt[kk + M] xor (y shr 1) xor mag01[y and 1]
end;
For kk := N - M to N - 2do
begin
y := (mt[kk] and Up_Mask) or (mt[kk + 1] and Low_Mask);
mt[kk] := mt[kk + M - N] xor (y shr 1) xor mag01[y and 1]
end;
y := (mt[N - 1] and Up_Mask) or (mt[0] and Low_Mask);
mt[N - 1] := mt[M - 1] xor (y shr 1) xor mag01[y and 1];
mti := 0
end;
y := mt[mti];
Inc(mti);
y := y xor (y shr 11);
y := y xor ((y shl 7) and T_Mask_B);
y := y xor ((y shl 15) and T_Mask_C);
y := y xor (y shr 18);
Result := y;
end;

function RandomHex(const Digits: Integer): String;
var I : Integer;
begin
Result := '';
Repeat
I := Digits - Length(Result);
if I > 0 then
Result := Result + IntToHex(RandomUniform, 8);
Until I <= 0;
SetLength(Result, Digits);
end;

procedure InitGUID;
var I : Integer;
begin
GUIDBase[0] := RandomSeed;
For I := 1 to 3do
GUIDBase := RandomUniform;
GUIDInit := True;
end;

function GenerateGUID32: LongWord;
begin
if not GUIDInit then
InitGUID;
Result := GUIDBase[3];
GUIDBase[3] := LongWord(GUIDBase[3] + 1);
end;

function GetHostEnt: PHostEnt;
begin
Result := GetHostEntByName('');
end;

function GetHostEntByName(const HostName: string): PHostEnt;
begin
Result := WinSock.GetHostByName(PChar(HostName));
end;

function LocalIP:string;
var
WSAData: TWSAData;
HostName, Address: string;
HostEnt: PHostEnt;
begin
{ no error checking...}
WSAStartup($0101,WSAData);
SetLength(HostName, 255);
gethostname(PChar(HostName), 255);
SetLength(HostName, StrLen(PChar(HostName)));
HostEnt := gethostbyname(PChar(HostName));
with HostEnt^do
Address := Format('%d.%d.%d.%d', [Byte(h_addr^[0]), Byte(h_addr^[1]),
Byte(h_addr^[2]), Byte(h_addr^[3])]);
WSACleanup;
Result := Address;
end;


function HadWhiteSpace(const S: string): Boolean;
var
I: Integer;
begin
Result := false;
for I := Length(S)do
wnto 1do
begin
if S = #32 then
begin
Result := true;
Break;
end;
end;
end;

function GetComputerName: string;
var
L: Cardinal;
begin
Result := StringOfChar(#0, Max_Path);
L := Max_Path;
Windows.GetComputerName(PChar(Result), L);
Result := StrPas(PChar(Result))
end;

function GetUserName: string;
var
L: Cardinal;
begin
Result := StringOfChar(#0, Max_Path + 1);
L := Max_Path;
if Windows.GetUserName(PChar(Result), L) then
SetLength(Result, StrLen(PChar(Result)))
else
SetLength(Result, 0);
end;

function UniqueName(Instance: TComponent;
const Name: string;
Owner: TComponent): string;
var
I: Integer;
Tmp: TComponent;
begin

I := 0;
Result := Name;
if Assigned(Owner) then
begin
Tmp := Owner.FindComponent(Result);
if Assigned(Tmp) and (Tmp <> Instance) then
while (Tmp <> nil)do
begin
Result := Format('%s_%d', [Name, I]);
Inc(I);
Tmp := Owner.FindComponent(Result);
end;
end
else
begin
Result := '';
if Assigned(FindGlobalComponent(Name)) then
begin
Result := Name;
while FindGlobalComponent(Result) <> nildo
begin
Result := Format('%s_%d', [Name, I]);
Inc(I);
end;
end;
end;

end;

procedure ParametersAssignedToParams(Parameters:TParameters;Params:TParams);
var
i:integer;
lParam:TParam;
begin

Params.Clear;
for i := 0 to Parameters.Count -1do
begin
lParam := TParam.Create(Params);
lParam.Name := Parameters.Items.Name;
lParam.DataType := TFieldType(Ord(Parameters.Items.DataType));
case lParam.DataType of
FtString: if VarToStr(Parameters.Items.Value) = '0' then
lParam.AsString := '' else
lParam.AsString := VarToStr(Parameters.Items.Value);
ftInteger,ftSmallInt:
if VarIsNull(Parameters.Items.Value) then
lParam.AsInteger := 0
else
lParam.AsInteger := Parameters.Items.Value;
FtDateTime:
begin
if (Parameters.Items.Value = 0) then
lParam.AsDateTime := 0
else
lParam.AsDateTime := Parameters.Items.Value;
end;
else
lParam.Value := Parameters.Items.Value;
end;

lParam.Precision := Parameters.Items.Precision;
lParam.Size := Parameters.Items.Size;
lParam.ParamType := TParamType(Ord(Parameters.Items.Direction));
end;

end;

procedure ParamsAssignedToParameters(Params:TParams;Parameters:TParameters);
var
i:integer;
begin

for i := 0 to Params.Count -1do
begin
with Parameters.ParamByName(Params.Items.Name)do
begin
if (Params.Items.ParamType in [ptInput,ptInputOutput])
// and (not VarIsNull(Params.Items.Value))
and (VarCompareValue(Params.Items.Value,Unassigned) <> vrEqual) then
Value := Params.Items.Value;
end;
end;

end;

procedure _AssignParamValues(Source,Destiny: TParams);
var
I, J: Integer;
begin
for I := 0 to Source.Count - 1do
for J := 0 to Destiny.Count - 1do
if AnsiCompareText(Source.Items.Name,Destiny[J].Name) = 0 then
begin
Destiny[J].Assign(Source);
Break;
end;
end;

function StoredProcParamsToVariant(Params:TParams):Variant;
var
I, Idx, Count: Integer;
begin
Result := NULL;
Count := 0;
for I := 0 to Params.Count - 1do
Inc(Count);
if Count > 0 then
begin
Idx := 0;
Result := VarArrayCreate([0, Count - 1], varVariant);
for I := 0 to Params.Count - 1do
with Paramsdo
begin
Result[Idx] := VarArrayOf([Name, Value, Ord(DataType), Ord(ParamType)]);
Inc(Idx);
end;
end;
end;

procedure VariantToStoredProcParams(Source:Variant;Dest:TParams);
var
TempParams: TParams;
Param : TParam;
i,j: Integer;
VarValue : Variant;
begin
if not VarIsNull(Source) and VarIsArray(Source) and VarIsArray(Source[0]) then
begin
TempParams := TParams.Create;
try
j := VarArrayHighBound(Source, 1);
for i := 0 to jdo
try
Param := TParam.Create(Dest);
with Paramdo
begin
if VarArrayHighBound(Source, 1) > 1 then
DataType := TFieldType(Source[2]);
if VarArrayHighBound(Source, 1) > 2 then
ParamType := TParamType(Source[3]);
Name := Source[0];
VarValue := Source[1];
case DataType of
FtString: if VarToStr(VarValue) = '0' then
AsString := '' else
AsString := VarToStr(VarValue);
ftInteger,ftSmallInt:
if VarIsNull(VarValue) then
AsInteger := 0
else
AsInteger := VarValue;
FtDateTime:
begin
if (VarValue = 0) then
AsDateTime := 0
else
AsDateTime := VarValue;
end;
else
Value := VarValue;
end;
end;
finally
end;
_AssignParamValues(TempParams,Dest);
finally
TempParams.Free;
end;
end;

end;

procedure RaiseUAExcetion(UAExcepions: TUAExcepions);
begin
raise Exception.Create(TUAExceptionMsg[Ord(UAExcepions)]);
end;

procedure UA_variantToStream(AVariant:Variant;
AStream:TStream);
var
pChar;
sz:integer;
begin
if not VarIsArray(AVariant) then
raise Exception.Create('UAVariantToStream : Variant is not an array.');
sz:=VarArrayHighBound(AVariant,1);
p:=VarArrayLock(AVariant);
try
AStream.Position:=0;
AStream.WriteBuffer(p^,sz+1);
AStream.Position:=0;
finally
VarArrayUnlock(AVariant);
end;
end;

function UA_StreamToVariant(AStream:TStream):Variant;
var
pChar;
sz:integer;
begin
sz:=AStream.Size;
Result:=VarArrayCreate([0,sz-1],varByte);
p:=VarArrayLock(Result);
try
AStream.Position:=0;
AStream.ReadBuffer(p^,sz);
AStream.Position:=0;
finally
VarArrayUnlock(Result);
end;
end;

procedure InitUADebugMemo(LMemo:TMemo);
begin

if not Assigned(LMemo) then
Exit;
if UADebugMemo <> nil then
Exit;
UADebugMemo := LMemo;
UADebugMemo.Lines.Clear;
end;

procedure UADebugEx(UADebugDefine:TUADebugDefine;dRec:TDateTime;LObj:TObject;sMsg:string);
var
s,s1,sDebug,sAdd:string;
const
CR=#13#10;
TUADebugDefineMsg :array [0..8] of string =
('|Request|',
'|Update|',
'|Execute|',
'|Lock Object|',
'|UnLock Object|',
'|Catch All Exception|',
'|Start Transaction|',
'|Commit Transaction|',
'|Rollback Transaction|'
);
begin

if not UA_Debug then
Exit;
sDebug := TUADebugDefineMsg[Ord(UADebugDefine)];
if Assigned(LObj) then
begin
sAdd := LObj.ClassName + '@'+IntToHex(Int64(Addr(LObj)),8);
end
else
sAdd := 'Null';
s1 := 'begin
Task Process:'+DateTimeToStr(dRec);
s := '---------------begin
UA Trace Debug Message -------------------------'+
CR+
sDebug + CR+
'Object Info:' + sAdd +
CR+sMsg +
CR + s1 +CR +
'--------------------%%UA Trace End%%---------------------------------'
+#13#10;
if not Assigned(UADebugMemo) then
OutputDebugString(PChar(s))
else
begin
UADebugMemo.Lines.begin
Update;
try
if UADebugMemo.Lines.Count > 2000 then
while UADebugMemo.Lines.Count > 2000do
UADebugMemo.Lines.Delete(0);
UADebugMemo.Lines.Add(s);
finally
UADebugMemo.Lines.EndUpdate;
SendMessage(UADebugMemo.Handle, EM_SCROLLCARET, 0, 0);
end;
end;

end;

function _GetBasicClientInfo(var vDataIn: OleVariant): string;
var
sTmp,sCliHost,sCliUser:string;
iPos:integer;
begin

if (not VarIsEmpty(vDataIn)) and
(VarCompareValue(vDataIn,Unassigned)<> vrEqual) then
begin
sTmp := VarToStr(vDataIn[0][3]);
iPos := AnsiPos('#',sTmp);
sCliHost := Copy(sTmp,0,iPos -1);
sCliUser := Copy(sTmp,iPos+1,Length(sTmp)- iPos);
Result := 'Tag Id:'+ IntToStr(vDataIn[0][1])+#13#10+
'UA Ver:'+ vDataIn[0][2] +#13#10+
'Client IP Address:'+ vDataIn[0][4]+#13#10+
'Client Host Name:'+sCliHost+#13#10+
'Client User Name:'+sCliUser+#13#10+
'Session ID:'+vDataIn[0][5]+#13#10;
end;
end;

procedure UARunLogToDb(LAdoConn:TAdoConnection;dRec:TDateTime;vDataIn:OleVariant;sSrvObj:string;sService:string;OpMsg:string);
var
sSql:string;
sSesId,sTagId,sHost,sUser,sHostIp:string;
sSiteId:string;
sUA_User:string;
sTmp:string;
iPos:integer;

begin

if not Assigned(LAdoConn) then
Exit;
if not Assigned(AdoDs_UALog) then
begin
AdoDs_UALog := TAdoQuery.Create(Application);
AdoDs_UALog.Name := UniqueName(AdoDs_UALog,'AdoDs_UALog',Application);
end;

sSiteId := #39+IntToStr(UA_SiteID) + #39;
if (not VarIsEmpty(vDataIn)) and (not VarIsNull(vDataIn)) and
(VarCompareValue(vDataIn,Unassigned)<> vrEqual) then
begin
sTagId := #39 +IntToStr(vDataIn[0][1])+#39;
sSesId := #39 +VarToStr(vDataIn[0][5])+#39;
sHostIp := #39 +VarToStr(vDataIn[0][4])+#39;
sTmp := #39 +VarToStr(vDataIn[0][3])+#39;
iPos := AnsiPos('#',sTmp);
sHost := Copy(sTmp,0,iPos -1)+#39 ;
sUser := #39+Copy(sTmp,iPos+1,Length(sTmp)- iPos);
sUA_User := #39+ 'UA_DEBUG'+ #39;
end;

sSql := 'insert into UA_RunLog '+
'(cSesstionId,cTagId,cSiteId,dRec,cHost,cWinUser,cHostIp,cUAUser,cSrvObjName,cService,cOpMsg)'
+' values ( '
+ sSesId + ','+sTagId +','+sSiteId +','+ #39+DateTimeToStr(dRec) +#39 +','+sHost+ ','+sUser+','
+ sHostIp+',' +sUA_User +','+ #39+ sSrvObj+ #39+ ','+#39+sService +#39+','+#39+OpMsg +#39
+' )';
AdoDs_UALog.Connection := LAdoConn;
try
try
if AdoDs_UALog.Active then
AdoDs_UALog.Close;
AdoDs_UALog.SQL.Clear;
AdoDs_UALog.SQL.Add(sSql);
AdoDs_UALog.ExecSQL;
except
end;
finally
AdoDs_UALog.Connection := nil;
end;
end;

function do
ubleQuote(Value:string):string;
var
I : Integer;
begin
Result := '';
for I := 1 to Length(Value)do
begin
if Value = '''' then
Result := Result + ''''''
else
Result := Result + Value;
end;
end;

function BlobFieldValueAsString(lField:TField):string;
var
iSize:integer;
TmpStream :TStream;
pDataChar;
j, k : Integer;
const
// Hex Code Table vinson zeng
HexDigit : array [0..15] of char =
('0', '1', '2', '3', '4', '5', '6', '7',
'8', '9', 'A', 'B', 'C', 'D', 'E', 'F');
begin

if lField.DataType in [ftBlob, ftMemo, ftGraphic] then
begin

TmpStream := lField.DataSet.CreateBlobStream(lField, bmRead);
try
iSize := TmpStream.Size;
if iSize > 0 then
begin
pData := AllocMem(iSize);
//分配缓冲内存
TmpStream.ReadBuffer(pData^,iSize);
end;

k := 0;
for j := 0 to iSize - 1do
begin
if PData[j] in [#0..#31, '$', ''''] then
Inc(k);
end;

// Now we can adjust result size ,must bedo
it
SetLength(Result, 2 + iSize + k + k);
// Anddo
the second pass to set result value
Result[1] := '''';
k := 2;
for j := 0 to iSize - 1do
begin
if pData[j] in [#0..#31, '$', ''''] then
begin
Result[k] := '$';
Inc(k);
Result[k] := HexDigit[Ord(pData[j]) shr 4];
Inc(k);
Result[k] := HexDigit[Ord(pData[j]) and 15];
end
else
Result[k] := pData[j];
Inc(k);
end;
Result[k] := '''';
finally
//必须回收已经分配的内存空间
FreeMem(pData,iSize);
TmpStream.Free;
end;
end;

end;

function FieldValueToSqlStr(lDataType: TFieldType;aValue: Variant): string;
begin

case lDataType of
ftString, ftFixedChar, ftWideString:
Result := ''''+VarToStr(aValue)+'''';
ftSmallint, ftInteger, ftWord, ftLargeint, ftAutoInc, ftCurrency:
Result := VarToStr(aValue);
ftBoolean:
// Result := IntToStr(Ord(aValue));
if aValue=true then
Result:='1'
else
Result :='0';
ftFloat:
Result := VarToStr(aValue);
ftDate, ftTime, ftDateTime:
Result := ''''+DatetimeToStr(VarToDateTime(aValue))+'''';
ftBCD:
Result := VarToStr(aValue);
ftTimeStamp:
Result := VarToStr(aValue);
ftBytes, ftVarBytes:
Result := ''''+VarToStr(aValue)+'''';
ftBlob, ftMemo, ftGraphic:
begin
end;
ftUnknown, {ftBlob, ftMemo, ftGraphic,}
ftFmtMemo, ftParadoxOle, ftDBaseOle,
ftTypedBinary, ftCursor, ftADT, ftArray, ftReference,
ftDataSet, ftOraBlob, ftOraClob, ftVariant, ftInterface,
ftIDispatch, ftGuid, ftFMTBcd:
Result := '""'
else
Result := '""';
end;

end;

function GenSelectDS(sTableName:string;cdsSrc:TClientDataSet;
lFieldKeys: array of string):string;
var
i,j:integer;
sSql1,sSql2:string;
vValue:Variant;
bKeys:Boolean;
begin
Result := '';
if high(lFieldKeys)>=low(lFieldKeys) then
bKeys := true
else
bKeys := False;
sSql1 :='';
sSql2 :='';
for i :=0 to cdsSrc.Fields.Count-1 do
begin
if sSql1<>'' then
sSql1 := sSql1 + ',';
sSql1 := sSql1+ cdsSrc.Fields.FieldName;
if bKeys then
begin
for j := low(lFieldKeys) to high(lFieldKeys)do
if lowercase(cdsSrc.Fields.FieldName)=lowercase(lFieldKeys[j]) then
begin
if sSql2<>'' then
sSql2 := sSql2+ ' and ';
vValue := cdsSrc.Fields.Value;
sSql2 := sSql2 + cdsSrc.Fields.FieldName;
if not VarIsNull(vValue) then
sSql2 := sSql2 + '=' + FieldValueToSqlStr(cdsSrc.Fields.DataType,vValue)
else
sSql2 := sSql2 + ' Is Null ';
end;
end
else
begin
if sSql2<>'' then
sSql2 := sSql2+ ' and ';
vValue := cdsSrc.Fields.Value;
sSql2 := sSql2 + cdsSrc.Fields.FieldName;
if not VarIsNull(vValue) then
sSql2 := sSql2 + '=' + FieldValueToSqlStr(cdsSrc.Fields.DataType,vValue)
else
sSql2 := sSql2 + ' Is Null ';
end;
end;
Result := 'select '+ sSql1 + ' from ' +sTableName+ ' where '+sSql2;
end;

function ExistsTable(AdoConn:TAdoConnection;sTableName: string): Boolean;
//判断表是否存在
const
Sql = 'SELECT Name FROM sysobjects WHERE Name = ''%s'' AND type = ''U''';
var
AdoQry:TAdoQuery;
begin

Result := false;
if sTablename = '' then
Exit;
if not Assigned(AdoConn) then
Exit;
AdoQry := TAdoQuery.Create(nil);
AdoQry.Connection := AdoConn;
try
AdoQry.Close;
AdoQry.SQL.Clear;
AdoQry.SQL.Add(Format(Sql, [sTableName]));
AdoQry.Open;
if AdoQry.FieldByName('Name').AsString = '' then
Result := false
else
Result := true;
finally
if Assigned(AdoQry) then
begin
AdoQry.Connection := nil;
FreeAndNil(AdoQry);
end;
end;

end;

function CreateUA_SysTable(AdoConn:TAdoConnection):Boolean;
var
sUALogDb:string;
AdoQry_Create:TAdoQuery;
begin

sUALogDb := 'CREATE TABLE UA_SysLog('
+' LogUnique varchar(8) NOT NULL,'
+' AccountName varchar(32) NOT NULL,'
+' UserId varchar(20) COLLATE Chinese_PRC_CI_AS NULL ,'
+' Msg varchar(200) COLLATE Chinese_PRC_CI_AS NULL ,'
+' MsgDateTime datetime NOT NULL Default GetDate(),'
+' ModuleID varchar(40),'
+' BillNo varchar(40),'
+' DestId varchar(20),'
+' CopyTo bit NOT NULL default 0,'
+' Command bit NOT NULL default 0, CONSTRAINT PK_UA_SysLog PRIMARY KEY(LogUnique))';
Result := false;
if not Assigned(AdoConn) then
Exit;
AdoQry_Create := TAdoQuery.Create(nil);
AdoQry_Create.Connection := AdoConn;
try
try
if not ExistsTable(AdoConn,'UA_SysLog') then
begin
AdoQry_Create.Close;
AdoQry_Create.SQL.Clear;
AdoQry_Create.SQL.Add(sUALogDb);
AdoQry_Create.ExecSQL;
Result := true;
end
else
Result := true;
except
Result := false;
end;
finally
if Assigned(AdoQry_Create) then
begin
AdoQry_Create.Connection := nil;
FreeAndNil(AdoQry_Create);
end;
end;
end;

{ TUALocalErrorParam }
destructor TUALocalErrorParam.Destroy;
begin

inherited;
end;

function GenUniqueId: string;
const
// counter: integer = 0;
// starttime: integer = 0;
base: byte = 62;
const
tran: string[62] =
'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz';
var
counter: integer;
starttime: integer;
hh, mi, ss, cc: word;
date2000: TDateTime;
aaa, bbb, ddd: string[3];
base2, base3: longint;
function Conv10toN(number: longint;
numbyte: byte): string;
var a, b, c, d: integer;
begin
if numbyte = 2 then
if number >= base2 then
number := number - base2
else
else
if number >= base3 then
number := number - base3;
a := number div base;
b := number mod base;
if numbyte = 3 then
begin
c := a div base;
d := a mod base;
Result := tran[c + 1] + tran[d + 1] + tran[b + 1];
end
else
Result := tran[a + 1] + tran[b + 1];
end;

begin
Counter := 0;
starttime := 0;
base2 := base * base;
base3 := base2 * base;
DecodeTime(Time, hh, mi, ss, cc);
if starttime = 0 then
begin
Counter := hh * 60 + mi;
starttime := 1;
end
else
Inc(Counter);
if Counter >= base2 then
Counter := 0;
date2000 := EncodeDate(2000, 11, 1);
aaa := Conv10toN(Trunc(Date - date2000) * 24 + hh, 3);
bbb := Conv10toN(mi * 60 + ss, 2);
ddd := Conv10toN(((cc div 10) * base2 div 2) + Counter, 3);
Result := aaa + bbb + ddd;
end;

procedure EncryptString(var S: string);
var
I: Integer;
begin
for I := 1 to Length(S)do
S := Char(Ord(S) + 129);
end;

{-----------------------------------------------------------------------------
Procedure: DecryptString
Author: vinson zeng
Date: 04-三月-2004
Arguments: var S: string
Result: None
-----------------------------------------------------------------------------}

procedure DecryptString(var S: string);
var
I: Integer;
begin
for I := 1 to Length(S)do
S := Char(Ord(S) - 129);
end;

function StringToPChar(const S: string): PChar;
var
L: Integer;
begin
L := Length(S);
if L > 0 then
begin
Result := StrAlloc(Length(S) + 1);
StrPCopy(Result, S);
end
else
Result := nil;
end;

function PCharToString(P: PChar): string;
begin
if Assigned(P) then
Result := P
else
Result := '';
end;

{-----------------------------------------------------------------------------
Procedure: LongWordToBase
Author: vinson zeng
Date: 05-三月-2004
Arguments: const I: LongWord;
const Digits, Base: Byte
Result: String
-----------------------------------------------------------------------------}
function LongWordToBase(const I: LongWord;
const Digits, Base: Byte): String;
var D: LongWord;
L: Byte;
P: PChar;
begin
Assert(Base <= 16, 'Base <= 16');
if I = 0 then
begin
if Digits = 0 then
L := 1 else
L := Digits;
SetLength(Result, L);
FillChar(Pointer(Result)^, L, '0');
exit;
end;
L := 0;
D := I;
While D > 0do
begin
Inc(L);
D := D div Base;
end;
if L < Digits then
L := Digits;
SetLength(Result, L);
P := Pointer(Result);
Inc(P, L - 1);
D := I;
While D > 0do
begin
P^ := s_HexDigitsUpper[D mod Base + 1];
Dec(P);
Dec(L);
D := D div Base;
end;
While L > 0do
begin
P^ := '0';
Dec(P);
Dec(L);
end;
end;

function LongWordToHex(const I: LongWord;
const Digits: Byte): String;
begin
Result := LongWordToBase(I, Digits, 16);
end;

{-----------------------------------------------------------------------------
Procedure: WinExecute
Author: vinson zeng
Date: 05-三月-2004
Arguments: const ExeName, Params: String;
const ShowWin: Word;
const Wait: Boolean
Result: Boolean
-----------------------------------------------------------------------------}
function WinExecute(const ExeName, Params: String;
const ShowWin: Word;
const Wait: Boolean): Boolean;
var StartUpInfo : TStartupInfo;
ProcessInfo : TProcessInformation;
Cmd : String;
begin
if Params = '' then
Cmd := ExeName else
Cmd := ExeName + ' ' + Params;
FillChar(StartUpInfo, SizeOf(StartUpInfo), #0);
StartUpInfo.cb := SizeOf(StartUpInfo);
StartUpInfo.dwFlags := STARTF_USESHOWWINDOW;
StartUpInfo.wShowWindow := ShowWin;
Result := CreateProcess(
nil, PChar(Cmd), nil, nil, False,
CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, nil,
PChar(ExtractFilePath(ExeName)), StartUpInfo, ProcessInfo);
if Wait then
WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
end;

procedure SetApplicationAutoRun(const Name: String;
const AutoRun: Boolean);
begin
if Name = '' then
exit;
if AutoRun then
// SetRegistryString(HKEY_LOCAL_MACHINE, AutoRunRegistryKey, Name, ParamStr(0)) else
// DeleteRegistryValue(HKEY_LOCAL_MACHINE, AutoRunRegistryKey, Name);
end;

{-----------------------------------------------------------------------------
Procedure: StrIsAvaiNum
Author: vinson zeng
Date: 05-三月-2004
Arguments: sStr:string;const bZero:Boolean = false
Result: Boolean
-----------------------------------------------------------------------------}
function StrIsAvaiNum(sStr:string;const bZero:Boolean = false):Boolean;
var
i,iLength:integer;
CHChar;
begin

Result := true;
if trim(sStr) = '' then
Exit;
iLength := Length(sStr);
if iLength = 1 then
begin
CH := StrAlloc(Length(sStr) + 1);
StrPCopy(CH,sStr);
if not bZero then
Result := (CH[0] in ['0'..'9']) and (CH[0] <> '0')
else
Result := (CH[0] in ['0'..'9']);
end;

if iLength >1 then
begin
CH := StrAlloc(Length(sStr) + 1);
StrPCopy(CH,sStr);
if CH[0] = '0' then
Exit;
for i := 0 to iLength -1do
Result := Result and (CH in ['0'..'9']);
end;
StrDispose(CH);
// 释放已经分配的内存
end;

initialization
{ if not Assigned(AdoDs_UALog) then
begin
AdoDs_UALog := TAdoQuery.Create(Application);
AdoDs_UALog.Name := UniqueName(AdoDs_UALog,'AdoDs_UALog',Application);
end;
}
UA_SiteID := $D01;
UA_Debug := false;

finalization
if Assigned(AdoDs_UALog) then
begin
if AdoDs_UALog.Active then
AdoDs_UALog.Active := false;
if AdoDs_UALog.Connection <> nil then
AdoDs_UALog.Connection := nil;
FreeAndNil(AdoDs_UALog);
end;

end.