Chip 2001 October/Chip_2001-10_cd1.bin/zkuste/delphi/kolekce/d456/DCSLIB25.ZIP/DCEditTools.pas

Pascal/Delphi Source File | 2001-06-28 | 55.7 KB | 1,993 lines

{
 BUSINESS CONSULTING
 s a i n t - p e t e r s b u r g

         Components Library for Borland Delphi 4.x, 5.x
         Copyright (c) 1998 Alex'EM

         last modification: 24/04/2000
}
unit DCEditTools;

interface
{$I DCConst.inc}

uses Windows, Controls, Forms, SysUtils, CommCtrl, Messages, Graphics,
     Classes, DCConst;

type
  TDCDBObject = class(TPersistent)
  private
    FNode: string;
    FCode: string;
    FCaption: string;
  published
    property Node: string read FNode write FNode;
    property Code: string read FCode write FCode;
    property Caption: string read FCaption write FCaption;
  end;

function _intMin(A, B: integer): integer;
function _intMax(A, B: integer): integer;
function _getFlag(Flag: dword; const Index: Integer): boolean;
procedure _intSwap(var A, B: integer);
procedure _setFlag(var Flag: dword; const Index: Integer; const Value: boolean);

procedure StrPCat(var Dest: string; Source: PChar; Len: integer);

function IsExistDragging: boolean;
function IsLeapYear(Year: Integer): Boolean;
function DaysPerMonth(Year, Month: Integer): Integer;

function DateToStrY2K(Date: TDateTime; var Stroke: string;
  Kind: TDateEditKind = dkDate): boolean; overload;
function DateToStrY2K(Date: string; var Stroke: string;
  Kind: TDateEditKind = dkDate): boolean; overload;

function GetNumericFormat(Value: PChar; var Precision: integer;
  var Digits: integer): TNumericFormat;

function IsValidInteger(Value: string): boolean;
function IsValidFloat(Value: string): boolean;
function IsValidCurrency(Value: string; APrecision: integer): boolean;

function CheckInteger(var Value: string; ADigits: integer): boolean;
function CheckFloat(var Value: string; APrecision, ADigits: integer): boolean;
function CheckCurrency(var Value: string; APrecision, ADigits: integer): boolean;

function GetCharWidth(Handle: HWND; Font: TFont): integer;
function GetCharHeight(Handle: HWND; Font: TFont): integer;

procedure DrawFocusedRect(DC: HDC; pOldRect, pNewRect: PRect; BorderSize: integer);
function SetRectInDesktop( var Pos: TPoint; AWidth, AHeight: Integer; Offset: TPoint): integer;

function GetDCTextWidth(Font: TFont; Value: string; ACanvas: TCanvas = nil) : Longint;
function GetDCTextHeight(Font: TFont; Value: string; ACanvas: TCanvas = nil) : Longint;
function GetTextWidth(DC: HDC; Value: string): integer;
function GetTextHeight(DC: HDC; Value: string): integer;

function GetTransparentColor(RGB: integer): integer;

procedure TransformBitmap(Source, Dest: TBitmap; Style: TTransformStyle; AColor: TColor = $FFFFFF);
procedure TransformBitmapTransparent(BkgImage, SrcImage: TBitmap;
  var DstImage: TBitmap; Opacity: integer; AColor: TColor = $FFFFFF);

procedure DrawBitmap(ACanvas: TCanvas; ABitmap: TBitmap; ARect: TRect;
  AStretch: boolean; ATransparent: boolean = True);
procedure DrawTransparentBitmap(DC: HDC; Bitmap: TBitmap; R: TRect;
  StretchBitmap: boolean; AColor: TColor = $FFFFFF);
procedure DrawStyledBitmap(Canvas: TCanvas; ARect: TRect; X, Y: integer;
 Bitmap: TBitmap; Style: TTransformStyle);

function DrawHighLightText(Canvas: TCanvas; Text: PChar;
  ARect: TRect; Mode: byte; DrawFlag: DWORD = DT_END_ELLIPSIS;
  ImageList: TImageList = nil): TPoint;

procedure DrawGridFrameBorder(Canvas: TCanvas; ARect: TRect; AStyle: TEdgeBorderStyle;
  AState: TDrawBorerState; FixedColor: TColor);

function RecordCount2Str(Count: integer): string;

function CreateEmptyRgn: HRGN;
procedure ProcessPaintMessages;

function ETGetSystemImages(Mode: integer): TImageList;
procedure ETGetBitmap(Mode, Index: integer; ABitmap: TBitmap);

implementation

{$R DCSystem.RES}

var
 TempBitmap: TBitmap;

var
 SystemSmallImages: TImageList;       // Size: 15x15

function _intMin(A, B: integer): integer;
{
   -> eax   A
   -> edx   B
   <- eax   A if A < B
            A if A = B
            B if A < B
}
asm
  cmp eax, edx  // ±≡αΓφΦΓασ∞ └ Φ ┬
  jg  @@1       // σ±δΦ eax > edx ΦΣσ∞ ΦΣσ∞ φα @@1
  jmp @@2       // Φφα≈σ Γ√⌡εΣΦ∞
@@1:
  mov eax, edx  // τα∩Φ±√Γασ∞ Γ ┬ Γ Result
@@2:
end;

function _intMax(A, B: integer): integer;
{
   -> eax   A
   -> edx   B
   <- eax   A if A > B
            B if A = B
            B if A < B
}
asm
  cmp eax, edx  // ±≡αΓφΦΓασ∞ └ Φ ┬
  jg  @@2       // σ±δΦ eax > edx ΦΣσ∞ ΦΣσ∞ φα @@2
  jmp @@1       // Φφα≈σ Γ√⌡εΣΦ∞
@@1:
  mov eax, edx  // τα∩Φ±√Γασ∞ Γ ┬ Γ Result
@@2:
end;

procedure _intSwap(var A, B: integer);
asm
  mov ebx, [eax]
  mov ecx, [edx]
  mov [eax], ecx
  mov [edx], ebx
end;

function _getFlag(Flag: dword; const Index: Integer): boolean; assembler;
asm
  bt  eax, edx
  sbb eax, eax
  and eax, 1
end;

procedure _setFlag(var Flag: dword; const Index: Integer; const Value: boolean); assembler;
asm
  push esi
  mov esi, [eax]
  or  Value, Value
  jz  @@1
  bts esi, edx
  jmp @@2
@@1:
  btr esi, edx
@@2:
  mov [eax], esi
  pop esi
end;

procedure StrPCat(var Dest: string; Source: PChar; Len: integer);
 var
  i, Size: Integer;
  pValue: PChar;
begin
  if Len <> 0 then
  begin
    i := Length(Dest);
    Size := (i + Len + 1)*SizeOf(Char);
    pValue := AllocMem(Size);
    try
      if i > 0 then Move(Pointer(Dest)^, pValue^, i);
      Move(Source^, pValue[i], Len);
      Dest := pValue;
    finally
      FreeMem(pValue, Size);
    end;
  end;
end;

function IsExistDragging: boolean;
 var
  i: integer;
  Control: TControl;

 function IsDragging(AControl: TControl): boolean;
  var
   i: integer;
   Control: TControl;
 begin
   Result := False;
   if (csAcceptsControls in AControl.ControlStyle) then
     for i := 0 to AControl.ComponentCount-1 do
     begin
        Control := TControl(AControl.Components[i]);
        if Control.Dragging then
          Result := True
        else
          Result := IsDragging(Control);

        if Result then Exit;
     end;
 end;
begin
  Result := False;
  for i := 0 to Application.ComponentCount-1 do
  begin
     Control := TControl(Application.Components[i]);
      if Control.Dragging then
        Result := True
      else
        Result := IsDragging(Control);

      if Result then Exit;
  end;
end;

procedure ProcessPaintMessages;
 var
  Msg: TMsg;
begin
  while PeekMessage(Msg, 0, WM_PAINT, WM_PAINT, PM_NOREMOVE) do begin
    case Integer(GetMessage(Msg, 0, WM_PAINT, WM_PAINT)) of
      -1: Break;
      0 :
        begin
          PostQuitMessage(Msg.WParam);
          Break;
        end;
    end;
    DispatchMessage(Msg);
  end;
end;

function IsLeapYear(Year: Integer): Boolean;
begin
  Result := (Year mod 4 = 0) and ((Year mod 100 <> 0) or (Year mod 400 = 0));
end;

function DaysPerMonth(Year, Month: Integer): Integer;
 const
  DaysInMonth: array[1..12] of Integer = (31, 28, 31,
                                          30, 31, 30,
                                          31, 31, 30,
                                          31, 30, 31);
begin
  Result := DaysInMonth[Month];
  if (Month = 2) and IsLeapYear(Year) then Inc(Result);
end;

function DateToStrY2K(Date: TDateTime; var Stroke: string; Kind: TDateEditKind): boolean; overload;
 var
  DateFormat: string;
begin
  Result := True;
  if Date = 0 then
    Stroke := ''
  else begin
    case Kind of
      dkDate:
        DateFormat := Format('dd%0:smm%0:syyyy',[DateSeparator]);
      dkDateTime:
        DateFormat := Format('dd%0:smm%0:syyyy hh%1:snn%1:sss',[DateSeparator, TimeSeparator]);
      else
        DateFormat := Format('dd%0:smm%0:syyyy',[DateSeparator]);
    end;
    DateTimeToString(Stroke, DateFormat, Date);
  end;
end;

function DateToStrY2K(Date: string; var Stroke: string; Kind: TDateEditKind): boolean; overload;
 type
  TDateInfo = array[1..6] of integer;

 var
  DateInfo: TDateInfo;

 function DecodeDateStr(pDate: PChar; var DateInfo: TDateInfo): boolean;
  var
   Section, Count, i: integer;
   xDate: PChar;

 begin
   for i := Low(DateInfo) to High(DateInfo) do DateInfo[i] := 0;

   xDate  := pDate;
   Count  := 0;
   Section:= Low(DateInfo);
   while pDate^ <> #0 do
   begin
     if not(pDate^ in ['0'..'9']) then
     begin
       if Count > 0 then
       begin
         if Section <= High(DateInfo) then
         begin
           DateInfo[Section] := StrToIntDef(Copy(xDate, 0, Count), 0);
           Inc(Section)
         end
         else begin
           Result := False;
           Exit;
         end;
       end;
       xDate  := pDate+1;
       Count  := 0;
     end
     else
       Inc(Count);
     Inc(pDate);
   end;
   if (Count > 0) and (Section <= High(DateInfo)) then
   begin
     DateInfo[Section] := StrToIntDef(Copy(xDate, 0, Count), 0);
   end;

   Result := not( ( (DateInfo[3] = 00) and
                    ( (Section =3) and (Count=0) ) or (Section < 3)
                  ) or
                  (DateInfo[2] = 00) or (DateInfo[2] > 12) or
                  (DateInfo[1] = 00) or (DateInfo[1] > DaysPerMonth(DateInfo[3],DateInfo[2]))
                  or
                  (DateInfo[4] > 23) or (DateInfo[5] > 59));
 end;
begin
  Result := DecodeDateStr(PChar(Date), DateInfo);
  if Result then
  begin
    case DateInfo[3] of
      000..049: DateInfo[3] := 2000 + DateInfo[3];
      050..099: DateInfo[3] := 1900 + DateInfo[3];
      100..999: DateInfo[3] := 2000 + DateInfo[3];
    end;
    case Kind of
      dkDate:
        Stroke := Format('%1:2.2d%0:s%2:2.2d%0:s%3:d',
          [DateSeparator, DateInfo[1], DateInfo[2], DateInfo[3]]);
      dkDateTime:
        Stroke := Format('%1:2.2d%0:s%2:2.2d%0:s%3:d %5:2.2d%4:s%6:2.2d%4:s%7:2.2d',
          [DateSeparator, DateInfo[1], DateInfo[2], DateInfo[3],
           TimeSeparator, DateInfo[4], DateInfo[5], DateInfo[6]]);
      else
        Stroke := Format('%1:2.2d%0:s%2:2.2d%0:s%3:d',
          [DateSeparator, DateInfo[1], DateInfo[2], DateInfo[3]]);
    end;
  end;
end;


procedure DrawFocusedRect(DC: HDC; pOldRect, pNewRect: PRect; BorderSize: integer);
 var
  Brush: HBRUSH;
  RgnOuterRect, RgnInnerRect, RgnOldBorder, RgnNewBorder: HRGN;
  R: TRect;
  nSavedDC: integer;

 function CreateNullRgn: HRGN;
  var
   R: TRect;
 begin
   SetRectEmpty(R);
   Result := CreateRectRgnIndirect(R);
 end;

 procedure SetBoundsRgn(Rgn: HRGN; R: TRect);
 begin
   with R do SetRectRgn(Rgn, Left, Top, Right, Bottom);
 end;

begin
  RgnOuterRect := CreateNullRgn;
  RgnInnerRect := CreateNullRgn;
  RgnOldBorder := CreateNullRgn;
  RgnNewBorder := CreateNullRgn;

  {╤ετΣαφΦσ Brush}
  Brush:= CreateSolidBrush($00999999);

  if pOldRect <> nil then
  begin
    R := pOldRect^;
    SetBoundsRgn(RgnOuterRect, R);
    InflateRect(R, -BorderSize, -BorderSize);
    SetBoundsRgn(RgnInnerRect, R);
    CombineRgn(RgnOldBorder, RgnOuterRect, RgnInnerRect, RGN_XOR);

  end;

  if pNewRect <> nil then
  begin
    R := pNewRect^;
    SetBoundsRgn(RgnOuterRect, R);
    InflateRect(R, -BorderSize, -BorderSize);
    SetBoundsRgn(RgnInnerRect, R);
    CombineRgn(RgnNewBorder, RgnOuterRect, RgnInnerRect, RGN_XOR);

    if pOldRect <> nil then
      CombineRgn(RgnNewBorder, RgnOldBorder, RgnNewBorder, RGN_XOR);

  end;

  if pNewRect = nil then RgnNewBorder := RgnOldBorder;

  nSavedDC := SaveDC(DC);
  try
    SelectClipRgn(DC, RgnNewBorder);
    GetClipBox(DC, R);
    SelectObject(DC, Brush);
    PatBlt(DC, R.Left, R.Top, R.Right-R.Left, R.Bottom-R.Top, PATINVERT);
  finally
    RestoreDC(DC, nSavedDC);
  end;

  DeleteObject(RgnOuterRect);
  DeleteObject(RgnInnerRect);
  DeleteObject(RgnOldBorder);
  DeleteObject(RgnNewBorder);
  DeleteObject(Brush)

end;

function SetRectInDesktop(var Pos: TPoint; AWidth, AHeight: Integer; Offset: TPoint): integer;
begin
  Result := 0;
  with Screen do
  begin
    if Pos.Y < DesktopTop  then Pos.Y := DesktopTop;
    if (Pos.Y+AHeight) > (DesktopTop+DesktopHeight) then
    begin
      Pos.Y  := (DesktopTop+DesktopHeight)-AHeight-Offset.Y;
      Result := $1;
    end;
    if Pos.X < DesktopLeft then Pos.X := DesktopLeft;
    if (Pos.X+AWidth)  > (DesktopLeft+DesktopWidth) then
    begin
      Pos.X := (DesktopLeft+DesktopWidth)-AWidth-Offset.X;
      Result := Result + $2;
    end;
  end;
end;

function GetCharWidth(Handle: HWND; Font: TFont): integer;
 var
  TextMetric: TTextMetric;
  DC: HDC;
begin
  Result := 0;
  DC := GetWindowDC(Handle);
  SelectObject(DC, Font.Handle);
  try
    if GetTextMetrics(DC, TextMetric) then Result := TextMetric.tmMaxCharWidth;
  finally
    ReleaseDC(Handle, DC);
  end;
end;

function GetCharHeight(Handle: HWND; Font: TFont): integer;
 var
  TextMetric: TTextMetric;
  DC: HDC;
begin
  Result := 0;
  DC := GetWindowDC(Handle);
  SelectObject(DC, Font.Handle);
  try
    if GetTextMetrics(DC, TextMetric) then Result := TextMetric.tmHeight;
  finally
    ReleaseDC(Handle, DC);
  end;
end;

function GetDCTextHeight(Font: TFont; Value: string; ACanvas: TCanvas = nil): Longint;
var
 Canvas: TCanvas;
begin
  if ACanvas = nil then
  begin
    Canvas := nil;
    try
      Canvas := TCanvas.Create;
      Canvas.Handle := GetDC(0);
      Canvas.Font := Font;
      Result := GetTextHeight(Canvas.Handle, Value);
    finally
      ReleaseDC(0, Canvas.Handle);
      Canvas.Free;
    end
  end
  else
    Result := GetTextHeight(ACanvas.Handle, Value);
end;

function GetDCTextWidth(Font: TFont; Value: string;  ACanvas: TCanvas = nil): Longint;
var
 Canvas: TCanvas;
begin
  if ACanvas = nil then
  begin
    Canvas := nil;
    try
      Canvas := TCanvas.Create;
      Canvas.Handle := GetDC(0);
      Canvas.Font := Font;
      Result := GetTextWidth(Canvas.Handle, Value);
    finally
      ReleaseDC(0, Canvas.Handle);
      Canvas.Handle := 0;
      Canvas.Free;
    end
  end
  else begin
    Result := GetTextWidth(ACanvas.Handle, Value);
  end;
end;


function GetTextHeight(DC: HDC; Value: string): integer;
 var
  R: TSize;
begin
  Windows.GetTextExtentPoint(DC, PChar(Value), Length(Value), R);
  Result := R.CY;
end;

function GetTextWidth(DC: HDC; Value: string): integer;
 var
  R: TSize;
begin
  Windows.GetTextExtentPoint(DC, PChar(Value), Length(Value), R);
  Result := R.CX;
end;

function GetSysColorsNumber(DC: HDC): LongInt;
begin
  Result := (LongInt(1) shl GetDeviceCaps(DC, BitsPixel)) *
    LongInt(GetDeviceCaps(DC, Planes));
end;

function ConvertedColor(RGBPart: integer): integer;
 var
  HiByte: integer;
begin
  HiByte := (RGBPart and $8F0) shr 4;
  Result := 0;
  case HiByte of
    00    : Result := 7;
    01, 02: Result := 8;
    03, 05: Result := 9;
    06    : Result := 10;
    07, 08: Result := 11;
    09, 10: Result := 12;
    11, 12: Result := 13;
    13, 14: Result := 14;
    15    : Result := 15;
  end;
  Result := Result shl 4;
  case RGBPart of
   000..019: Result := Result + 11;
   020..039: Result := Result + 04;
   040..069: Result := Result + 05;
   070..089: Result := Result + 14;
   090..099: Result := Result + 13;
   100..109: Result := Result + 06;
   110..129: Result := Result + 05;
   130..149: Result := Result + 13;
   150..189: Result := Result + 06;
   190..209: Result := Result + 14;
   210..255: Result := Result + 07;
  end;
end;

function GetTransparentColor(RGB: integer): integer;
begin
  Result  := ConvertedColor(RGB and $FF0000 shr 16) ;
  Result  := Result shl 8 or ConvertedColor(RGB and $00FF00 shr 8);
  Result  := Result shl 8 or ConvertedColor(RGB and $0000FF);
end;


procedure DrawBitmap(ACanvas: TCanvas; ABitmap: TBitmap; ARect: TRect;
  AStretch: boolean; ATransparent: boolean = True);
 var
  SrcR, DstR: TRect;
  DstH, DstW: integer;
begin
  if Assigned(ABitmap) then
  begin
    DstW := ABitmap.Width;
    DstH := ABitmap.Height;
    SrcR := Rect(0,0,DstW,DstH);
    if AStretch then
      DstR := ARect
    else begin
      DstR := Rect(0, 0, ABitmap.Width, ABitmap.Height);
      OffsetRect(DstR, ARect.Left, ARect.Top);
    end;
    ABitmap.Transparent := ATransparent;
    ACanvas.StretchDraw(DstR, ABitmap);
  end;
end;

procedure DrawTransparentBitmap(DC: HDC; Bitmap: TBitmap; R: TRect; StretchBitmap: boolean;
  AColor: TColor);
const
  ROP_DSPDxax = $00E20746;
var
  DstW, DstH: Integer;
  MaskDC: HDC;
  Mask: TBitmap;
  MaskHandle: HBITMAP;
  Color: TColor;
begin
  if Assigned(Bitmap) then
  begin
    if AColor = $FFFFFF then
      Color := Bitmap.Canvas.Pixels[0,Bitmap.Height-1]
    else
      Color := AColor;
    if Bitmap.TransparentColor = Color then
    begin
      Mask := nil;
      MaskHandle := Bitmap.MaskHandle;
      MaskDC := CreateCompatibleDC(0);
      MaskHandle := SelectObject(MaskDC, MaskHandle);
    end
    else
    begin
      Mask := TBitmap.Create;
      Mask.Assign(Bitmap);
      Mask.Mask(Color);
      MaskDC := Mask.Canvas.Handle;
      MaskHandle := 0;
    end;

    if StretchBitmap then
    begin
      DstW := R.Right  - R.Left;
      DstH := R.Bottom - R.Top;
    end
    else begin
      DstW := Bitmap.Width;
      DstH := Bitmap.Height;
    end;

    try
      TransparentStretchBlt(DC, R.Left, R.Top, DstW, DstH, Bitmap.Canvas.Handle,
        0, 0, Bitmap.Width, Bitmap.Height, MaskDC, 0, 0);
    finally
      if Assigned(Mask) then
        Mask.Free
      else begin
        if MaskHandle <> 0 then SelectObject(MaskDC, MaskHandle);
        DeleteDC(MaskDC);
      end;
    end;
 end;
end;

procedure DrawStyledBitmap(Canvas: TCanvas; ARect: TRect; X, Y: integer;
 Bitmap: TBitmap; Style: TTransformStyle);
 var
  DestRect, SourceRect: TRect;
begin
  TransformBitmap(Bitmap, TempBitmap, Style);
  SourceRect := Rect(0, 0, Bitmap.Width, Bitmap.Height);
  DestRect   := SourceRect;
  OffsetRect(DestRect, ARect.Left+X, ARect.Top+Y);
  Canvas.BrushCopy(DestRect, TempBitmap, SourceRect,
    TempBitmap.Canvas.Pixels[0,Bitmap.Height-1]);
end;

procedure TransformBitmap(Source, Dest: TBitmap; Style: TTransformStyle;
  AColor: TColor = $FFFFFF);
 var
  i, j, ScanLineWidth, dHeight: integer;
  R, R1: TRect;
  LDScan, LSScan: PByteArray;
  LSScan0, LSScan1, LSScan2: PByteArray;
  AColorRBG: ULong;
  BValue, GValue, RValue: integer;
  TempBitmap: TBitmap;

  procedure CopyLScanLine(i: integer);
  begin
    LDScan[i]   := LSScan[i];
    LDScan[i+1] := LSScan[i+1];
    LDScan[i+2] := LSScan[i+2];
  end;

  function GetBSelectedBit(i: integer): integer;
  begin
    case i of
      0  :  Result := $42;
      255:  Result := $BD;
      else  Result := i;
    end;
  end;

  function GetBluredBit(i: integer): integer;
  begin
    Result := (LSScan0[i] + LSScan1[i] + LSScan2[i] +
      LSScan1[_intMax(0, i-3)] + LSScan1[_intMin(ScanLineWidth, i+3)]) div 5;
  end;

begin
  try
    Dest.PixelFormat := pf24Bit;
    if Dest.Handle <> Source.Handle then
    begin
      with Dest do
      begin
        Width  := Source.Width;
        Height := Source.Height;
      end;
    end;
    R := Rect(0, 0, Dest.Width, Dest.Height);
    ScanLineWidth := Integer(Dest.ScanLine[0]) - Integer(Dest.ScanLine[1]) - 1;
  except
    if Dest.Handle <> Source.Handle then
    begin
      with Dest do
      begin
        Width  := Source.Width;
        Height := Source.Height;
      end;
    end;
    R := Rect(0, 0, Dest.Width, Dest.Height);
    if not IsRectEmpty(R) then
    begin
      Dest.Canvas.CopyMode := cmSrcCopy;
      Dest.Canvas.CopyRect(R, Source.Canvas, R);
    end;
    Exit;
  end;
  if AColor <> $FFFFFF then
    AColorRBG := ColorToRGB(AColor)
  else
    AColorRBG := Source.Canvas.Pixels[0, 0];
  {24 bit}

  dHeight := Dest.Height-1;
  case Style of
    tsDisable:
      begin
        Source.PixelFormat := pf24Bit;
        for j := 0 to dHeight do
        begin
          LDScan := Dest.ScanLine[j];
          LSScan := Source.ScanLine[j];
          i := 0;
          while (i+2) <= ScanLineWidth do
          begin
            if LSScan[i+2] < $AF then
            begin
              LDScan[i]   := 120;
              LDScan[i+1] := 120;
              LDScan[i+2] := 120;
            end
            else
              if Dest.Canvas.Handle <> Source.Canvas.Handle then CopyLScanLine(i);
            Inc(i, 3);
          end;
        end;
      end;
    tsSelect:
      begin
        Source.PixelFormat := pf24Bit;
        for j := 0 to dHeight do
        begin
          LDScan := Dest.ScanLine[j];
          LSScan := Source.ScanLine[j];
          i := 0;
          while (i+2) <= ScanLineWidth do
          begin
            LDScan[i+2] := LSScan[i+2] div 2;
            LDScan[i+1] := LSScan[i+1] div 2;
            LDScan[i]   := GetBSelectedBit(LSScan[i]);
            Inc(i, 3);
          end;
        end;
      end;
    tsTransparent:
      begin
        Source.PixelFormat := pf24Bit;
        for j := 0 to Dest.Height-1 do
        begin
          LDScan := Dest.ScanLine[j];
          LSScan := Source.ScanLine[j];
          i := 0;
          while (i+3) <= ScanLineWidth do
          begin
            LDScan[i+2] := ConvertedColor(LSScan[i+2]);
            LDScan[i+1] := ConvertedColor(LSScan[i+1]);
            LDScan[i]   := ConvertedColor(LSScan[i]);
            Inc(i, 3);
          end;
        end;
      end;
    tsShadow:
      begin
        Source.PixelFormat := pf24Bit;
        BValue := GetBValue(AColorRBG);
        GValue := GetGValue(AColorRBG);
        RValue := GetRValue(AColorRBG);
        for j := 0 to dHeight do
        begin
          LDScan := Dest.ScanLine[j];
          LSScan := Source.ScanLine[j];
          i := 0;
          while (i+2) <= ScanLineWidth do
          begin
            if (LSScan[i] <> BValue) and (LSScan[i+1] <> GValue) and (LSScan[i+2] <> RValue) and
               (((i div 3) + j) mod 2 = 0) then
            begin
              LDScan[i+2] := 8;
              LDScan[i+1] := 36;
              LDScan[i]   := 107;
            end
            else
              if Dest.Canvas.Handle <> Source.Canvas.Handle then CopyLScanLine(i);
            Inc(i, 3);
          end;
        end;
      end;
    tsBlur:
      begin
        Source.PixelFormat := pf24Bit;
        for j := 0 to dHeight do
        begin
          LDScan  := Dest.ScanLine[j];

          LSScan0 := Source.ScanLine[_intMax(0, j-1)];
          LSScan1 := Source.ScanLine[j];
          LSScan2 := Source.ScanLine[_intMin(j+1, dHeight)];

          i := 0;
          while i <= ScanLineWidth do
          begin
            LDScan[i] := GetBluredBit(i);
            Inc(i);
          end;
        end;
      end;
    tsNormal:
      begin
        Dest.Canvas.CopyMode := cmSrcCopy;
        Dest.Canvas.CopyRect(R, Source.Canvas, R);
      end;
    tsInvert:
      begin
        Dest.Canvas.CopyMode := cmNotSrcCopy;
        Dest.Canvas.CopyRect(R, Source.Canvas, R);
      end;
    tsXPStyle:
      begin
        Source.PixelFormat := pf24Bit;
        BValue := GetBValue(AColorRBG);
        GValue := GetGValue(AColorRBG);
        RValue := GetRValue(AColorRBG);
        TempBitmap := TBitmap.Create;
        TempBitmap.Assign(Source);
        R1 := R;
        Dest.Canvas.Lock;
        try
          Dest.Canvas.Brush.Color := AColorRBG;
          Dest.Canvas.FillRect(R);
          OffsetRect(R1, 1, 1);
          DrawTransparentBitmap(Dest.Canvas.Handle, TempBitmap, R1, False);
          for j := 0 to dHeight do
          begin
            LDScan := Dest.ScanLine[j];
            LSScan := Dest.ScanLine[j];
            i := 0;
            while (i+2) <= ScanLineWidth do
            begin
              if (LSScan[i] <> BValue) or (LSScan[i+1] <> GValue) or (LSScan[i+2] <> RValue) then
              begin
                //clXPShadow = $00888D9D;
                LDScan[i+2] := $88;
                LDScan[i+1] := $8D;
                LDScan[i]   := $9D;
              end;
              Inc(i, 3);
            end;
          end;
          OffsetRect(R1, -2, -2);
          DrawTransparentBitmap(Dest.Canvas.Handle, TempBitmap, R1, False);
        finally
          TempBitmap.Free;
          Dest.Canvas.UnLock;
        end;
      end;
  end;
end;

procedure TransformBitmapTransparent(BkgImage, SrcImage: TBitmap;
  var DstImage: TBitmap; Opacity: integer; AColor: TColor = $FFFFFF);
 var
  LSrcScan, LBkgScan, LDstScan: PByteArray;
  i, j, ScanLineWidth: integer;
  R: TRect;
  AColorRBG: ULong;

  function GetScanAttr(A, B, Opacity: Integer): Integer;
  begin
    Result := ((A* Opacity) + B*(100-Opacity)) div 100;
  end;

   procedure SetDstImageBounds;
   begin
     with DstImage do
     begin
       if SrcImage <> nil then
       begin
         Width := _intMin(BkgImage.Width, SrcImage.Width);
         Height:= _intMin(BkgImage.Height, SrcImage.Height);
       end
       else begin
         Width := BkgImage.Width;
         Height:= BkgImage.Height;
       end;
       R := Rect(0, 0, Width, Height);
     end;
   end;

begin
  {24 bits only}

  try
    with DstImage do
    begin
      PixelFormat := pf24Bit;
      SetDstImageBounds;
      ScanLineWidth := Integer(ScanLine[0]) - Integer(ScanLine[1]);
    end;
  except
    SetDstImageBounds;
    DstImage.Canvas.CopyMode := cmSrcCopy;
    DstImage.Canvas.CopyRect(R, SrcImage.Canvas, R);
    Exit;
  end;

  if SrcImage <> nil then SrcImage.PixelFormat := pf24Bit;
  BkgImage.PixelFormat := pf24Bit;

  AColorRBG := $FFFFFF;
  if AColor <> $FFFFFF then
    AColorRBG := ColorToRGB(AColor)
  else if SrcImage <> nil then
    AColorRBG := SrcImage.Canvas.Pixels[0, 0];

  for j := 0 to DstImage.Height-1 do
  begin
    if SrcImage <> nil then
    begin
      LSrcScan := SrcImage.ScanLine[j];
      LBkgScan := BkgImage.ScanLine[j];
      LDstScan := DstImage.ScanLine[j];
      i := 0;
      while (i +3) <= ScanLineWidth do
      begin
       if AColorRBG <> RGB(LSrcScan[i+2], LSrcScan[i+1], LSrcScan[i]) then
       begin
         LDstScan[i]   := GetScanAttr(LSrcScan[i] ,  LBkgScan[i]  , Opacity);
         LDstScan[i+1] := GetScanAttr(LSrcScan[i+1], LBkgScan[i+1], Opacity);
         LDstScan[i+2] := GetScanAttr(LSrcScan[i+2], LBkgScan[i+2], Opacity);
       end
       else begin
         LDstScan[i]   := LBkgScan[i];
         LDstScan[i+1] := LBkgScan[i+1];
         LDstScan[i+2] := LBkgScan[i+2];
       end;
       inc(i, 3);
      end;
    end
    else begin
      LBkgScan := BkgImage.ScanLine[j];
      LDstScan := DstImage.ScanLine[j];
      i := 0;
      while (i+3) <= ScanLineWidth do
      begin
       LDstScan[i]   := GetScanAttr(GetBValue(AColor), LBkgScan[i]  , Opacity);
       LDstScan[i+1] := GetScanAttr(GetGValue(AColor), LBkgScan[i+1], Opacity);
       LDstScan[i+2] := GetScanAttr(GetRValue(AColor), LBkgScan[i+2], Opacity);
       inc(i, 3);
      end;
    end;
  end;
end;


function DrawHighLightText(Canvas: TCanvas; Text: PChar; ARect: TRect;
  Mode: byte; DrawFlag: DWORD = DT_END_ELLIPSIS;
  ImageList: TImageList = nil): TPoint;

 var
  nHeight, nWidth, nLineWidth, nLineHeight: Integer;
  DrawRect: TRect;
  pValue, pDrawText: PChar;
  nDrawCount, nValueCount: integer;
  lFirstChar: boolean;
  lTranslateSlash: boolean;
  LogFont: TLogFont;
  pFont0, pFont1: HFONT;
  AFont: TFont;

 procedure IncDrawCount(nCount: integer = 1);
   var
    nTextHeight: integer;
 begin
   Inc(nDrawCount, nCount);
   if lFirstChar then
   begin
     nTextHeight := GetDCTextHeight(Canvas.Font, 'Wg');
     Inc(nLineHeight, nTextHeight);
     lFirstChar  := False;
   end
 end;

 procedure ClearDrawText;
 begin
   pDrawText  := Text;
   nDrawCount := 0;
 end;

 procedure PaintString;
  var
   R: TRect;
 begin
   R := DrawRect;

   if (pDrawText^ = #0) or (nDrawCount=0) then
   begin
     ClearDrawText;
     Exit;
   end;

   case Mode of
     0:
       begin
         {Γ√≈Φ±δ σ∞ ≡ατ∞σ≡ ≥σΩ±≥α}
         if DT_WORDBREAK and DrawFlag = 0 then
           DrawText(Canvas.Handle, pDrawText, nDrawCount, R, DT_CALCRECT or DT_SINGLELINE)
         else begin
           DrawText(Canvas.Handle, pDrawText, nDrawCount, R, DT_CALCRECT or DT_WORDBREAK);
           nLineHeight := R.Bottom - R.Top;
         end;
         Inc(nLineWidth, (R.Right-R.Left));
         DrawRect.Left := DrawRect.Left + (R.Right-R.Left);
       end;
     1:
       if DrawRect.Left < ARect.Right then
       begin
         DrawText(Canvas.Handle, pDrawText, nDrawCount, R,
           DT_CALCRECT or DrawFlag);
         DrawText(Canvas.Handle, pDrawText, nDrawCount, DrawRect, DrawFlag);
         Inc(nLineWidth, (R.Right-R.Left));
         DrawRect.Left := DrawRect.Left + (R.Right-R.Left);
       end;
   end;

   ClearDrawText;
 end;

 procedure NewLine;
 begin
   Inc(Text);
   PaintString;
   lFirstChar := True;
   nHeight  := nHeight + nLineHeight;
   nWidth   := _intMax(nWidth, nLineWidth);
   DrawRect := Rect(ARect.Left, ARect.Top+nHeight, ARect.Right,
     ARect.Bottom);

   nLineHeight := 0;
   nLineWidth  := 0;
 end;

 procedure TranslateSpecial;
  var
    cFlag: Char;
    nValue: integer;
    AR: TRect;

  function ReadParam: boolean;
   var
    pParam: PChar;
  begin
    nValueCount := 0;
    Inc(Text);                        // {
    Result := False;
    if Text^ in ['{', ','] then
    begin
      repeat
        Inc(Text)
      until not(Text^ in [#0, '}', ',', ' ']);
      pParam := Text;
      while not(Text^ in [#0, '}', ',']) do
      begin
        Inc(Text);
        Inc(nValueCount);
      end;

      if Text^ = ',' then
        Result := True
      else
        if Text^ <> #0 then Inc(Text);

      ReallocMem(pValue, nValueCount+1);
      StrLCopy(pValue, pParam, nValueCount);
    end;
  end;

  procedure ReadBitmapTag(AStyle: TTransformStyle; AdjustHeight: boolean);
   var
    ANext: boolean;
    nParam1, nParam2: integer;

  begin
    Inc(Text);
    ANext := ReadParam;
    if (nValueCount > 0) then
    begin
      try
        case AStyle of
          tsNormal:
            begin
              if Assigned(ImageList) and (pValue^ in ['0'..'9']) then
              begin
                {}
                if ANext then
                begin
                  nValue := StrToIntDef(pValue, 0);
                  Dec(Text);
                  ReadParam;
                  if Mode > 0 then with DrawRect do
                  begin
                    Canvas.FillRect(Rect(Left, Top, Left + ImageList.Width, Bottom));
                    ImageList.DrawOverlay(Canvas, DrawRect.Left, DrawRect.Top,
                       nValue, StrToIntDef(pValue, 0));
                  end;
                end
                else
                  if Mode > 0 then with DrawRect do
                  begin
                    Canvas.FillRect(Rect(Left, Top, Left + ImageList.Width, Bottom));
                    ImageList.Draw(Canvas, Left, Top, StrToIntDef(pValue, 0), True);
                  end;

                if AdjustHeight then
                begin
                  if nLineHeight < ImageList.Height then
                  begin
                    nLineHeight := ImageList.Height;
                    lFirstChar  := False;
                  end;
                end;

                DrawRect.Left := DrawRect.Left + ImageList.Width;
                Inc(nLineWidth, ImageList.Width);
              end
              else
                try
                  TempBitmap.Canvas.Brush.Color := Canvas.Brush.Color;
                  with TempBitmap do
                  begin
                    if Mode > 0 then Canvas.FillRect(Rect(0, 0, Width, Height));
                    LoadFromResourceName(HInstance, pValue);
                  end;
                  if (Mode > 0) and (DrawRect.Left < DrawRect.Right) then
                    DrawBitmap(Canvas, TempBitmap, DrawRect, False);
                  DrawRect.Left := DrawRect.Left + TempBitmap.Width;
                  if AdjustHeight then
                  begin
                    if nLineHeight < TempBitmap.Height then
                    begin
                      nLineHeight := TempBitmap.Height;
                      lFirstChar  := False;
                    end
                  end;
                  Inc(nLineWidth, TempBitmap.Width);
                except
                  {}
                end;
            end;
          tsTransparent:
            begin
              TempBitmap.Canvas.Brush.Color := Canvas.Brush.Color;

              nParam1 := StrToIntDef(pValue, 0);
              if ANext then
              begin
                Dec(Text);
                ANext := ReadParam;
                nParam2 := StrToIntDef(pValue, 0)
              end
              else
                nParam2 := 50;

              if Assigned(ImageList) and (pValue^ in ['0'..'9']) then
              begin
                if ANext then with TempBitmap do
                begin
                  Width  := ImageList.Width;
                  Height := ImageList.Height;
                  Dec(Text);
                  ReadParam;
                  if Mode > 0 then
                  begin
                    Canvas.FillRect(Rect(0, 0, Width, Height));
                    ImageList.DrawOverlay(Canvas, 0, 0, nParam1, StrToIntDef(pValue, 0));
                  end;
                end
                else begin
                  with TempBitmap do
                  begin
                    if Mode > 0 then Canvas.FillRect(Rect(0, 0, Width, Height));
                    ImageList.GetBitmap(nParam1, TempBitmap)
                  end;
                end
              end
              else
                try
                  TempBitmap.LoadFromResourceName(HInstance, pValue);
                except
                  {}
                end;

              if (Mode > 0) and (DrawRect.Left < DrawRect.Right) then
              begin
                TransformBitmapTransparent(TempBitmap, nil, TempBitmap,
                  nParam2, TempBitmap.Canvas.Pixels[0,0]);
                DrawBitmap(Canvas, TempBitmap, DrawRect, False);
              end;

              DrawRect.Left := DrawRect.Left + TempBitmap.Width;
              Inc(nLineWidth, TempBitmap.Width);
            end;
          tsSelect, tsShadow, tsInvert, tsXPStyle:
            begin
              TempBitmap.Canvas.Brush.Color := Canvas.Brush.Color;
              nParam1 := StrToIntDef(pValue, 0);

              if Assigned(ImageList) and (pValue^ in ['0'..'9']) then
              begin
                if ANext then with TempBitmap do
                begin
                  Width  := ImageList.Width;
                  Height := ImageList.Height;
                  Dec(Text);
                  ReadParam;
                  if Mode > 0 then
                  begin
                    Canvas.FillRect(Rect(0, 0, Width, Height));
                    ImageList.DrawOverlay(Canvas, 0, 0, nParam1, StrToIntDef(pValue, 0));
                  end;
                end
                else begin
                  with TempBitmap do
                  begin
                    if Mode > 0 then Canvas.FillRect(Rect(0, 0, Width, Height));
                    ImageList.GetBitmap(nParam1, TempBitmap)
                  end;
                end
              end
              else
                try
                  TempBitmap.LoadFromResourceName(HInstance, pValue);
                except
                  {}
                end;

              if (Mode > 0) and (DrawRect.Left < DrawRect.Right) then
              begin
                TransformBitmap(TempBitmap, TempBitmap, AStyle);
                DrawBitmap(Canvas, TempBitmap, DrawRect, False);
              end;

              DrawRect.Left := DrawRect.Left + TempBitmap.Width;
              Inc(nLineWidth, TempBitmap.Width);
            end;
        end;

        Dec(Text);
      finally
        {}
      end;
    end
    else begin
      Canvas.Font.Style := Canvas.Font.Style  + [fsItalic];
      Dec(Text, 2);
    end
  end;

 begin
   Inc(Text);
   if Text^<>#0 then
   begin
     case Text^ of
       'b':
          begin
            if ((Text+1)^<>#0) and ((Text+1)^ = '0') then
            begin
              Canvas.Font.Style := Canvas.Font.Style  - [fsBold];
              Inc(Text);
            end
            else
              Canvas.Font.Style := Canvas.Font.Style  + [fsBold];
            Inc(Text);
            ClearDrawText;
          end;
       'i':
          begin
            if ((Text+1)^<>#0) then
            begin
              case (Text+1)^ of
               '0':
                 begin
                  Canvas.Font.Style := Canvas.Font.Style  - [fsItalic];
                  Inc(Text);
                 end;
               'd': ReadBitmapTag(tsTransparent, False);
               'n': ReadBitmapTag(tsInvert, False);
               'h': ReadBitmapTag(tsShadow, False);
               'm': ReadBitmapTag(tsNormal, False);
               'p': ReadBitmapTag(tsNormal, True);
               's': ReadBitmapTag(tsSelect, False);
               'x': ReadBitmapTag(tsXPStyle, False);
               else
                 Canvas.Font.Style := Canvas.Font.Style  + [fsItalic];
              end;
            end
            else
              Canvas.Font.Style := Canvas.Font.Style  + [fsItalic];
            Inc(Text);
            ClearDrawText;
          end;
       'u':
          begin
            if ((Text+1)^<>#0) and ((Text+1)^ = '0') then
            begin
              Canvas.Font.Style := Canvas.Font.Style  - [fsUnderline];
              Inc(Text);
            end
            else
              Canvas.Font.Style := Canvas.Font.Style  + [fsUnderline];
            Inc(Text);
            ClearDrawText;
           end;
       'f':
          begin
            if ((Text+1)^<>#0) and ((Text+1)^ = '0') then
            begin
              Canvas.Font.Name := AFont.Name;
              Inc(Text, 2);
            end
            else begin
              ReadParam;
              Canvas.Font.Name := Strpas(pValue);
            end;
            ClearDrawText;
          end;
       's':
          begin
            if ((Text+1)^<>#0) then
            begin
              case (Text+1)^ of
               '0':
                 begin
                   Canvas.Font.Style := Canvas.Font.Style  - [fsStrikeOut];
                   Inc(Text);
                 end;
               '{':
                 begin
                   ReadParam;
                   nValue := StrToIntDef(pValue, 0);
                   if (pValue^ = '+') or  (pValue^ = '-')then
                     Canvas.Font.Size := Canvas.Font.Size + nValue
                   else
                   if pValue^ = '0' then
                     Canvas.Font.Size := AFont.Size
                   else
                     Canvas.Font.Size := nValue;
                   Dec(Text);
                 end;
               else
                 Canvas.Font.Style := Canvas.Font.Style  + [fsStrikeOut];
              end;
            end
            else
              Canvas.Font.Style := Canvas.Font.Style  + [fsStrikeOut];
            Inc(Text);
            ClearDrawText;
          end;
       'o':
          begin
            if ((Text+1)^<>#0) then
            begin
              case (Text+1)^ of
                'w','h', 'W', 'H':
                  begin
                    Inc(Text);
                    cFlag := Text^;
                    ReadParam;
                    if IsValidInteger(pValue) then
                    begin
                      nValue := StrToIntDef(pValue, 0);
                      case cFlag of
                        'w':
                          begin
                            DrawRect.Left := DrawRect.Left + nValue;
                            Inc(nLineWidth, nValue);
                          end;
                        'h':
                          begin
                            DrawRect.Top := DrawRect.Top + nValue;
                            Inc(nLineHeight, nValue);
                          end;
                        'W':
                          begin
                            DrawRect.Left := DrawRect.Left - nValue;
                            Dec(nLineWidth, nValue);
                          end;
                        'H':
                          begin
                            DrawRect.Top := DrawRect.Top - nValue;
                            Dec(nLineHeight, nValue);
                          end;
                      end;
                    end
                    else begin
                       SetRectEmpty(AR);
                       DrawText(Canvas.Handle, pValue, Length(pValue), AR, DT_CALCRECT or DT_SINGLELINE);
                       case cFlag of
                         'w':
                           begin
                             DrawRect.Left := DrawRect.Left + AR.Right - AR.Left;
                             Inc(nLineWidth, AR.Right - AR.Left);
                           end;
                         'h':
                           begin
                             DrawRect.Top := DrawRect.Top + AR.Bottom - AR.Top;
                             Inc(nLineHeight, AR.Bottom - AR.Top);
                           end;
                         'W':
                           begin
                             DrawRect.Left := DrawRect.Left - AR.Right + AR.Left;
                             Inc(nLineWidth, - AR.Right + AR.Left);
                           end;
                         'H':
                           begin
                             DrawRect.Top := DrawRect.Top - AR.Bottom + AR.Top;
                             Inc(nLineHeight, - AR.Bottom + AR.Top);
                           end;
                       end;
                    end;
                    ClearDrawText;
                  end;
              end;
            end;
          end;
       'c':
          begin
            ReadParam;
            ClearDrawText;
            try
              nValue := StringToColor(pValue);
              Canvas.Font.Color := nValue;
            except
            end;
          end;
       'l':
          begin
            ReadParam;
            ClearDrawText;
            try
              nValue := StringToColor(pValue);
              Canvas.Pen.Color := nValue;
              with DrawRect do
              begin
                Canvas.MoveTo(Left , Top);
                Canvas.LineTo(Right, Top);
              end;
            except
            end;
          end;
       '#':
         NewLine;
       else
         IncDrawCount;
     end;
   end
   else
     IncDrawCount;
 end;

begin
(*
  ±∩σ÷Φαδⁿφ√σ ±Φ∞Γεδ√:
  /b  - ≤±≥αφεΓΩα Bold
  /b0 - ±φ ≥Φσ Bold
  /i  - ≤±≥αφεΓΩα Italic
  /i0 - ±φ ≥Φσ Italic
  /u  - ≤±≥αφεΓΩα Underline
  /u0 - ±φ ≥Φσ Underline
  /s  - StrikeOut
  /s0 - StrikeOut
  /f{font name} - ≤±≥αφεΓΩα °≡Φ⌠≥α           **αΩ≥≤αδⁿφε ≥εδⁿΩε Γ φα≈αδσ ±≥≡εΩΦ
  /s{font size} - ≤±≥αφεΓΩα ≡ατ∞σ≡α          **αΩ≥≤αδⁿφε ≥εδⁿΩε Γ φα≈αδσ ±≥≡εΩΦ
  /ow{length}    - ±∞σ∙σφΦσ ε≥φε±Φ≥σδⁿφε ∩ε±δσΣφσΘ ∩ετΦ÷ΦΦ ∩ε πε≡Φτεφ≥αδΦ
  /oh{length}    - ±∞σ∙σφΦσ ε≥φε±Φ≥σδⁿφε ∩ε±δσΣφσΘ ∩ετΦ÷ΦΦ ∩ε Γσ≡≥ΦΩαδΦ
  /c{color}     - ≤±≥αφεΓΩα ÷Γσ≥α
  /im{resource name} - ≡Φ±εΓαφΦσ ßΦ≥∞α∩α
  /ip{resource name} - ≡Φ±εΓαφΦσ ßΦ≥∞α∩α
  /is{resource name} - ≡Φ±εΓαφΦσ ßΦ≥∞α∩α
  /l{color}          - ≡Φ±εΓαφΦσ δΦφΦΦ
  /#                 - φεΓα  ±≥≡εΩα
  /{.../}            - φα≈αδε ±≥≡εΩΦ ßστ εß≡αßε≥ΩΦ ±∩σ÷.±Φ∞ΓεδεΓ
*)

  if Text = '' then begin
    Result := Point(0,0);
    Exit;
  end;

  pValue := AllocMem(1);

  AFont := TFont.Create;
  AFont.Assign(Canvas.Font);
  GetObject(Canvas.Font.Handle, SizeOf(TLogFont), @LogFont);
  pFont0 := CreateFontIndirect(LogFont);
  pFont1 := SelectObject(Canvas.Handle, pFont0);


  SetBkMode(Canvas.Handle, TRANSPARENT);

  nHeight := 0;
  nWidth  := 0;

  lFirstChar := True;
  DrawRect   := ARect;

  nLineHeight := 0;
  nLineWidth  := 0;

  ClearDrawText;

  if Mode = 0 then ARect := Rect(ARect.Left, ARect.Top, MaxInt, MaxInt);

  lTranslateSlash := True;

  try
    while Text^<>#0 do
    begin
      case Text^ of
        '/': begin
              if ((Text+1)^<>#0) then
              begin
                case (Text+1)^ of
                  '{':
                    begin
                      PaintString;
                      lTranslateSlash := False;
                      Inc(Text, 2);
                      ClearDrawText;
                    end;
                  '}':
                    begin
                      PaintString;
                      lTranslateSlash := True;
                      Inc(Text, 2);
                      ClearDrawText;
                    end;
                  else begin
                    if lTranslateSlash then
                    begin
                      PaintString;
                      TranslateSpecial;
                    end
                    else begin
                      IncDrawCount;
                      Inc(Text);
                    end;
                  end
                end;
              end
              else begin
                IncDrawCount;
                Inc(Text);
              end;
             end;
        #10: begin
               NewLine;
             end;
        #13:begin
              if not lFirstChar then
                NewLine
              else
                Inc(Text);
              ClearDrawText;
           end;
        else begin
          IncDrawCount;
          Inc(Text);
        end;
      end
    end;
    PaintString;
    nHeight := nHeight + nLineHeight;
    nWidth  := _intMax(nWidth, nLineWidth) + ARect.Left;
    Result  := Point(nWidth, nHeight);
  finally
    Canvas.Font.Assign(AFont);
    SelectObject(Canvas.Handle, pFont1);
    DeleteObject(pFont0);
    AFont.Free;
    ReallocMem(pValue,0);
  end;
end;

procedure DrawGridFrameBorder(Canvas: TCanvas; ARect: TRect;
  AStyle: TEdgeBorderStyle; AState: TDrawBorerState; FixedColor: TColor);
  var
   APoints: array of TPoint;
begin
  case AStyle of
    ebsNormal:
     case AState of
       dsUp:
         begin
           DrawEdge(Canvas.Handle, ARect, BDR_RAISEDINNER, BF_RECT);
         end;
       dsDown:
         begin
           DrawEdge(Canvas.Handle, ARect, BDR_SUNKENINNER, BF_BOTTOMRIGHT);
           DrawEdge(Canvas.Handle, ARect, BDR_SUNKENOUTER, BF_TOPLEFT);
         end;
     end;
    ebsFlat:
     begin
       case AState of
         dsUp:
           begin
             DrawEdge(Canvas.Handle, ARect, BDR_RAISEDINNER, BF_RECT);
           end;
         dsDown:
           begin
             DrawEdge(Canvas.Handle, ARect, BDR_SUNKENOUTER, BF_RECT);
           end;
       end;
     end;
   ebsNone:
     begin
       FrameRect(Canvas.Handle, ARect, CreateSolidBrush(ColorToRGB(FixedColor)));
       SetLength(APoints, 4);
       APoints[0].X := ARect.Left ; APoints[0].Y := ARect.Bottom;
       APoints[1].X := ARect.Right; APoints[1].Y := ARect.Bottom;
       APoints[2].X := ARect.Right; APoints[2].Y := ARect.Top-1;
       APoints[3].X := ARect.Left ; APoints[3].Y := ARect.Top-1;
       if ColorToRGB(FixedColor) = clSilver then
         Canvas.Pen.Color := clGray
       else
         Canvas.Pen.Color := clSilver;
       Canvas.Polyline(APoints);
     end;
   ebsShadowFlat:
      begin
       InflateRect(Arect, -1, -1);
       case AState of
         dsUp:
           begin
             DrawEdge(Canvas.Handle, ARect, BDR_RAISEDINNER, BF_RECT);
           end;
         dsDown:
           begin
             DrawEdge(Canvas.Handle, ARect, BDR_SUNKENOUTER, BF_RECT);
           end;
       end;
      end;
  end;
end;

{$HINTS OFF}
function GetNumericFormat(Value: PChar; var Precision: integer;
  var Digits: integer): TNumericFormat;
type
 TNumericPart = (npIntegral, npDecimal, npExponent);

 var
  NumericPart:  TNumericPart;
  Values: array[TNumericPart] of string[30];
  ESigns: array[TNumericPart] of ShortInt;
  ESChar: array[TNumericPart] of Char;
  V, E: Integer;
begin
  ESigns[npIntegral] := 0;
  ESigns[npDecimal ] := -1;
  ESigns[npExponent] := 0;

  Precision := 0;
  Digits    := 0;

  for NumericPart := npIntegral to npExponent do
  begin
    Values[NumericPart] := '';
    ESChar[NumericPart] := '+';
  end;

  Result      := nmInteger;
  NumericPart := npIntegral;

  while (Value^ <> #0) and (Result <> nmNone) do
  begin
    case Value^ of
      '+', '-':
        if (ESigns[NumericPart] = 0) and (Values[NumericPart] = '') then
        begin
          ESigns[NumericPart] := ESigns[NumericPart] + 1;
          ESChar[NumericPart] := Value^;
        end
        else begin
          Result := nmNone;
          continue;
        end;
      'E', 'e':
        if (NumericPart <> npExponent) and
           ((NumericPart = npIntegral) and (Values[NumericPart] <> '') or
            (NumericPart = npDecimal ) and (Values[NumericPart] <> '')) then
        begin
          NumericPart := npExponent;
          Result      := nmExponent;
        end
        else begin
          Result := nmNone;
          continue;
        end;
      '0'..'9':
        Values[NumericPart] := Values[NumericPart] + Value^;
      else
        if (Value^ = DecimalSeparator) and
           (Result = nmInteger)
        then begin
          NumericPart := npDecimal;
          Result      := nmDecimal
        end
        else begin
          Result := nmNone;
          continue;
        end;
    end;
    Inc(Value);
  end;
  case Result of
    nmInteger:
      begin
        Val(Values[npIntegral], V, E);
        if E <> 0  then Result := nmNone;
        Digits := Length(Values[npIntegral]);
      end;
    nmDecimal:
      begin
        if Length(Values[npDecimal])<= CurrencyDecimals then
          Result := nmCurrency;
        Digits    := Length(Values[npIntegral]) + Length(Values[npDecimal]) + 1;
        Precision := Length(Values[npDecimal]);
      end;
    nmExponent:
      begin
        if Length(Values[npExponent]) = 0 then
        begin
          Result := nmNone;
          Exit;
        end;
        Digits := Length(Values[npIntegral]);
        if Length(Values[npDecimal]) > 0 then
          Inc(Digits, Length(Values[npDecimal]) + 1);
        Precision := Length(Values[npDecimal]);
        Inc(Digits, Length(Values[npExponent]));
        case ESChar[npExponent] of
          '+':
            begin
              Dec(Precision, Length(Values[npExponent]));
              if Precision < 0 then Precision := 0;
            end;
          '-':
             Inc(Precision, Length(Values[npExponent]));
        end;
      end;
  end;
end;
{$HINTS ON}

function IsValidInteger(Value: string): boolean;
 var
  NumericFormat: TNumericFormat;
  Precision, Digits: integer;
begin
  NumericFormat := GetNumericFormat(PChar(Value), Precision, Digits);
  Result := (NumericFormat = nmInteger);
end;

function IsValidFloat(Value: string): boolean;
 var
  NumericFormat: TNumericFormat;
  Precision, Digits: integer;
begin
  NumericFormat := GetNumericFormat(PChar(Value), Precision, Digits);
  Result := (NumericFormat = nmInteger)  or
            (NumericFormat = nmDecimal)  or
            (NumericFormat = nmCurrency) or
            (NumericFormat = nmExponent);
end;

function IsValidCurrency(Value: string; APrecision: integer): boolean;
 var
  NumericFormat: TNumericFormat;
  Precision, Digits: integer;
begin
  NumericFormat := GetNumericFormat(PChar(Value), Precision, Digits);
  Result := (NumericFormat = nmCurrency) or (NumericFormat = nmInteger) or
            ((NumericFormat = nmDecimal) and ((APrecision = -1) or (Precision <= APrecision)));
end;

function CheckInteger(var Value: string; ADigits: integer): boolean;
 var
  NumericFormat: TNumericFormat;
  Precision, Digits: integer;
begin
  NumericFormat := GetNumericFormat(PChar(Value), Precision, Digits);
  Result := (NumericFormat = nmInteger) and ((ADigits = -1) or (Digits <= ADigits));
end;

function CheckFloat(var Value: string; APrecision, ADigits: integer): boolean;
 var
  NumericFormat: TNumericFormat;
  Precision, Digits, i, LastDigit: integer;
begin
  NumericFormat := GetNumericFormat(PChar(Value), Precision, Digits);
  Result := ((NumericFormat = nmInteger)  or
             (NumericFormat = nmDecimal)  or
             (NumericFormat = nmCurrency) or
             (NumericFormat = nmExponent)) and
            ((ADigits = -1) or (Digits <= ADigits)) and
            ((APrecision = -1) or (Precision <= APrecision));
  if Result then
  begin
    case NumericFormat of
      nmInteger :
        begin
          if APrecision > 0 then
          begin
            Value := Value + DecimalSeparator;
            for i := 0 to APrecision - 1 do Value := Value + '0';
          end;
        end;
      nmCurrency, nmDecimal:
        for i := Precision to APrecision - 1 do Value := Value + '0';
    end;
  end
  else begin
    if (NumericFormat = nmDecimal) and (Precision > APrecision) then
    begin
      Result    := True;
      LastDigit := Digits - Precision + APrecision;
      Value  := Copy(Value, 1, LastDigit);
    end;
  end
end;

function CheckCurrency(var Value: string; APrecision, ADigits: integer): boolean;
 var
  NumericFormat: TNumericFormat;
  Precision, Digits, i: integer;
begin
  NumericFormat := GetNumericFormat(PChar(Value), Precision, Digits);
  Result := ((NumericFormat = nmCurrency) or (NumericFormat = nmInteger) or
             ((NumericFormat = nmDecimal) and ((APrecision = -1) or (Precision <= APrecision)))
            ) and
            ((ADigits = -1) or (Digits <= ADigits));
  if Result then
  begin
    case NumericFormat of
      nmInteger :
        begin
          Value := Value + DecimalSeparator;
          for i := 0 to CurrencyDecimals - 1 do Value := Value + '0';
        end;
      nmCurrency:
        for i := Precision to CurrencyDecimals - 1 do Value := Value + '0';
    end;
  end;
end;

function RecordCount2Str(Count: integer): string;
begin
  Result := LoadStr(RES_GRID_REC_ROOT);
  case (Count mod 10) of
    1..4     :
      begin
        if (Count mod 100) = 11 then
          Result := Result + LoadStr(RES_GRID_REC_VAL0)
        else
          if (Count mod 10) = 1 then
            Result := Result + LoadStr(RES_GRID_REC_VAL1)
          else
            Result := Result + LoadStr(RES_GRID_REC_VAL2);
      end;
    0,5..9: Result := Result + LoadStr(RES_GRID_REC_VAL0);
  end;
end;

function CreateEmptyRgn: HRGN;
 var
  R: TRect;
begin
  SetRectEmpty(R);
  Result := CreateRectrgnIndirect(R);
end;

procedure CreateSystemImages;
 var
  Bitmap: TBitmap;
  i: integer;

 const
  SMALL_IMAGE_PREFIX = 'DC_SMALL_IMAGE';
  LARGE_IMAGE_PREFIX = 'DC_LARGE_IMAGE';

  SMALL_IMAGE_COUNT  = 10;
  LARGE_IMAGE_COUNT  = 0;

begin
  Bitmap := TBitmap.Create;
  try
    i := 0;
    repeat
      Bitmap.LoadFromResourceName(HInstance, Format('%s%2.2d', [SMALL_IMAGE_PREFIX, i]));
      if i = 0 then SystemSmallImages := TImageList.CreateSize(Bitmap.Width, Bitmap.Height);
      SystemSmallImages.AddMasked(Bitmap, Bitmap.Canvas.Pixels[0,0]);
      inc(i);
    until i = SMALL_IMAGE_COUNT;
  finally
    Bitmap.Free;
    SystemSmallImages.Overlay(0, 0);
    SystemSmallImages.Overlay(1, 1);
    SystemSmallImages.Overlay(2, 2);
    SystemSmallImages.Overlay(3, 3);
  end;
end;

procedure DestroySystemImages;
begin
  SystemSmallImages.Clear;
  SystemSmallImages.Free;
end;

function ETGetSystemImages(Mode: integer): TImageList;
begin
  if Mode and DCGIM_SMALLICON <> 0 then
    Result := SystemSmallImages
  else
    Result := nil;
end;

procedure ETGetBitmap(Mode, Index: integer; ABitmap: TBitmap);
begin
  if Mode and DCGIM_SMALLICON <> 0 then
  begin
    SystemSmallImages.GetBitmap(Index, ABitmap);
  end;
end;

initialization
 TempBitmap := TBitmap.Create;
 TempBitmap.PixelFormat := pf24Bit;
 CreateSystemImages;

finalization
 TempBitmap.Free;
 DestroySystemImages;

end.