hutil32.pas.svn-base

Asphyre的传奇WIL,可以用Asphyre来写传奇了

function Str_Catch (src, dest: string; len: integer): string; //Result is rests..
begin

end;

function  Trim_R (const str: string): string;
var
	I, Len, tr: integer;
begin
	tr := 0;
	Len := Length (str);
   for I:=Len downto 1 do
   	if str[I] = ' ' then Inc (tr)
      else break;
   Result := Copy (str, 1, Len - tr);
end;

function IsEqualFont (SrcFont, TarFont: TFont): Boolean;
begin
	Result := TRUE;
	if SrcFont.Name <> TarFont.Name then Result := FALSE;
   if SrcFont.Color <> TarFont.Color then Result := FALSE;
   if SrcFont.Style <> TarFont.Style then Result := FALSE;
   if SrcFont.Size <> TarFont.Size then Result := FALSE;
end;


function CutHalfCode (Str: string): string;
var
	pos, Len: integer;
begin

	Result := '';
	pos := 1;
   Len := Length (Str);

	while TRUE do begin

   	if pos > Len then break;

      if (Str[pos] > #127) then begin

      	if ((pos+1) <= Len) and (Str[pos+1] > #127) then begin
      		Result := Result + Str[pos] + Str[pos+1];
         	Inc (pos);
         end;

      end else
      	Result := Result + Str[pos];

      Inc (pos);

   end;
end;


function ConvertToShortName(Canvas : TCanvas; Source : string; WantWidth : integer) : string;
var
   I, Len: integer;
   Str: string;
begin
	if Length(Source) > 3 then
      if Canvas.TextWidth (Source) > WantWidth then begin

 			Len := Length (Source);
         for I:=1 to Len do begin

            Str := Copy (Source, 1, (Len-I));
            Str := Str + '..';

            if Canvas.TextWidth (Str) < (WantWidth-4) then begin
               Result := CutHalfCode (Str);
               exit;
            end;

         end;

         Result := CutHalfCode (Copy (Source, 1, 2)) + '..';
         exit;

      end;

   Result := Source;

end;


function DuplicateBitmap (bitmap: TBitmap): HBitmap;
var
	hbmpOldSrc, hbmpOldDest, hbmpNew : HBitmap;
   hdcSrc, hdcDest						: HDC;

begin
   hdcSrc := CreateCompatibleDC (0);
   hdcDest := CreateCompatibleDC (hdcSrc);

   hbmpOldSrc := SelectObject(hdcSrc, bitmap.Handle);

   hbmpNew := CreateCompatibleBitmap(hdcSrc, bitmap.Width, bitmap.Height);

   hbmpOldDest := SelectObject(hdcDest, hbmpNew);

   BitBlt(hdcDest, 0, 0, bitmap.Width, bitmap.Height, hdcSrc, 0, 0,
     SRCCOPY);

   SelectObject(hdcDest, hbmpOldDest);
   SelectObject(hdcSrc, hbmpOldSrc);

   DeleteDC(hdcDest);
   DeleteDC(hdcSrc);

   Result := hbmpNew;
end;


procedure SpliteBitmap (DC: HDC; X, Y: integer; bitmap: TBitmap; transcolor: TColor);
var
   hdcMixBuffer, hdcBackMask, hdcForeMask, hdcCopy 			: HDC;
   hOld, hbmCopy, hbmMixBuffer, hbmBackMask, hbmForeMask 	: HBitmap;
   oldColor: TColor;
begin

   {UnrealizeObject (DC);}
(*   SelectPalette (DC, bitmap.Palette, FALSE);
   RealizePalette (DC);
  *)

	hbmCopy := DuplicateBitmap (bitmap);
	hdcCopy := CreateCompatibleDC (DC);
   hOld := SelectObject (hdcCopy, hbmCopy);

   hdcBackMask := CreateCompatibleDC (DC);
	hdcForeMask := CreateCompatibleDC (DC);
	hdcMixBuffer:= CreateCompatibleDC (DC);

	hbmBackMask := CreateBitmap (bitmap.Width, bitmap.Height, 1, 1, nil);
	hbmForeMask := CreateBitmap (bitmap.Width, bitmap.Height, 1, 1, nil);
	hbmMixBuffer:= CreateCompatibleBitmap (DC, bitmap.Width, bitmap.Height);

   SelectObject (hdcBackMask, hbmBackMask);
	SelectObject (hdcForeMask, hbmForeMask);
	SelectObject (hdcMixBuffer, hbmMixBuffer);

	oldColor := SetBkColor (hdcCopy, transcolor); //clWhite);

	BitBlt (hdcForeMask, 0, 0, bitmap.Width, bitmap.Height, hdcCopy, 0, 0, SRCCOPY);

	SetBkColor (hdcCopy, oldColor);

	BitBlt( hdcBackMask, 0, 0, bitmap.Width, bitmap.Height, hdcForeMask, 0, 0, NOTSRCCOPY );

	BitBlt( hdcMixBuffer, 0, 0, bitmap.Width, bitmap.Height, DC, X, Y, SRCCOPY );

	BitBlt( hdcMixBuffer, 0, 0, bitmap.Width, bitmap.Height, hdcForeMask, 0, 0, SRCAND );

	BitBlt( hdcCopy, 0, 0, bitmap.Width, bitmap.Height, hdcBackMask, 0, 0, SRCAND );

	BitBlt( hdcMixBuffer, 0, 0, bitmap.Width, bitmap.Height, hdcCopy, 0, 0, SRCPAINT );

	BitBlt( DC, X, Y, bitmap.Width, bitmap.Height, hdcMixBuffer, 0, 0, SRCCOPY );

   {DeleteObject (hbmCopy);}
   DeleteObject( SelectObject( hdcCopy, hOld ) );
	DeleteObject( SelectObject( hdcForeMask, hOld ) );
	DeleteObject( SelectObject( hdcBackMask, hOld ) );
	DeleteObject( SelectObject( hdcMixBuffer, hOld ) );

	DeleteDC( hdcCopy );
	DeleteDC( hdcForeMask );
	DeleteDC( hdcBackMask );
   DeleteDC( hdcMixBuffer );

end;

function  TimeIsOut (dtime: TDateTime; taghour, tagmin: integer): Boolean;
var
   ayear, amon, aday, ahour, amin, asec, amsec: word;
   targdate: TDateTime;
begin
   DecodeDate (dtime, ayear, amon, aday);
   DecodeTime (dtime, ahour, amin, asec, amsec);

   amin := amin + tagmin;
   if amin >= 60 then begin
      ahour := ahour + 1;
      amin := 0;
   end;
   ahour := ahour + taghour;
   while ahour >= 24 do begin
      aday := aday + 1;
      ahour := ahour - 24;
   end;
   while aday > MonthDays[FALSE][amon] do begin
      aday := aday - MonthDays[FALSE][amon];
      amon := amon + 1;
   end;
   if amon > 12 then begin
      ayear := ayear + 1;
      amon := 1;
   end;

   targdate := EncodeDate (ayear, amon, aday) +
               EncodeTime (ahour, amin, asec, amsec);

   if Now >= targdate then Result := TRUE
   else Result := FALSE;
end;

function TagCount (source: string; tag: char): integer;
var
   i, tcount: integer;
begin
   tcount := 0;
   for i:=1 to Length(source) do
      if source[i] = tag then Inc (tcount);
   Result := tcount;
end;

{ "xxxxxx" => xxxxxx }
function TakeOffTag (src: string; tag: char; var rstr: string): string;
var
   i, n2: integer;
begin
   n2 := Pos (tag, Copy (src, 2, Length(src)));
   rstr := Copy (src, 2, n2-1);
   Result := Copy (src, n2+2, length(src)-n2);
end;

function CatchString (source: string; cap: char; var catched: string): string;
var
   n: integer;
begin
   Result := '';
   catched := '';
   if source = '' then exit;
   if Length(source) < 2 then begin
      Result := source;
      exit;
   end;
   if source[1] = cap then begin
      if source[2] = cap then   //##abc#
         source := Copy (source, 2, Length(source));
      if TagCount (source, cap) >= 2 then begin
         Result := TakeOffTag (source, cap, catched);
      end else
         Result := source;
   end else begin
      if TagCount (source, cap) >= 2 then begin
         n := Pos (cap, source);
         source := Copy (source, n, Length(source));
         Result := TakeOffTag (source, cap, catched);
      end else
         Result := source;
   end;
end;

{ GetValidStr3客 崔府 侥喊磊啊 楷加栏肺 唱棵版快 贸府 救凳 }
{ 侥喊磊啊 绝阑 版快, nil 府畔.. }
function DivString (source: string; cap: char; var sel: string): string;
var
   n: integer;
begin
   if source = '' then begin
      sel := '';
      Result := '';
      exit;
   end;
   n := Pos (cap, source);
   if n > 0 then begin
      sel := Copy (source, 1, n-1);
      Result := Copy (source, n+1, Length(source));
   end else begin
      sel := source;
      Result := '';
   end;
end;

function DivTailString (source: string; cap: char; var sel: string): string;
var
   i, n: integer;
begin
   if source = '' then begin
      sel := '';
      Result := '';
      exit;
   end;
   n := 0;
   for i:=Length(source) downto 1 do
      if source[i] = cap then begin
         n := i;
         break;
      end;
   if n > 0 then begin
      sel := Copy (source, n+1, Length(source));
      Result := Copy (source, 1, n-1);
   end else begin
      sel := '';
      Result := source;
   end;
end;


function SPos (substr, str: string): integer;
var
   i, j, len, slen: integer;
   flag : Boolean;
begin
   Result := -1;
   len  := Length(str);
   slen := Length(substr);
   for i:=0 to len-slen do begin
      flag := TRUE;
      for j:=1 to slen do begin
         if byte(str[i + j]) >= $B0 then begin
            if (j < slen) and (i+j < len) then begin
               if substr[j] <> str[i + j] then begin
                  flag := FALSE;
                  break;
               end;
               if substr[j+1] <> str[i + j + 1] then begin
                  flag := FALSE;
                  break;
               end;
            end else
               flag := FALSE;
         end else
            if substr[j] <> str[i + j] then begin
               flag := FALSE;
               break;
            end;
      end;
      if flag then begin
         Result := i + 1;
         break;
      end;
   end;
end;

function NumCopy (str: string): integer;
var
   i: integer;
   data: string;
begin
   data := '';
   for i:=1 to Length(str) do begin
      if (Word('0') <= Word(str[i])) and (Word('9') >= Word(str[i])) then begin
         data := data + str[i];
      end else
         break;
   end;
   Result := Str_ToInt (data, 0);
end;

function  GetMonDay: string;
var
   year, mon, day: word;
   str: string;
begin
   DecodeDate (Date, year, mon, day);
   str := IntToStr(year);
   if mon < 10 then str := str + '0' + IntToStr(mon)
   else str := IntToStr(mon);
   if day < 10 then str := str + '0' + IntToStr(day)
   else str := IntToStr(day);
   Result := str;
end;

function  BoolToStr(boo: Boolean): string;
begin
   if boo then Result := 'TRUE'
   else Result := 'FALSE';
end;

function  BoolToInt (boo: Boolean): integer;
begin
   if boo then Result := 1
   else Result := 0;
end;

function  TimeStr (atime: TDateTime): string;
var
   hour, min, sec, msec: word;
begin
   DecodeTime (atime, hour, min, sec, msec);
   Result := IntToStr(hour) + '-' + IntToStr(min) + '-' + IntToStr(sec) + '-' + IntToStr(msec);
end;


function _MIN (n1, n2: integer): integer;
begin
	if n1 < n2 then Result := n1
   else Result := n2;
end;

function _MAX (n1, n2: integer): integer;
begin
	if n1 > n2 then Result := n1
   else Result := n2;
end;


// 老馆 胶飘傅阑 孽府俊 利钦窍霸 函版 : PDS
// ' = \A , " = \B , `= \C , /=\D , :=\E , ,=\F , %=\G , \=\H
function StrToSQLSafe  ( str : string ):string;
var
   len : integer;
   i      : integer;
   dest   : string;
begin
   len  := Length( str );
   dest := '';
   for i:= 1 to len do
   begin
        case str[i] of
        char(''''): dest := dest + '\A';
        char('"') : dest := dest + '\B';
        char('`') : dest := dest + '\C';
        char('/') : dest := dest + '\D';
        char(':') : dest := dest + '\E';
        char(',') : dest := dest + '\F';
        char('%') : dest := dest + '\G';
        char('\') : dest := dest + '\H';
        char($0D) : dest := dest + '\R';
        char($0A) : dest := dest + '\N';
        else
        dest := dest + str[i];
        end;
   end;

   Result :=  dest;
end;

// 孽府胶飘傅阑 老馆 胶飘傅栏肺 函版 : PDS
function SQLSafeToStr  ( sqlstr : string ):string;
var
   len   : integer;
   i     : integer;
   dest  : string;
begin
   len := Length( sqlstr);
   i := 1;
   while i <= len do
   begin
        if sqlstr[i] = '\'then
        begin
             inc( i);
             case sqlstr[i] of
             char('A') : dest := dest + '''';
             char('B') : dest := dest + '"';
             char('C') : dest := dest + '`';
             char('D') : dest := dest + '/';
             char('E') : dest := dest + ':';
             char('F') : dest := dest + ',';
             char('G') : dest := dest + '%';
             char('H') : dest := dest + '\';
             char('R') : dest := dest + char($0D);
             char('N') : dest := dest + char($0A);
             end;
        end
        else
        begin
             dest := dest + sqlstr[i];
        end;

        inc( i );
   end;

   Result :=  dest;
end;

// 俺青巩磊殿阑 昏力茄 胶飘傅栏肺 函版
function StrToVisibleOnly( str : string ):string;
var
   len   : integer;
   i     : integer;
   dest  : string;
begin
   len := Length( str);
   i := 1;
   while i <= len do
   begin
        if ord( str[i]) < 128 then
        begin
           if ord( str[i] ) >= 20 then
              dest := dest + str[i];
        end
        else
        begin
            dest := dest + str[i];
            inc(i);
            dest := dest + str[i];
        end;

        inc(i);
   end;

   Result :=  dest;
end;

// 俺青巩磊殿阑 昏力茄 胶飘傅栏肺 函版
function StrToHint( str : string ):string;
var
   len   : integer;
   i     : integer;
   newline : integer;
   dest  : string;
begin
   len := Length( str);
   i := 1;
   newline := 0;
   while i <= len do
   begin
        if ord( str[i]) < 128 then
        begin
           if ord( str[i] ) >= 20 then
              dest := dest + str[i]
           else
           begin
               if ord( str[i] ) = 10 then
               begin
                  dest := dest + '\';
               end;

               newline := -1;
           end;
        end
        else
        begin
            dest := dest + str[i];
            inc(i);
            dest := dest + str[i];
        end;

        inc(i);
        inc ( newline);

        if ( newline = 20 ) then
        begin
             dest := dest + '\';
             newline := 0;
        end;
   end;

   Result :=  dest;
end;

end.