uaunits.~pas

基于Midas 技术的多层应用开发包第二版（带开发文档）

end;

function CnvtDateTimeToSQLVarChar(Value: TDateTime): string;
const
  sDateFormat = 'yyyy-mm-dd';
  sTimeFormat = 'hh":"nn":"ss';
var
  Hour, Min, Sec, MSec: Word;
begin

  // 'yyyymmdd' format does not depend from 'set dateformat' option
  // don't process millisecond part
  Result := FormatDateTime(sDateFormat, Value);
  DecodeTime(Value, Hour, Min, Sec, MSec);
  if (Hour > 0) or (Min > 0) or (Sec > 0) {or (MSec > 0) }then begin
    Result := Result + ' ' + FormatDateTime(sTimeFormat, Value);
    if MSec > 0 then
      //Result := Format('%s:%.3d', [Result, MSec]);
  end;
  Result := Format('''%s''', [Result]);
  
end;


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


{/***
如果为char型值，aValue 必须判断 =''
如果是Int   ，aValue 必须判断 0
**/}

  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:
         //----- modify by vinson zeng 2004-7-30...etc
//        Result := ''''+DatetimeToStr(VarToDateTime(aValue))+'''';
        Result := CnvtDateTimeToSQLVarChar(VarToDateTime(aValue));
        //------ %% end of %% ---------------------------------
    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[i].FieldName;
    if bKeys then
    begin
       for j := low(lFieldKeys) to high(lFieldKeys) do
          if lowercase(cdsSrc.Fields[i].FieldName)=lowercase(lFieldKeys[j]) then
          begin
             if sSql2<>'' then sSql2 := sSql2+ ' and ';
             vValue := cdsSrc.Fields[i].Value;
             sSql2 := sSql2 + cdsSrc.Fields[i].FieldName;
             if not VarIsNull(vValue) then
                sSql2 := sSql2 + '=' + FieldValueToSqlStr(cdsSrc.Fields[i].DataType,vValue)
             else
                sSql2 :=  sSql2 + ' Is Null ';
         end;
    end
    else begin
          if sSql2<>'' then sSql2 := sSql2+ ' and ';
             vValue := cdsSrc.Fields[i].Value;
             sSql2 := sSql2 + cdsSrc.Fields[i].FieldName;
             if not VarIsNull(vValue) then
               sSql2 := sSql2 + '=' + FieldValueToSqlStr(cdsSrc.Fields[i].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;


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


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


function  DecryptString(var S: string):string;
var
  I: Integer;
begin
  for I := 1 to Length(S) do
    S[I] := Char(Ord(S[I]) - 129);
  Result := s;  
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 > 0 do
    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 > 0 do
    begin
      P^ := s_HexDigitsUpper[D mod Base + 1];
      Dec(P);
      Dec(L);
      D := D div Base;
    end;
  While L > 0 do
    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;
  CH:PChar;
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 -1 do
      Result := Result and (CH[i] in ['0'..'9']);
  end;
  StrDispose(CH); // 释放已经分配的内存

end;

function ReadStrFromStream(Stream:TStream):String;
var
  Len:Integer;
begin
  Len:=0;
  Stream.Read(Len,SizeOf(Byte));
  if Len=$FF then
    Stream.Read(Len,SizeOf(Integer));
  SetLength(Result,Len);
  Stream.Read(Result[1],Len);
end;


procedure WriteStrToStream(Stream:TStream;const Str:string);
var
  Len:Integer;
begin
  Len:=Length(Str);
  if Len<$FF then
    Stream.Write(Len,SizeOf(Byte))
  else
  begin
    Len:=$FF;
    Stream.Write(Len,SizeOf(Byte));
    Len:=Length(Str);
    Stream.Write(Len,SizeOf(Integer));
  end;
  Stream.Write(Str[1],Len);
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.