ah_tool.pas

一个STRINGGRID 控件,比原DELPHI自带的STRINGGRID 功能强大

unit ah_tool;
{ Copyright 1995-200 Andreas H鰎stemeier            Version 1.1 2001-06-04   }
{ this utility functions are public domain. They are used by several of my   }
{ components. In case you have several version of this file always use the   }
{ latest one. Please check the file readme.txt of the component you found    }
{ this file at for more detailed info on usage and distributing.             }
(*@/// interface *)
interface

(*$b- *)
  (*$i ah_def.inc *)

uses
(*$ifdef delphi_1 *)
  winprocs,
  wintypes,
(*$else *)
  windows,
(*$endif *)
  messages,
  sysutils,
  classes,
  controls,
  forms;

(*@/// String utility functions *)
{ Find n'th occurence of a substring, from left or from right }
function posn(const s,t:string; count:integer):integer;

{ Find the n'th char unequal from left or from right }
function poscn(c:char; const s:string; n: integer):integer;

{ Exchange all occurances of a string by another (e.g. ,->.) }
function exchange_s(const prior,after: string; const s:string):string;

{ Delphi 1 didn't know these, but they are useful/necessary for D2/D3 }
(*$ifdef delphi_1 *)
function trim(const s:string):string;
procedure setlength(var s:string; l: byte);
(*$endif *)

{ Write a string into a stream }
procedure String2Stream(stream:TMemorystream; const s:string);
(*@\\\0000001101*)

{ The offset to UTC/GMT in minutes of the local time zone }
function TimeZoneBias:longint;

{ Convert a string to HTML - currently only for latin 1 }
function text2html(const s:string):string;

{ Why are these not in the language itself? }
function min(x,y: longint):longint;
function max(x,y: longint):longint;

(*@/// Create a windows HWnd avoiding the stuff from forms *)
type
  TWndProc = procedure (var Message: TMessage) of object;

function AH_AllocateHWnd(Method: TWndProc): HWND;
procedure AH_DeallocateHWnd(Wnd: HWND);
(*@\\\*)

(*@/// The routines to make the applications events use a list of methods *)
(*$ifndef delphi_ge_3 *)
procedure AddShowHintProc(proc:TShowHintEvent);
procedure RemoveShowHintProc(proc:TShowHintEvent);
(*$endif *)
procedure AddIdleProc(proc:TIdleEvent);
procedure RemoveIdleProc(proc:TIdleEvent);
(*@\\\*)

(*@/// Make Stream and Clipboard work together *)
procedure Stream2Clipboard(stream:TStream; format:integer);
procedure Clipboard2Stream(stream:TStream; format:integer);
(*@\\\*)

(*@/// Windows Resources and Languages *)
(*$ifdef delphi_gt_1 *)
function LoadStrEx(id:word; languageid: word):string;
(*$endif *)
function LoadStr(id:word):string;
(*@\\\*)

function ScrollBarVisible(control: TWinControl; vertical: boolean):boolean;
(*@\\\0000002501*)
(*@/// implementation *)
implementation

(*@/// Some string utility functions *)
(*@/// function posn(const s,t:string; count:integer):integer; *)
function posn(const s,t:string; count:integer):integer;

{ find the count'th occurence of the substring,
  if count<0 then look from the back }

var
  i,h,last: integer;
  u: string;
begin
  u:=t;
  if count>0 then begin
    result:=length(t);
    for i:=1 to count do begin
      h:=pos(s,u);
      if h>0 then
        u:=copy(u,pos(s,u)+1,length(u))
      else begin
        u:='';
        inc(result);
        end;
      end;
    result:=result-length(u);
    end
  else if count<0 then begin
    last:=0;
    for i:=length(t) downto 1 do begin
      u:=copy(t,i,length(t));
      h:=pos(s,u);
      if (h<>0) and (h+i<>last) then begin
        last:=h+i-1;
        inc(count);
        if count=0 then BREAK;
        end;
      end;
    if count=0 then result:=last
               else result:=0;
    end
  else
    result:=0;
  end;
(*@\\\*)
(*@/// function exchange_s(const prior,after: string; const s:string):string; *)
function exchange_s(const prior,after: string; const s:string):string;
var
  h,p: integer;
begin
  result:=s;
  p:=length(prior);
  while true do begin
    h:=pos(prior,result);
    if h=0 then BREAK;
    result:=copy(result,1,h-1)+after+copy(result,h+p,length(result));
    end;
  end;
(*@\\\*)
(*@/// function poscn(c:char; const s:string; n: integer):integer; *)
function poscn(c:char; const s:string; n: integer):integer;

{ Find the n'th occurence of a character different to c,
  if n<0 look from the back }

var
  i: integer;
begin
  if n=0 then  n:=1;
  if n>0 then begin
    for i:=1 to length(s) do begin
      if s[i]<>c then begin
        dec(n);
        result:=i;
        if n=0 then begin
          EXIT;
          end;
        end;
      end;
    end
  else begin
    for i:=length(s) downto 1 do begin
      if s[i]<>c then begin
        inc(n);
        result:=i;
        if n=0 then begin
          EXIT;
          end;
        end;
      end;
    end;
  poscn:=0;
  end;
(*@\\\*)
(*@/// function filename_of(const s:string):string; *)
function filename_of(const s:string):string;
var
  t:integer;
begin
  t:=posn('\',s,-1);
  if t>0 then
    result:=copy(s,t+1,length(s))
  else begin
    t:=posn(':',s,-1);
    if t>0 then
      result:=copy(s,t+1,length(s))
    else
      result:=s;
    end;
  end;
(*@\\\*)
(*$ifdef delphi_1 *)
(*@/// function trim(const s:string):string; *)
function trim(const s:string):string;
var
  h: integer;
begin
  (* trim from left *)
  h:=poscn(' ',s,1);
  if h>0 then
    result:=copy(s,h,length(s))
  else
    result:=s;
  (* trim from right *)
  h:=poscn(' ',result,-1);
  if h>0 then
    result:=copy(result,1,h);
  end;
(*@\\\*)
(*@/// procedure setlength(var s:string; l: byte); *)
procedure setlength(var s:string; l: byte);
begin
  s[0]:=char(l);
  end;
(*@\\\*)
(*$endif *)
(*@/// procedure String2Stream(stream:TMemorystream; const s:string); *)
procedure String2Stream(stream:TMemorystream; const s:string);
begin
  stream.write(s[1],length(s));
  end;
(*@\\\*)
(*@\\\*)

(*@/// function min(x,y: longint):longint; *)
function min(x,y: longint):longint;
begin
  if x<y then result:=x
         else result:=y;
  end;
(*@\\\*)
(*@/// function max(x,y: longint):longint; *)
function max(x,y: longint):longint;
begin
  if x>y then result:=x
         else result:=y;
  end;
(*@\\\*)

(*@/// function TimeZoneBias:longint;          // in minutes ! *)
function TimeZoneBias:longint;
(*@/// 16 bit way: try a 32bit API call via thunking layer, if that fails try the TZ *)
(*$ifdef delphi_1 *)
(*@/// function GetEnvVar(const s:string):string; *)
function GetEnvVar(const s:string):string;
var
  L: Word;
  P: PChar;
begin
  L := length(s);
  P := GetDosEnvironment;
  while P^ <> #0 do begin
    if (StrLIComp(P, PChar(@s[1]), L) = 0) and (P[L] = '=') then begin
      GetEnvVar := StrPas(P + L + 1);
      EXIT;
      end;
    Inc(P, StrLen(P) + 1);
    end;
  GetEnvVar := '';
  end;
(*@\\\*)

(*@/// function day_in_month(month,year,weekday: word; count: integer):TDateTime; *)
function day_in_month(month,year,weekday: word; count: integer):TDateTime;
var
  h: integer;
begin
  if count>0 then begin
    h:=dayofweek(encodedate(year,month,1));
    h:=((weekday-h+7) mod 7) +1 + (count-1)*7;
    result:=encodedate(year,month,h);
    end
  else begin
    h:=dayofweek(encodedate(year,month,1));
    h:=((weekday-h+7) mod 7) +1 + 6*7;
    while count<0 do begin
      h:=h-7;
      try
        result:=encodedate(year,month,h);
        inc(count);
        if count=0 then EXIT;
      except
        end;
      end;
    end;
  end;
(*@\\\*)
(*@/// function DayLight_Start:TDateTime;     // american way ! *)
function DayLight_Start:TDateTime;
var
  y,m,d: word;
begin
  DecodeDate(now,y,m,d);
  result:=day_in_month(4,y,1,1);
  (* for european one: day_in_month(3,y,1,-1) *)
  end;
(*@\\\*)
(*@/// function DayLight_End:TDateTime;       // american way ! *)
function DayLight_End:TDateTime;
var
  y,m,d: word;
begin
  DecodeDate(now,y,m,d);
  result:=day_in_month(10,y,1,-1);
  end;
(*@\\\*)
type    (* stolen from windows.pas *)
  (*@/// TSystemTime = record ... end; *)
  PSystemTime = ^TSystemTime;
  TSystemTime = record
    wYear: Word;
    wMonth: Word;
    wDayOfWeek: Word;
    wDay: Word;
    wHour: Word;
    wMinute: Word;
    wSecond: Word;
    wMilliseconds: Word;
  end;
  (*@\\\*)
  (*@/// TTimeZoneInformation = record ... end; *)
  TTimeZoneInformation = record
    Bias: Longint;
    StandardName: array[0..31] of word;  (* wchar *)
    StandardDate: TSystemTime;
    StandardBias: Longint;
    DaylightName: array[0..31] of word;  (* wchar *)
    DaylightDate: TSystemTime;
    DaylightBias: Longint;
    end;
  (*@\\\*)
var
  tz_info: TTimeZoneInformation;
  LL32:function (LibFileName: PChar; handle: longint; special: longint):Longint;
  FL32:function (hDll: Longint):boolean;
  GA32:function (hDll: Longint; functionname: PChar):longint;
  CP32:function (buffer:TTimeZoneInformation; prochandle,adressconvert,dwParams:Longint):longint;
  hdll32,dummy,farproc: longint;
  hdll:THandle;
  sign: integer;
  s: string;
begin
  hDll:=GetModuleHandle('kernel');                  { get the 16bit handle of kernel }
  @LL32:=GetProcAddress(hdll,'LoadLibraryEx32W');   { get the thunking layer functions }
  @FL32:=GetProcAddress(hdll,'FreeLibrary32W');
  @GA32:=GetProcAddress(hdll,'GetProcAddress32W');
  @CP32:=GetProcAddress(hdll,'CallProc32W');
  (*@/// if possible then   call GetTimeZoneInformation via Thunking *)
  if (@LL32<>NIL) and
     (@FL32<>NIL) and
     (@GA32<>NIL) and
     (@CP32<>NIL) then begin
    hDll32:=LL32('kernel32.dll',dummy,1);            { get the 32bit handle of kernel32 }
    farproc:=GA32(hDll32,'GetTimeZoneInformation');  { get the 32bit adress of the function }
    case CP32(tz_info,farproc,1,1) of                { and call it }
      1: result:=tz_info.StandardBias+tz_info.Bias;
      2: result:=tz_info.DaylightBias+tz_info.Bias;
      else result:=0;
      end;
    FL32(hDll32);                                    { and free the 32bit dll }
    end
  (*@\\\*)
  (*@/// else  calculate the bias out of the TZ environment variable *)
  else begin
    s:=GetEnvVar('TZ');
    while (length(s)>0) and (not(s[1] in ['+','-','0'..'9'])) do
      s:=copy(s,2,length(s));
    case s[1] of
      (*@/// '+': *)
      '+': begin
        sign:=1;
        s:=copy(s,2,length(s));
        end;
      (*@\\\*)
      (*@/// '-': *)
      '-': begin
        sign:=-1;
        s:=copy(s,2,length(s));
        end;
      (*@\\\*)
      else sign:=1;
      end;
    try
      result:=strtoint(copy(s,1,2))*60;
      s:=copy(s,3,length(s));
    except
      try
        result:=strtoint(s[1])*60;
        s:=copy(s,2,length(s));
      except
        result:=0;
        end;
      end;
    (*@/// if s[1]=':' then    minutes offset *)
    if s[1]=':' then begin
      try
        result:=result+strtoint(copy(s,2,2));
        s:=copy(s,4,length(s));
      except
        try
          result:=result+strtoint(s[2]);
          s:=copy(s,3,length(s));
        except
          end;
        end;
      end;
    (*@\\\*)
    (*@/// if s[1]=':' then    seconds offset - ignored *)
    if s[1]=':' then begin
      try
        strtoint(copy(s,2,2));
        s:=copy(s,4,length(s));
      except
        try
          strtoint(s[2]);
          s:=copy(s,3,length(s));
        except
          end;
        end;
      end;
    (*@\\\*)
    result:=result*sign;
    (*@/// if length(s)>0 then daylight saving activated, calculate it *)
    if length(s)>0 then begin
      (* forget about the few hours on the start/end day *)
      if (now>daylight_start) and (now<DayLight_End+1) then
        result:=result-60;
      end;
    (*@\\\*)
    end;
  (*@\\\*)
  end;
(*@\\\0000001C01*)
(*@/// 32 bit way: API call GetTimeZoneInformation *)
(*$else *)
var
  tz_info: TTimeZoneInformation;
begin
  case GetTimeZoneInformation(tz_info) of
    1: result:=tz_info.StandardBias+tz_info.Bias;
    2: result:=tz_info.DaylightBias+tz_info.Bias;
    else result:=0;
    end;
  end;
(*$endif *)
(*@\\\*)
(*@\\\0000000301*)

(*@/// function text2html(const s:string):string; *)
function text2html(const s:string):string;
var
  i: integer;
  t: string;
begin
  result:='';
  for i:=1 to length(s) do begin
    case s[i] of
      (*@/// iso latin 1 *)
      (*$ifdef iso_latin1 *)
            '&' : t:='&amp;';
            '<' : t:='&lt;';
            '>' : t:='&gt;';
            #160: t:='&nbsp;';
            '