u_tools_leo.pas

来自「一个仓库管理中的子系统－－采购子系统」· PAS 代码 · 共 1,257 行 · 第 1/3 页

//////////////////////////////////////////////////////////////////////////
function tmsgpacket.getvalue(const name:string):string;
begin
result:=flist.values[name];
end;
//////////////////////////////////////////////////////////////////////////
function tmsgpacket.getsize;
var
  mem:tmemorystream;
begin
mem:=tmemorystream.create;
self.savetostream(mem);
result:=mem.size;
mem.free;
end;//////////////////////////////////////////////////////////////////////////
function tmsgpacket.getheadsize:integer;
var
  mem:tmemorystream;
begin
mem:=tmemorystream.create;
mem.position:=0;
flist.savetostream(mem);
result:=mem.size;
mem.free;
end;//////////////////////////////////////////////////////////////////////////
Procedure distributetext (canvas:tcanvas; width: integer; font: tfont; text:string; strings: tstringlist);
Var
  count1 : integer;
  buf : string;
  addbuf : string;
Begin
  strings.Clear;
  Canvas.Font := font;
  buf := '';
  count1 := 1;
  While count1 <= length (text) Do
    Begin
      addbuf := '';
      If ord (text[count1]) <= 126 Then
        Begin
          // that is to say text[count1] is not chinese;
          addbuf := text[count1];
          inc (count1)
        End
      Else
        Begin
          addbuf := text[count1] + text[count1 + 1];
          count1 := count1 + 2
        End;
      If Canvas.TextWidth (buf +
                                  addbuf) <= width Then
        // that is to say there has enough space;
        buf := buf + addbuf
      Else
        Begin
          If Canvas.TextWidth (buf) <= width Then
            strings.Add (buf);
          buf := addbuf
        End
    End; // while count1<=length(text) do end;
  If ((strings.Count <> 0)
       and
      (strings[strings.count -
               1] <> buf))
      or
     ((strings.Count = 0)
       and
      (buf <> '')) Then
    strings.Add (buf)
End;
//////////////////////////////////////////////////////////////////////////
function StreamToOlevariant(const stream:tstream;out v:olevariant):boolean;
var
  p:pointer;
  ptr:pointer;
  size:longint;
begin
size:=stream.size;
getmem(p,size);
stream.Position:=0;
stream.ReadBuffer(p^,size);
varclear(v);
v:=vararraycreate([0,stream.size],varbyte);
ptr:=vararraylock(v);
move(p^,ptr^,size);
vararrayunlock(v);
freemem(p);
end;
////////////////////////////////////////////////////////////////////////////////
function OlevariantToStream(stream:tstream;v:olevariant;size:longint):boolean;
var
  p:pointer;
  ptr:pointer;
begin
getmem(p,size);
ptr:=vararraylock(v);
move(ptr^,p^,size);
vararrayunlock(v);
stream.Position:=0;
stream.WriteBuffer(p^,size);
freemem(p);
end;
//////////////////////////////////////////////////////////////////////////
function getdata(cs:string;datatype:string):string;
var
  count1:integer;
  buf:string;
  index:integer;

  begin
index:=pos(datatype,cs);
if  index<=0 then
  begin
  result:='';
  exit;
  end;
buf:=copy(cs,pos(datatype,cs)+length(datatype)+1,length(cs));
result:=copy(buf,1,pos('~',buf)-1);
end;
//////////////////////////////////////////////////////////////////////////
function setdata(var cs:string;datatype:string;data:string):boolean;
var
  count1:integer;
  buf1,buf2,buf3:string;
begin
if pos(datatype,cs)>0 then
  begin// has include this cs we need change it
  buf1:=copy(cs,1,pos(datatype,cs)+length(datatype)-1);
  buf2:=copy(cs,pos(datatype,cs)+length(datatype)+1,length(cs));
  buf2:=copy(buf2,pos('~',buf2)+1,length(buf2));
  cs:=buf1+'~'+data+'~'+buf2;
  end
else begin//// has not include this cs we add change it
     cs:=cs+datatype+'~'+data+'~';
     end;

end;
//////////////////////////////////////////////////////////////////////////
function formatdatetime(str:string):string;
begin
if length(str)=14 then//有分秒
   result:=copy(str,1,4)+'年'+copy(str,5,2)+'月'+copy(str,7,2)+'日'+copy(str,9,2)+'时'+copy(str,11,2)+'分'+copy(str,13,2)+'秒';
if length(str)=8 then//只有日期
   result:=copy(str,1,4)+'年'+copy(str,5,2)+'月'+copy(str,7,2)+'日';
end;
//////////////////////////////////////////////////////////////////////////
function movequery(query:tquery;tablename:string;keyfieldname:string;keyvalue:string;action:string):string;
VAR
  nowkeyvalue:string;
begin

if action='last' then
  openquery(query,'SELECT * FROM '+tablename+' WHERE '+keyfieldname+'=(SELECT MAX('+keyfieldname+') FROM '+tablename+')'+' ORDER BY '+keyfieldname,'open');
if action='search' then
  openquery(query,'SELECT * FROM '+tablename+' WHERE '+keyfieldname+'='+''''+keyvalue+''''+' ORDER BY '+keyfieldname,'open');
if action='first' then
  openquery(query,'SELECT * FROM '+tablename+' WHERE '+keyfieldname+'=(SELECT MIN('+keyfieldname+') FROM '+tablename+')'+' ORDER BY '+keyfieldname,'open');
if action='open' then
  openquery(query,'SELECT * FROM '+tablename+' WHERE '+keyfieldname+'=(SELECT MAX('+keyfieldname+') FROM '+tablename+')'+' ORDER BY '+keyfieldname,'open');
if action='next' then
  openquery(query,'SELECT TOP 1 * FROM '+tablename+' WHERE '+keyfieldname+'>'+''''+keyvalue+''''+' ORDER BY '+keyfieldname,'open');
if action='prior' then
  openquery(query,'SELECT TOP 1 * FROM '+tablename+' WHERE '+keyfieldname+'=(SELECT MAX('+keyfieldname+') FROM '+tablename+' WHERE '+keyfieldname+'<'+''''+keyvalue+''''+')'+' ORDER BY '+keyfieldname,'open');
if query.fieldbyname(keyfieldname).asstring='' then
  nowkeyvalue:=keyvalue
else nowkeyvalue:=query.fieldbyname(keyfieldname).asstring;

openquery(query,'SELECT * FROM '+tablename+' WHERE '+keyfieldname+'='+''''+nowkeyvalue+'''','open');
result:=nowkeyvalue
end;
//////////////////////////////////////////////////////////////////////////
function OpenQuery(query:tquery;sqllist:tstringlist;action:string):boolean;overload;
var
  count1:integer;
begin
with query do
  begin
  close;
  sql.clear;
  sql.Assign(sqllist);
  prepare;
  if action='open' then open;
  if action='execsql' then execsql;
  end;
end;
//////////////////////////////////////////////////////////////////////////
function OpenQuery(query:tquery;sqlstring:string;action:string):boolean;
begin
with query do
  begin
  close;
  sql.clear;
  sql.add(sqlstring);
  prepare;
  if action='open' then open;
  if action='execsql' then execsql;
  end;
end;
///////////////////////////////////////////////////////////////////////////
function TSqlGenerater.GenSelect(Tables:Array of string;Fields:Array of String;WhereSql:string):String;
var
  buf:String;
  count1:integer;
  str:string;
begin
str:='SELCET ';
for count1:=0 to high(fields) do
  str:=str+fields[count1]+',';
str:=copy(str,1,length(str)-1)+' FROM ';
for count1:=0 to high(tables) do
  str:=str+tables[count1]+',';
if wheresql<>'' then
  result:=copy(str,1,length(str)-1)+' '+wheresql
else result:=copy(str,1,length(str)-1);
end;
///////////////////////////////////////////////////////////////////////////
function TSqlGenerater.GenDelete(TableName:string;WhereString:string):string;
begin
result:='DELETE FROM '+tablename+' '+wherestring;
end;
///////////////////////////////////////////////////////////////////////////
function TSqlGenerater.GenInsert(TableName:string;Fields:Array of String;Values:Array of Const):String;
var
  buf:String;
  count1:integer;
  str:string;
begin
result:='';
if (high(Fields)=0) or (high(Values)=0) or (high(Values)<>high(Fields))then exit;
str:='INSERT INTO '+TableName+' (';
for count1:=0 to high(Fields) do
  str:=str+fields[count1]+',';
str:=copy(str,1,length(str)-1)+') VALUES (';
for count1:=0 to high(values) do
  if (values[count1].VType=vtstring) or (values[count1].VType=vtansistring) or (values[count1].VType=vtchar)or (values[count1].VType=vtpchar)then
    str:=str+''''+varrectostring(values[count1])+''''+','
  else str:=str+varrectostring(values[count1])+',';
result:=copy(str,1,length(str)-1)+')';
end;
///////////////////////////////////////////////////////////////////////////
function TSqlGenerater.GenWhere(items:array of const):string;
var
  count1:integer;
  buf:string;
  str:string;
begin
result:='';
str:=' WHERE ';
if ((high(items)+1) mod 3 )<> 0 then exit;
for count1:=0 to high(items) do
  if (count1 mod 3)=0 then
    begin
    if (items[count1+2].VType=vtansistring) or (items[count1+2].VType=vtchar) then
       buf:='('+VarrecToString(items[count1])+VarrecToString(items[count1+1])+''''+VarrecToString(items[count1+2])+''''+')'+' AND '
    else buf:='('+VarrecToString(items[count1])+VarrecToString(items[count1+1])+VarrecToString(items[count1+2])+')'+' AND ';
    str:=str+buf;
    end;
result:=copy(str,1,length(str)-4);
end;
///////////////////////////////////////////////////////////////////////////
function TSqlGenerater.GenNormalWhere(fields:array of string;values:array of const):string;
var
  buf:String;
  count1:integer;
  str:string;
begin
result:='';
if (high(Fields)<0) or (high(Values)<0) or (high(Values)<>high(Fields))then exit;
str:=' WHERE ';
for count1:=0 to high(fields) do
  begin
  if (values[count1].VType=vtansistring) or (values[count1].VType=vtchar)then
    buf:='('+fields[count1]+'='+''''+VarrecToString(values[count1])+''''+')'+' AND '
  else  buf:='('+fields[count1]+'='+VarrecToString(values[count1])+')'+' AND ';
  str:=str+buf;
  end;
result:=copy(str,1,length(str)-4);
end;
///////////////////////////////////////////////////////////////////////////
function VarrecToString(rec:TVarRec):String;
begin
with rec do
case VType of
  vtInteger:    Result :=IntToStr(VInteger);
  vtBoolean:    if vboolean=true then Result :='true'
                else result:='false';
  vtChar:       Result :=VChar;
  vtExtended:   Result :=FloatToStr(VExtended^);
  vtString:     Result :=VString^;
  vtPChar:      Result :=VPChar;
  vtObject:     Result :=VObject.ClassName;
  vtClass:      Result :=VClass.ClassName;
  vtAnsiString: Result :=string(VAnsiString);
  vtCurrency:   Result :=CurrToStr(VCurrency^);
  vtVariant:    Result :=string(VVariant^);
  vtInt64:      Result :=IntToStr(VInt64^);
end;
end;
///////////////////////////////////////////////////////////////////////////
function TSqlGenerater.GenUpdate(TableName:String;Fields:Array of String;Values:Array of Const;WhereSql:String):String;
var
  buf:String;
  count1:integer;
  str:string;
begin
result:='';
if (high(Fields)=0) or (high(Values)=0) or (high(Values)<>high(Fields))then exit;
str:='UPDATE '+TableName+' SET  ';
for count1:=0 to high(Fields) do
  begin
  if (values[count1].VType=vtAnsiString)or (values[count1].VType=vtchar) then
    buf:=fields[count1]+'='+''''+VarrecToString(values[count1])+''''+','
  else  buf:=fields[count1]+'='+VarrecToString(values[count1])+',';
  str:=str+buf;
  end;
str:=copy(str,1,length(str)-1);
if wheresql='' then result:=str
else result:=str+' '+wheresql;
end;
///////////////////////////////////////////////////////////////////////////
function changelength(str:string;fillchar:char;strlength:integer):string;
var
  count1:integer;
  buf:string;
begin
if length(str)>=strlength then
  begin
  result:=copy(str,1,strlength);
  end
else begin
     for count1:=1 to strlength-length(str) do
       buf:=buf+fillchar;
     result:=buf+str;
     end;

end;
///////////////////////////////////////////////////////////////////////
Procedure writetext (canvas:tcanvas; x1,y1,x2,y2: integer; textxdirectionspace,textydirectionspace:integer;text: string; font: tfont; alignflag: integer; ifrh: boolean);
Var
  count1 : integer;
  count2 : integer;
  length : integer;
  textheight : integer;
  beforeheight : integer;
  strings : tstringlist;
  width,height:integer;
Begin
try
  canvas.Lock;
  canvas.Brush.style:=bsclear;
  Canvas.font := font;
  width:=abs(x1-x2);
  height:=abs(y1-y2);
  If ifrh = false Then
  //不进行绕行
    Begin
      textheight := Canvas.TextHeight (text);
      Case alignflag Of
      0:
      //左对齐
      canvas.textrect(rect(x1,y1,x2,y2),x1+textxdirectionspace,y1+textydirectionspace+round ((height - 2 *textydirectionspace - textheight) / 2),text);
      1://中对齐
        Begin
          length := Canvas.TextWidth (text);
          canvas.textrect(rect(x1,y1,x2,y2),x1+round (textxdirectionspace + (width - 2* textxdirectionspace - length) / 2),y1+textydirectionspace+round ((height - 2 *textydirectionspace - textheight) / 2),text);
        End;
      2://右对齐
        Begin
          length := Canvas.TextWidth (text);
          canvas.textrect(rect(x1,y1,x2,y2),x1+width - textxdirectionspace - length,y1+round ((height - 2 * textydirectionspace - textheight) / 2 +textydirectionspace), text);
        End;
      End
      // end case;

    End
  Else
    Begin // 字符需要绕行
      strings := tstringlist.Create;
      distributetext (canvas, width - 2 * textxdirectionspace, font, text, strings);
      textheight := 0;
      For count1 := 0 to strings.Count - 1 Do
        textheight := textheight + Canvas.TextHeight (strings[count1]);
      Case alignflag Of
      0: For count1 := 0 to strings.Count - 1 Do
        Begin
          beforeheight := 0;
          For count2 := 0 to count1 - 1 Do
            beforeheight := beforeheight + canvas.textheight (strings[count2]);
            canvas.textrect(rect(x1,y1,x2,y2),x1+textxdirectionspace,y1+textydirectionspace+round ((height - 2 *textydirectionspace - textheight) / 2)+beforeheight,strings[count1]);
        End;
      2: For count1 := 0 to strings.Count - 1 Do
        Begin
          beforeheight := 0;
          For count2 := 0 to count1 - 1 Do
            beforeheight := beforeheight + canvas.textheight (strings[count2]);
          length := Canvas.TextWidth (strings[count1]);
          canvas.textrect(rect(x1,y1,x2,y2),x1+width - textxdirectionspace - length,y1+round ((height - 2 * textydirectionspace - textheight) / 2 +textydirectionspace+beforeheight), strings[count1]);
        End;
      1: For count1 := 0 to strings.Count - 1 Do
        Begin
          beforeheight := 0;
          For count2 := 0 to count1 - 1 Do
            beforeheight := beforeheight + canvas.textheight (strings[count2]);
          length := Canvas.TextWidth (strings[count1]);
          canvas.textrect(rect(x1,y1,x2,y2),x1+round (textxdirectionspace + (width - 2* textxdirectionspace - length) / 2),y1+textydirectionspace+round ((height - 2 *textydirectionspace - textheight) / 2)+beforeheight,strings[count1]);
        End;
      End
      //end case

    End
finally
  canvas.Unlock;
end;
End;

////////////////////////////////////////////////

end.