home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 June / Chip_2002-06_cd1.bin / zkuste / delphi / kolekce / d6 / rxlibsetup.exe / {app} / units / Vclutils.pas < prev   
Encoding:
Pascal/Delphi Source File  |  2002-02-19  |  76.3 KB  |  2,741 lines
  1. {*******************************************************}
  2. {                                                       }
  3. {         Delphi VCL Extensions (RX)                    }
  4. {                                                       }
  5. {         Copyright (c) 2001,2002 SGB Software          }
  6. {         Copyright (c) 1997, 1998 Fedor Koshevnikov,   }
  7. {                        Igor Pavluk and Serge Korolev  }
  8. {                                                       }
  9. {*******************************************************}
  10.  
  11. unit VCLUtils;
  12.  
  13. {$I RX.INC}
  14. {$P+,W-,R-,V-}
  15.  
  16. interface
  17.  
  18. uses Windows, Classes, Graphics, Forms, Controls, Dialogs, Variants;
  19.  
  20. { Windows resources (bitmaps and icons) VCL-oriented routines }
  21.  
  22. procedure DrawBitmapTransparent(Dest: TCanvas; DstX, DstY: Integer;
  23.   Bitmap: TBitmap; TransparentColor: TColor);
  24. procedure DrawBitmapRectTransparent(Dest: TCanvas; DstX, DstY: Integer;
  25.   SrcRect: TRect; Bitmap: TBitmap; TransparentColor: TColor);
  26. procedure StretchBitmapRectTransparent(Dest: TCanvas; DstX, DstY, DstW,
  27.   DstH: Integer; SrcRect: TRect; Bitmap: TBitmap; TransparentColor: TColor);
  28. function MakeBitmap(ResID: PChar): TBitmap;
  29. function MakeBitmapID(ResID: Word): TBitmap;
  30. function MakeModuleBitmap(Module: THandle; ResID: PChar): TBitmap;
  31. function CreateTwoColorsBrushPattern(Color1, Color2: TColor): TBitmap;
  32. function CreateDisabledBitmapEx(FOriginal: TBitmap; OutlineColor, BackColor,
  33.   HighlightColor, ShadowColor: TColor; DrawHighlight: Boolean): TBitmap;
  34. function CreateDisabledBitmap(FOriginal: TBitmap; OutlineColor: TColor): TBitmap;
  35. function ChangeBitmapColor(Bitmap: TBitmap; Color, NewColor: TColor): TBitmap;
  36. procedure AssignBitmapCell(Source: TGraphic; Dest: TBitmap; Cols, Rows,
  37.   Index: Integer);
  38. {$IFDEF WIN32}
  39. procedure ImageListDrawDisabled(Images: TImageList; Canvas: TCanvas;
  40.   X, Y, Index: Integer; HighlightColor, GrayColor: TColor; DrawHighlight: Boolean);
  41. {$ENDIF}
  42.  
  43. function MakeIcon(ResID: PChar): TIcon;
  44. function MakeIconID(ResID: Word): TIcon;
  45. function MakeModuleIcon(Module: THandle; ResID: PChar): TIcon;
  46. function CreateBitmapFromIcon(Icon: TIcon; BackColor: TColor): TBitmap;
  47. {$IFDEF WIN32}
  48. function CreateIconFromBitmap(Bitmap: TBitmap; TransparentColor: TColor): TIcon;
  49. {$ENDIF}
  50.  
  51. { Service routines }
  52.  
  53. procedure NotImplemented;
  54. procedure ResourceNotFound(ResID: PChar);
  55. function PointInRect(const P: TPoint; const R: TRect): Boolean;
  56. function PointInPolyRgn(const P: TPoint; const Points: array of TPoint): Boolean;
  57. function PaletteColor(Color: TColor): Longint;
  58. function WidthOf(R: TRect): Integer;
  59. function HeightOf(R: TRect): Integer;
  60. procedure PaintInverseRect(const RectOrg, RectEnd: TPoint);
  61. procedure DrawInvertFrame(ScreenRect: TRect; Width: Integer);
  62. procedure CopyParentImage(Control: TControl; Dest: TCanvas);
  63. procedure Delay(MSecs: Longint);
  64. procedure CenterControl(Control: TControl);
  65. {$IFDEF WIN32}
  66. procedure ShowMDIClientEdge(ClientHandle: THandle; ShowEdge: Boolean);
  67. function MakeVariant(const Values: array of Variant): Variant;
  68. {$ENDIF}
  69. function CreateRotatedFont(Font: TFont; Angle: Integer): HFont;
  70. function MsgBox(const Caption, Text: string; Flags: Integer): Integer;
  71. function MsgDlg(const Msg: string; AType: TMsgDlgType;
  72.   AButtons: TMsgDlgButtons; HelpCtx: Longint): Word;
  73. {$IFDEF CBUILDER}
  74. function FindPrevInstance(const MainFormClass: ShortString;
  75.   const ATitle: string): HWnd;
  76. function ActivatePrevInstance(const MainFormClass: ShortString;
  77.   const ATitle: string): Boolean;
  78. {$ELSE}
  79. function FindPrevInstance(const MainFormClass, ATitle: string): HWnd;
  80. function ActivatePrevInstance(const MainFormClass, ATitle: string): Boolean;
  81. {$ENDIF CBUILDER}
  82. function IsForegroundTask: Boolean;
  83. procedure MergeForm(AControl: TWinControl; AForm: TForm; Align: TAlign;
  84.   Show: Boolean);
  85. function GetAveCharSize(Canvas: TCanvas): TPoint;
  86. function MinimizeText(const Text: string; Canvas: TCanvas;
  87.   MaxWidth: Integer): string;
  88. procedure FreeUnusedOle;
  89. procedure Beep;
  90. function GetWindowsVersion: string;
  91. function LoadDLL(const LibName: string): THandle;
  92. function RegisterServer(const ModuleName: string): Boolean;
  93. {$IFNDEF WIN32}
  94. function IsLibrary: Boolean;
  95. {$ENDIF}
  96.  
  97. { Gradient filling routine }
  98.  
  99. type
  100.   TFillDirection = (fdTopToBottom, fdBottomToTop, fdLeftToRight, fdRightToLeft);
  101.  
  102. procedure GradientFillRect(Canvas: TCanvas; ARect: TRect; StartColor,
  103.   EndColor: TColor; Direction: TFillDirection; Colors: Byte);
  104.  
  105. { String routines }
  106.  
  107. function GetEnvVar(const VarName: string): string;
  108. function AnsiUpperFirstChar(const S: string): string;
  109. function StringToPChar(var S: string): PChar;
  110. function StrPAlloc(const S: string): PChar;
  111. procedure SplitCommandLine(const CmdLine: string; var ExeName,
  112.   Params: string);
  113. function DropT(const S: string): string;
  114.  
  115. { Memory routines }
  116.  
  117. function AllocMemo(Size: Longint): Pointer;
  118. function ReallocMemo(fpBlock: Pointer; Size: Longint): Pointer;
  119. procedure FreeMemo(var fpBlock: Pointer);
  120. function GetMemoSize(fpBlock: Pointer): Longint;
  121. function CompareMem(fpBlock1, fpBlock2: Pointer; Size: Cardinal): Boolean;
  122. {$IFNDEF RX_D5}
  123. procedure FreeAndNil(var Obj);
  124. {$ENDIF}
  125.  
  126. { Manipulate huge pointers routines }
  127.  
  128. procedure HugeInc(var HugePtr: Pointer; Amount: Longint);
  129. procedure HugeDec(var HugePtr: Pointer; Amount: Longint);
  130. function HugeOffset(HugePtr: Pointer; Amount: Longint): Pointer;
  131. procedure HugeMove(Base: Pointer; Dst, Src, Size: Longint);
  132. {$IFDEF WIN32}
  133. procedure HMemCpy(DstPtr, SrcPtr: Pointer; Amount: Longint);
  134. {$ELSE}
  135. procedure ZeroMemory(Ptr: Pointer; Length: Longint);
  136. procedure FillMemory(Ptr: Pointer; Length: Longint; Fill: Byte);
  137. {$ENDIF WIN32}
  138.  
  139. { Standard Windows colors that are not defined by Delphi }
  140.  
  141. const
  142. {$IFNDEF WIN32}
  143.   clInfoBk = TColor($02E1FFFF);
  144.   clNone = TColor($02FFFFFF);
  145. {$ENDIF}
  146.   clCream = TColor($A6CAF0);
  147.   clMoneyGreen = TColor($C0DCC0);
  148.   clSkyBlue = TColor($FFFBF0);
  149.  
  150. { ModalResult constants }
  151.  
  152. {$IFNDEF RX_D3}
  153. const
  154.   mrNoToAll  = mrAll + 1;
  155.   mrYesToAll = mrNoToAll + 1;
  156. {$ENDIF}
  157.  
  158. {$IFNDEF RX_D4}
  159.  
  160. { Mouse Wheel message }
  161.  
  162. {$IFDEF WIN32}
  163.  
  164. {$IFDEF VER90}
  165. const
  166.   WM_MOUSEWHEEL    =    $020A;
  167.   WHEEL_DELTA      =      120;
  168.   WHEEL_PAGESCROLL = MAXDWORD;
  169.  
  170.   SM_MOUSEWHEELPRESENT    =    75;
  171.   MOUSEEVENTF_WHEEL       = $0800;
  172.   SPI_GETWHEELSCROLLLINES =   104;
  173.   SPI_SETWHEELSCROLLLINES =   105;
  174. {$ENDIF}
  175.  
  176. type
  177.   TWMMouseWheel = record
  178.     Msg: Cardinal;
  179.     Keys: Word;
  180.     Delta: Word;
  181.     case Integer of
  182.       0: (
  183.         XPos: Smallint;
  184.         YPos: Smallint);
  185.       1: (
  186.         Pos: TSmallPoint;
  187.         Result: Longint);
  188.   end;
  189.  
  190. {$ENDIF WIN32}
  191.  
  192. {$ENDIF RX_D4}
  193.  
  194. { Cursor routines }
  195.  
  196. const
  197.   WaitCursor: TCursor = crHourGlass;
  198.  
  199. procedure StartWait;
  200. procedure StopWait;
  201. function DefineCursor(Instance: THandle; ResID: PChar): TCursor;
  202. {$IFDEF WIN32}
  203. function LoadAniCursor(Instance: THandle; ResID: PChar): HCursor;
  204. {$ENDIF}
  205.  
  206. { Windows API level routines }
  207.  
  208. procedure StretchBltTransparent(DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
  209.   SrcDC: HDC; SrcX, SrcY, SrcW, SrcH: Integer; Palette: HPalette;
  210.   TransparentColor: TColorRef);
  211. procedure DrawTransparentBitmap(DC: HDC; Bitmap: HBitmap;
  212.   DstX, DstY: Integer; TransparentColor: TColorRef);
  213. function PaletteEntries(Palette: HPALETTE): Integer;
  214. function WindowClassName(Wnd: HWnd): string;
  215. function ScreenWorkArea: TRect;
  216. {$IFNDEF WIN32}
  217. procedure MoveWindowOrg(DC: HDC; DX, DY: Integer);
  218. {$ENDIF}
  219. procedure SwitchToWindow(Wnd: HWnd; Restore: Boolean);
  220. procedure ActivateWindow(Wnd: HWnd);
  221. procedure ShowWinNoAnimate(Handle: HWnd; CmdShow: Integer);
  222. procedure CenterWindow(Wnd: HWnd);
  223. procedure ShadeRect(DC: HDC; const Rect: TRect);
  224. procedure KillMessage(Wnd: HWnd; Msg: Cardinal);
  225.  
  226. { Convert dialog units to pixels and backwards }
  227.  
  228. function DialogUnitsToPixelsX(DlgUnits: Word): Word;
  229. function DialogUnitsToPixelsY(DlgUnits: Word): Word;
  230. function PixelsToDialogUnitsX(PixUnits: Word): Word;
  231. function PixelsToDialogUnitsY(PixUnits: Word): Word;
  232.  
  233. { Grid drawing }
  234.  
  235. type
  236.   TVertAlignment = (vaTopJustify, vaCenter, vaBottomJustify);
  237.  
  238. procedure WriteText(ACanvas: TCanvas; ARect: TRect; DX, DY: Integer;
  239.   const Text: string; Alignment: TAlignment; WordWrap: Boolean
  240.   {$IFDEF RX_D4}; ARightToLeft: Boolean = False {$ENDIF});
  241. procedure DrawCellText(Control: TCustomControl; ACol, ARow: Longint;
  242.   const S: string; const ARect: TRect; Align: TAlignment;
  243.   VertAlign: TVertAlignment); {$IFDEF RX_D4} overload; {$ENDIF}
  244. procedure DrawCellTextEx(Control: TCustomControl; ACol, ARow: Longint;
  245.   const S: string; const ARect: TRect; Align: TAlignment;
  246.   VertAlign: TVertAlignment; WordWrap: Boolean); {$IFDEF RX_D4} overload; {$ENDIF}
  247. {$IFDEF RX_D4}
  248. procedure DrawCellText(Control: TCustomControl; ACol, ARow: Longint;
  249.   const S: string; const ARect: TRect; Align: TAlignment;
  250.   VertAlign: TVertAlignment; ARightToLeft: Boolean); overload;
  251. procedure DrawCellTextEx(Control: TCustomControl; ACol, ARow: Longint;
  252.   const S: string; const ARect: TRect; Align: TAlignment;
  253.   VertAlign: TVertAlignment; WordWrap: Boolean; ARightToLeft: Boolean); overload;
  254. {$ENDIF}
  255. procedure DrawCellBitmap(Control: TCustomControl; ACol, ARow: Longint;
  256.   Bmp: TGraphic; Rect: TRect);
  257.  
  258. { TScreenCanvas }
  259.  
  260. type
  261.   TScreenCanvas = class(TCanvas)
  262.   private
  263.     FDeviceContext: HDC;
  264.   protected
  265.     procedure CreateHandle; override;
  266.   public
  267.     destructor Destroy; override;
  268.     procedure SetOrigin(X, Y: Integer);
  269.     procedure FreeHandle;
  270.   end;
  271.  
  272. {$IFNDEF WIN32}
  273.  
  274. { TBits }
  275.  
  276.   TBits = class
  277.   private
  278.     FSize: Integer;
  279.     FBits: Pointer;
  280.     procedure SetSize(Value: Integer);
  281.     procedure SetBit(Index: Integer; Value: Boolean);
  282.     function GetBit(Index: Integer): Boolean;
  283.   public
  284.     destructor Destroy; override;
  285.     function OpenBit: Integer;
  286.     property Bits[Index: Integer]: Boolean read GetBit write SetBit; default;
  287.     property Size: Integer read FSize write SetSize;
  288.   end;
  289.  
  290. { TMetafileCanvas }
  291.  
  292.   TMetafileCanvas = class(TCanvas)
  293.   private
  294.     FMetafile: TMetafile;
  295.   public
  296.     constructor Create(AMetafile: TMetafile; ReferenceDevice: HDC);
  297.     destructor Destroy; override;
  298.     property Metafile: TMetafile read FMetafile;
  299.   end;
  300.  
  301. { TResourceStream }
  302.  
  303.   TResourceStream = class(THandleStream)
  304.   private
  305.     FStartPos: LongInt;
  306.     FEndPos: LongInt;
  307.   protected
  308.     constructor CreateFromPChar(Instance: THandle; ResName, ResType: PChar);
  309.   public
  310.     constructor Create(Instance: THandle; const ResName: string; ResType: PChar);
  311.     constructor CreateFromID(Instance: THandle; ResID: Integer; ResType: PChar);
  312.     destructor Destroy; override;
  313.     function Seek(Offset: Longint; Origin: Word): Longint; override;
  314.     function Write(const Buffer; Count: Longint): Longint; override;
  315.   end;
  316.  
  317. function GetCurrentDir: string;
  318. function SetCurrentDir(const Dir: string): Boolean;
  319.  
  320. {$ENDIF WIN32}
  321.  
  322. {$IFDEF WIN32}
  323. function CheckWin32(OK: Boolean): Boolean; { obsolete, use Win32Check }
  324. {$IFNDEF RX_D3}
  325. function Win32Check(RetVal: Bool): Bool;
  326. {$ENDIF}
  327. procedure RaiseWin32Error(ErrorCode: DWORD);
  328. {$ENDIF WIN32}
  329.  
  330. {$IFNDEF RX_D3} { for Delphi 3.0 and previous versions compatibility }
  331. type
  332.   TCustomForm = TForm;
  333.   TDate = TDateTime;
  334.   TTime = TDateTime;
  335.  
  336. function ResStr(Ident: Cardinal): string;
  337. {$ELSE}
  338. function ResStr(const Ident: string): string;
  339. {$ENDIF RX_D3}
  340.  
  341. {$IFNDEF RX_D4}
  342. type
  343.   Longword = Longint;
  344. {$ENDIF}
  345.  
  346. implementation
  347.  
  348. Uses RTLConsts, SysUtils, Messages, MaxMin, Consts, RxConst, {$IFDEF RX_V110} SysConst, {$ENDIF}
  349.   {$IFDEF WIN32} CommCtrl, {$ELSE} Str16, {$ENDIF} RxCConst;
  350.  
  351. { Exceptions }
  352.  
  353. procedure ResourceNotFound(ResID: PChar);
  354. var
  355.   S: string;
  356. begin
  357.   if LongRec(ResID).Hi = 0 then S := IntToStr(LongRec(ResID).Lo)
  358.   else S := StrPas(ResID);
  359.   raise EResNotFound.CreateFmt(ResStr(SResNotFound), [S]);
  360. end;
  361.  
  362. { Bitmaps }
  363.  
  364. function MakeModuleBitmap(Module: THandle; ResID: PChar): TBitmap;
  365. {$IFNDEF WIN32}
  366. var
  367.   S: TStream;
  368. {$ENDIF}
  369. begin
  370.   Result := TBitmap.Create;
  371.   try
  372. {$IFDEF WIN32}
  373.     if Module <> 0 then begin
  374.       if LongRec(ResID).Hi = 0 then
  375.         Result.LoadFromResourceID(Module, LongRec(ResID).Lo)
  376.       else
  377.         Result.LoadFromResourceName(Module, StrPas(ResID));
  378.     end
  379.     else begin
  380.       Result.Handle := LoadBitmap(Module, ResID);
  381.       if Result.Handle = 0 then ResourceNotFound(ResID);
  382.     end;
  383. {$ELSE}
  384.     Result.Handle := LoadBitmap(Module, ResID);
  385.     if Result.Handle = 0 then ResourceNotFound(ResID);
  386. {$ENDIF}
  387.   except
  388.     Result.Free;
  389.     Result := nil;
  390.   end;
  391. end;
  392.  
  393. function MakeBitmap(ResID: PChar): TBitmap;
  394. begin
  395.   Result := MakeModuleBitmap(hInstance, ResID);
  396. end;
  397.  
  398. function MakeBitmapID(ResID: Word): TBitmap;
  399. begin
  400.   Result := MakeModuleBitmap(hInstance, MakeIntResource(ResID));
  401. end;
  402.  
  403. procedure AssignBitmapCell(Source: TGraphic; Dest: TBitmap; Cols, Rows,
  404.   Index: Integer);
  405. var
  406.   CellWidth, CellHeight: Integer;
  407. begin
  408.   if (Source <> nil) and (Dest <> nil) then begin
  409.     if Cols <= 0 then Cols := 1;
  410.     if Rows <= 0 then Rows := 1;
  411.     if Index < 0 then Index := 0;
  412.     CellWidth := Source.Width div Cols;
  413.     CellHeight := Source.Height div Rows;
  414.     with Dest do begin
  415.       Width := CellWidth; Height := CellHeight;
  416.     end;
  417.     if Source is TBitmap then begin
  418.       Dest.Canvas.CopyRect(Bounds(0, 0, CellWidth, CellHeight),
  419.         TBitmap(Source).Canvas, Bounds((Index mod Cols) * CellWidth,
  420.         (Index div Cols) * CellHeight, CellWidth, CellHeight));
  421. {$IFDEF RX_D3}
  422.       Dest.TransparentColor := TBitmap(Source).TransparentColor;
  423. {$ENDIF RX_D3}
  424.     end
  425.     else begin
  426.       Dest.Canvas.Brush.Color := clSilver;
  427.       Dest.Canvas.FillRect(Bounds(0, 0, CellWidth, CellHeight));
  428.       Dest.Canvas.Draw(-(Index mod Cols) * CellWidth,
  429.         -(Index div Cols) * CellHeight, Source);
  430.     end;
  431. {$IFDEF RX_D3}
  432.     Dest.Transparent := Source.Transparent;
  433. {$ENDIF RX_D3}
  434.   end;
  435. end;
  436.  
  437. type
  438.   TParentControl = class(TWinControl);
  439.  
  440. procedure CopyParentImage(Control: TControl; Dest: TCanvas);
  441. var
  442.   I, Count, X, Y, SaveIndex: Integer;
  443.   DC: HDC;
  444.   R, SelfR, CtlR: TRect;
  445. begin
  446.   if (Control = nil) or (Control.Parent = nil) then Exit;
  447.   Count := Control.Parent.ControlCount;
  448.   DC := Dest.Handle;
  449. {$IFDEF WIN32}
  450.   with Control.Parent do ControlState := ControlState + [csPaintCopy];
  451.   try
  452. {$ENDIF}
  453.     with Control do begin
  454.       SelfR := Bounds(Left, Top, Width, Height);
  455.       X := -Left; Y := -Top;
  456.     end;
  457.     { Copy parent control image }
  458.     SaveIndex := SaveDC(DC);
  459.     try
  460.       SetViewportOrgEx(DC, X, Y, nil);
  461.       IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth,
  462.         Control.Parent.ClientHeight);
  463.       with TParentControl(Control.Parent) do begin
  464.         Perform(WM_ERASEBKGND, DC, 0);
  465.         PaintWindow(DC);
  466.       end;
  467.     finally
  468.       RestoreDC(DC, SaveIndex);
  469.     end;
  470.     { Copy images of graphic controls }
  471.     for I := 0 to Count - 1 do begin
  472.       if Control.Parent.Controls[I] = Control then Break
  473.       else if (Control.Parent.Controls[I] <> nil) and
  474.         (Control.Parent.Controls[I] is TGraphicControl) then
  475.       begin
  476.         with TGraphicControl(Control.Parent.Controls[I]) do begin
  477.           CtlR := Bounds(Left, Top, Width, Height);
  478.           if Bool(IntersectRect(R, SelfR, CtlR)) and Visible then begin
  479. {$IFDEF WIN32}
  480.             ControlState := ControlState + [csPaintCopy];
  481. {$ENDIF}
  482.             SaveIndex := SaveDC(DC);
  483.             try
  484.               SaveIndex := SaveDC(DC);
  485.               SetViewportOrgEx(DC, Left + X, Top + Y, nil);
  486.               IntersectClipRect(DC, 0, 0, Width, Height);
  487.               Perform(WM_PAINT, DC, 0);
  488.             finally
  489.               RestoreDC(DC, SaveIndex);
  490. {$IFDEF WIN32}
  491.               ControlState := ControlState - [csPaintCopy];
  492. {$ENDIF}
  493.             end;
  494.           end;
  495.         end;
  496.       end;
  497.     end;
  498. {$IFDEF WIN32}
  499.   finally
  500.     with Control.Parent do ControlState := ControlState - [csPaintCopy];
  501.   end;
  502. {$ENDIF}
  503. end;
  504.  
  505. { Transparent bitmap }
  506.  
  507. procedure StretchBltTransparent(DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
  508.   SrcDC: HDC; SrcX, SrcY, SrcW, SrcH: Integer; Palette: HPalette;
  509.   TransparentColor: TColorRef);
  510. var
  511.   Color: TColorRef;
  512.   bmAndBack, bmAndObject, bmAndMem, bmSave: HBitmap;
  513.   bmBackOld, bmObjectOld, bmMemOld, bmSaveOld: HBitmap;
  514.   MemDC, BackDC, ObjectDC, SaveDC: HDC;
  515.   palDst, palMem, palSave, palObj: HPalette;
  516. begin
  517.   { Create some DCs to hold temporary data }
  518.   BackDC := CreateCompatibleDC(DstDC);
  519.   ObjectDC := CreateCompatibleDC(DstDC);
  520.   MemDC := CreateCompatibleDC(DstDC);
  521.   SaveDC := CreateCompatibleDC(DstDC);
  522.   { Create a bitmap for each DC }
  523.   bmAndObject := CreateBitmap(SrcW, SrcH, 1, 1, nil);
  524.   bmAndBack := CreateBitmap(SrcW, SrcH, 1, 1, nil);
  525.   bmAndMem := CreateCompatibleBitmap(DstDC, DstW, DstH);
  526.   bmSave := CreateCompatibleBitmap(DstDC, SrcW, SrcH);
  527.   { Each DC must select a bitmap object to store pixel data }
  528.   bmBackOld := SelectObject(BackDC, bmAndBack);
  529.   bmObjectOld := SelectObject(ObjectDC, bmAndObject);
  530.   bmMemOld := SelectObject(MemDC, bmAndMem);
  531.   bmSaveOld := SelectObject(SaveDC, bmSave);
  532.   { Select palette }
  533.   palDst := 0; palMem := 0; palSave := 0; palObj := 0;
  534.   if Palette <> 0 then begin
  535.     palDst := SelectPalette(DstDC, Palette, True);
  536.     RealizePalette(DstDC);
  537.     palSave := SelectPalette(SaveDC, Palette, False);
  538.     RealizePalette(SaveDC);
  539.     palObj := SelectPalette(ObjectDC, Palette, False);
  540.     RealizePalette(ObjectDC);
  541.     palMem := SelectPalette(MemDC, Palette, True);
  542.     RealizePalette(MemDC);
  543.   end;
  544.   { Set proper mapping mode }
  545.   SetMapMode(SrcDC, GetMapMode(DstDC));
  546.   SetMapMode(SaveDC, GetMapMode(DstDC));
  547.   { Save the bitmap sent here }
  548.   BitBlt(SaveDC, 0, 0, SrcW, SrcH, SrcDC, SrcX, SrcY, SRCCOPY);
  549.   { Set the background color of the source DC to the color,         }
  550.   { contained in the parts of the bitmap that should be transparent }
  551.   Color := SetBkColor(SaveDC, PaletteColor(TransparentColor));
  552.   { Create the object mask for the bitmap by performing a BitBlt()  }
  553.   { from the source bitmap to a monochrome bitmap                   }
  554.   BitBlt(ObjectDC, 0, 0, SrcW, SrcH, SaveDC, 0, 0, SRCCOPY);
  555.   { Set the background color of the source DC back to the original  }
  556.   SetBkColor(SaveDC, Color);
  557.   { Create the inverse of the object mask }
  558.   BitBlt(BackDC, 0, 0, SrcW, SrcH, ObjectDC, 0, 0, NOTSRCCOPY);
  559.   { Copy the background of the main DC to the destination }
  560.   BitBlt(MemDC, 0, 0, DstW, DstH, DstDC, DstX, DstY, SRCCOPY);
  561.   { Mask out the places where the bitmap will be placed }
  562.   StretchBlt(MemDC, 0, 0, DstW, DstH, ObjectDC, 0, 0, SrcW, SrcH, SRCAND);
  563.   { Mask out the transparent colored pixels on the bitmap }
  564.   BitBlt(SaveDC, 0, 0, SrcW, SrcH, BackDC, 0, 0, SRCAND);
  565.   { XOR the bitmap with the background on the destination DC }
  566.   StretchBlt(MemDC, 0, 0, DstW, DstH, SaveDC, 0, 0, SrcW, SrcH, SRCPAINT);
  567.   { Copy the destination to the screen }
  568.   BitBlt(DstDC, DstX, DstY, DstW, DstH, MemDC, 0, 0,
  569.     SRCCOPY);
  570.   { Restore palette }
  571.   if Palette <> 0 then begin
  572.     SelectPalette(MemDC, palMem, False);
  573.     SelectPalette(ObjectDC, palObj, False);
  574.     SelectPalette(SaveDC, palSave, False);
  575.     SelectPalette(DstDC, palDst, True);
  576.   end;
  577.   { Delete the memory bitmaps }
  578.   DeleteObject(SelectObject(BackDC, bmBackOld));
  579.   DeleteObject(SelectObject(ObjectDC, bmObjectOld));
  580.   DeleteObject(SelectObject(MemDC, bmMemOld));
  581.   DeleteObject(SelectObject(SaveDC, bmSaveOld));
  582.   { Delete the memory DCs }
  583.   DeleteDC(MemDC);
  584.   DeleteDC(BackDC);
  585.   DeleteDC(ObjectDC);
  586.   DeleteDC(SaveDC);
  587. end;
  588.  
  589. procedure DrawTransparentBitmapRect(DC: HDC; Bitmap: HBitmap; DstX, DstY,
  590.   DstW, DstH: Integer; SrcRect: TRect; TransparentColor: TColorRef);
  591. var
  592.   hdcTemp: HDC;
  593. begin
  594.   hdcTemp := CreateCompatibleDC(DC);
  595.   try
  596.     SelectObject(hdcTemp, Bitmap);
  597.     with SrcRect do
  598.       StretchBltTransparent(DC, DstX, DstY, DstW, DstH, hdcTemp,
  599.         Left, Top, Right - Left, Bottom - Top, 0, TransparentColor);
  600.   finally
  601.     DeleteDC(hdcTemp);
  602.   end;
  603. end;
  604.  
  605. procedure DrawTransparentBitmap(DC: HDC; Bitmap: HBitmap;
  606.   DstX, DstY: Integer; TransparentColor: TColorRef);
  607. var
  608.   BM: {$IFDEF WIN32} Windows.TBitmap {$ELSE} WinTypes.TBitmap {$ENDIF};
  609. begin
  610.   GetObject(Bitmap, SizeOf(BM), @BM);
  611.   DrawTransparentBitmapRect(DC, Bitmap, DstX, DstY, BM.bmWidth, BM.bmHeight,
  612.     Rect(0, 0, BM.bmWidth, BM.bmHeight), TransparentColor);
  613. end;
  614.  
  615. procedure StretchBitmapTransparent(Dest: TCanvas; Bitmap: TBitmap;
  616.   TransparentColor: TColor; DstX, DstY, DstW, DstH, SrcX, SrcY,
  617.   SrcW, SrcH: Integer);
  618. var
  619.   CanvasChanging: TNotifyEvent;
  620. begin
  621.   if DstW <= 0 then DstW := Bitmap.Width;
  622.   if DstH <= 0 then DstH := Bitmap.Height;
  623.   if (SrcW <= 0) or (SrcH <= 0) then begin
  624.     SrcX := 0; SrcY := 0;
  625.     SrcW := Bitmap.Width;
  626.     SrcH := Bitmap.Height;
  627.   end;
  628.   if not Bitmap.Monochrome then
  629.     SetStretchBltMode(Dest.Handle, STRETCH_DELETESCANS);
  630.   CanvasChanging := Bitmap.Canvas.OnChanging;
  631. {$IFDEF RX_D3}
  632.   Bitmap.Canvas.Lock;
  633. {$ENDIF}
  634.   try
  635.     Bitmap.Canvas.OnChanging := nil;
  636.     if TransparentColor = clNone then begin
  637.       StretchBlt(Dest.Handle, DstX, DstY, DstW, DstH, Bitmap.Canvas.Handle,
  638.         SrcX, SrcY, SrcW, SrcH, Dest.CopyMode);
  639.     end
  640.     else begin
  641. {$IFDEF RX_D3}
  642.       if TransparentColor = clDefault then
  643.         TransparentColor := Bitmap.Canvas.Pixels[0, Bitmap.Height - 1];
  644. {$ENDIF}
  645.       if Bitmap.Monochrome then TransparentColor := clWhite
  646.       else TransparentColor := ColorToRGB(TransparentColor);
  647.       StretchBltTransparent(Dest.Handle, DstX, DstY, DstW, DstH,
  648.         Bitmap.Canvas.Handle, SrcX, SrcY, SrcW, SrcH, Bitmap.Palette,
  649.         TransparentColor);
  650.     end;
  651.   finally
  652.     Bitmap.Canvas.OnChanging := CanvasChanging;
  653. {$IFDEF RX_D3}
  654.     Bitmap.Canvas.Unlock;
  655. {$ENDIF}
  656.   end;
  657. end;
  658.  
  659. procedure StretchBitmapRectTransparent(Dest: TCanvas; DstX, DstY,
  660.   DstW, DstH: Integer; SrcRect: TRect; Bitmap: TBitmap;
  661.   TransparentColor: TColor);
  662. begin
  663.   with SrcRect do
  664.     StretchBitmapTransparent(Dest, Bitmap, TransparentColor,
  665.     DstX, DstY, DstW, DstH, Left, Top, Right - Left, Bottom - Top);
  666. end;
  667.  
  668. procedure DrawBitmapRectTransparent(Dest: TCanvas; DstX, DstY: Integer;
  669.   SrcRect: TRect; Bitmap: TBitmap; TransparentColor: TColor);
  670. begin
  671.   with SrcRect do
  672.     StretchBitmapTransparent(Dest, Bitmap, TransparentColor,
  673.     DstX, DstY, Right - Left, Bottom - Top, Left, Top, Right - Left,
  674.     Bottom - Top);
  675. end;
  676.  
  677. procedure DrawBitmapTransparent(Dest: TCanvas; DstX, DstY: Integer;
  678.   Bitmap: TBitmap; TransparentColor: TColor);
  679. begin
  680.   StretchBitmapTransparent(Dest, Bitmap, TransparentColor, DstX, DstY,
  681.     Bitmap.Width, Bitmap.Height, 0, 0, Bitmap.Width, Bitmap.Height);
  682. end;
  683.  
  684. { ChangeBitmapColor. This function create new TBitmap object.
  685.   You must destroy it outside by calling TBitmap.Free method. }
  686.  
  687. function ChangeBitmapColor(Bitmap: TBitmap; Color, NewColor: TColor): TBitmap;
  688. var
  689.   R: TRect;
  690. begin
  691.   Result := TBitmap.Create;
  692.   try
  693.     with Result do begin
  694.       Height := Bitmap.Height;
  695.       Width := Bitmap.Width;
  696.       R := Bounds(0, 0, Width, Height);
  697.       Canvas.Brush.Color := NewColor;
  698.       Canvas.FillRect(R);
  699.       Canvas.BrushCopy(R, Bitmap, R, Color);
  700.     end;
  701.   except
  702.     Result.Free;
  703.     raise;
  704.   end;
  705. end;
  706.  
  707. { CreateDisabledBitmap. Creating TBitmap object with disable button glyph
  708.   image. You must destroy it outside by calling TBitmap.Free method. }
  709.  
  710. const
  711.   ROP_DSPDxax = $00E20746;
  712.  
  713. function CreateDisabledBitmapEx(FOriginal: TBitmap; OutlineColor, BackColor,
  714.   HighlightColor, ShadowColor: TColor; DrawHighlight: Boolean): TBitmap;
  715. var
  716.   MonoBmp: TBitmap;
  717.   IRect: TRect;
  718. begin
  719.   IRect := Rect(0, 0, FOriginal.Width, FOriginal.Height);
  720.   Result := TBitmap.Create;
  721.   try
  722.     Result.Width := FOriginal.Width;
  723.     Result.Height := FOriginal.Height;
  724.     MonoBmp := TBitmap.Create;
  725.     try
  726.       with MonoBmp do begin
  727.         Width := FOriginal.Width;
  728.         Height := FOriginal.Height;
  729.         Canvas.CopyRect(IRect, FOriginal.Canvas, IRect);
  730. {$IFDEF RX_D3}
  731.         HandleType := bmDDB;
  732. {$ENDIF}
  733.         Canvas.Brush.Color := OutlineColor;
  734.         if Monochrome then begin
  735.           Canvas.Font.Color := clWhite;
  736.           Monochrome := False;
  737.           Canvas.Brush.Color := clWhite;
  738.         end;
  739.         Monochrome := True;
  740.       end;
  741.       with Result.Canvas do begin
  742.         Brush.Color := BackColor;
  743.         FillRect(IRect);
  744.         if DrawHighlight then begin
  745.           Brush.Color := HighlightColor;
  746.           SetTextColor(Handle, clBlack);
  747.           SetBkColor(Handle, clWhite);
  748.           BitBlt(Handle, 1, 1, WidthOf(IRect), HeightOf(IRect),
  749.             MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
  750.         end;
  751.         Brush.Color := ShadowColor;
  752.         SetTextColor(Handle, clBlack);
  753.         SetBkColor(Handle, clWhite);
  754.         BitBlt(Handle, 0, 0, WidthOf(IRect), HeightOf(IRect),
  755.           MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
  756.       end;
  757.     finally
  758.       MonoBmp.Free;
  759.     end;
  760.   except
  761.     Result.Free;
  762.     raise;
  763.   end;
  764. end;
  765.  
  766. function CreateDisabledBitmap(FOriginal: TBitmap; OutlineColor: TColor): TBitmap;
  767. begin
  768.   Result := CreateDisabledBitmapEx(FOriginal, OutlineColor,
  769.     clBtnFace, clBtnHighlight, clBtnShadow, True);
  770. end;
  771.  
  772. {$IFDEF WIN32}
  773. procedure ImageListDrawDisabled(Images: TImageList; Canvas: TCanvas;
  774.   X, Y, Index: Integer; HighlightColor, GrayColor: TColor; DrawHighlight: Boolean);
  775. var
  776.   Bmp: TBitmap;
  777.   SaveColor: TColor;
  778. begin
  779.   SaveColor := Canvas.Brush.Color;
  780.   Bmp := TBitmap.Create;
  781.   try
  782.     Bmp.Width := Images.Width;
  783.     Bmp.Height := Images.Height;
  784.     with Bmp.Canvas do begin
  785.       Brush.Color := clWhite;
  786.       FillRect(Rect(0, 0, Images.Width, Images.Height));
  787.       ImageList_Draw(Images.Handle, Index, Handle, 0, 0, ILD_MASK);
  788.     end;
  789.     Bmp.Monochrome := True;
  790.     if DrawHighlight then begin
  791.       Canvas.Brush.Color := HighlightColor;
  792.       SetTextColor(Canvas.Handle, clWhite);
  793.       SetBkColor(Canvas.Handle, clBlack);
  794.       BitBlt(Canvas.Handle, X + 1, Y + 1, Images.Width,
  795.         Images.Height, Bmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
  796.     end;
  797.     Canvas.Brush.Color := GrayColor;
  798.     SetTextColor(Canvas.Handle, clWhite);
  799.     SetBkColor(Canvas.Handle, clBlack);
  800.     BitBlt(Canvas.Handle, X, Y, Images.Width,
  801.       Images.Height, Bmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
  802.   finally
  803.     Bmp.Free;
  804.     Canvas.Brush.Color := SaveColor;
  805.   end;
  806. end;
  807. {$ENDIF}
  808.  
  809. { Brush Pattern }
  810.  
  811. function CreateTwoColorsBrushPattern(Color1, Color2: TColor): TBitmap;
  812. var
  813.   X, Y: Integer;
  814. begin
  815.   Result := TBitmap.Create;
  816.   Result.Width := 8;
  817.   Result.Height := 8;
  818.   with Result.Canvas do
  819.   begin
  820.     Brush.Style := bsSolid;
  821.     Brush.Color := Color1;
  822.     FillRect(Rect(0, 0, Result.Width, Result.Height));
  823.     for Y := 0 to 7 do
  824.       for X := 0 to 7 do
  825.         if (Y mod 2) = (X mod 2) then  { toggles between even/odd pixles }
  826.           Pixels[X, Y] := Color2;      { on even/odd rows }
  827.   end;
  828. end;
  829.  
  830. { Icons }
  831.  
  832. function MakeIcon(ResID: PChar): TIcon;
  833. begin
  834.   Result := MakeModuleIcon(hInstance, ResID);
  835. end;
  836.  
  837. function MakeIconID(ResID: Word): TIcon;
  838. begin
  839.   Result := MakeModuleIcon(hInstance, MakeIntResource(ResID));
  840. end;
  841.  
  842. function MakeModuleIcon(Module: THandle; ResID: PChar): TIcon;
  843. begin
  844.   Result := TIcon.Create;
  845.   Result.Handle := LoadIcon(Module, ResID);
  846.   if Result.Handle = 0 then begin
  847.     Result.Free;
  848.     Result := nil;
  849.   end;
  850. end;
  851.  
  852. { Create TBitmap object from TIcon }
  853.  
  854. function CreateBitmapFromIcon(Icon: TIcon; BackColor: TColor): TBitmap;
  855. var
  856.   IWidth, IHeight: Integer;
  857. begin
  858.   IWidth := Icon.Width;
  859.   IHeight := Icon.Height;
  860.   Result := TBitmap.Create;
  861.   try
  862.     Result.Width := IWidth;
  863.     Result.Height := IHeight;
  864.     with Result.Canvas do begin
  865.       Brush.Color := BackColor;
  866.       FillRect(Rect(0, 0, IWidth, IHeight));
  867.       Draw(0, 0, Icon);
  868.     end;
  869. {$IFDEF RX_D3}
  870.     Result.TransparentColor := BackColor;
  871.     Result.Transparent := True;
  872. {$ENDIF}
  873.   except
  874.     Result.Free;
  875.     raise;
  876.   end;
  877. end;
  878.  
  879. {$IFDEF WIN32}
  880. function CreateIconFromBitmap(Bitmap: TBitmap; TransparentColor: TColor): TIcon;
  881. begin
  882.   with TImageList.CreateSize(Bitmap.Width, Bitmap.Height) do
  883.   try
  884. {$IFDEF RX_D3}
  885.     if TransparentColor = clDefault then
  886.       TransparentColor := Bitmap.TransparentColor;
  887. {$ENDIF}
  888.     AllocBy := 1;
  889.     AddMasked(Bitmap, TransparentColor);
  890.     Result := TIcon.Create;
  891.     try
  892.       GetIcon(0, Result);
  893.     except
  894.       Result.Free;
  895.       raise;
  896.     end;
  897.   finally
  898.     Free;
  899.   end;
  900. end;
  901. {$ENDIF WIN32}
  902.  
  903. { Dialog units }
  904.  
  905. function DialogUnitsToPixelsX(DlgUnits: Word): Word;
  906. begin
  907.   Result := (DlgUnits * LoWord(GetDialogBaseUnits)) div 4;
  908. end;
  909.  
  910. function DialogUnitsToPixelsY(DlgUnits: Word): Word;
  911. begin
  912.   Result := (DlgUnits * HiWord(GetDialogBaseUnits)) div 8;
  913. end;
  914.  
  915. function PixelsToDialogUnitsX(PixUnits: Word): Word;
  916. begin
  917.   Result := PixUnits * 4 div LoWord(GetDialogBaseUnits);
  918. end;
  919.  
  920. function PixelsToDialogUnitsY(PixUnits: Word): Word;
  921. begin
  922.   Result := PixUnits * 8 div HiWord(GetDialogBaseUnits);
  923. end;
  924.  
  925. { Service routines }
  926.  
  927. type
  928.   THack = class(TCustomControl);
  929.  
  930. function LoadDLL(const LibName: string): THandle;
  931. var
  932.   ErrMode: Cardinal;
  933. {$IFNDEF WIN32}
  934.   P: array[0..255] of Char;
  935. {$ENDIF}
  936. begin
  937.   ErrMode := SetErrorMode(SEM_NOOPENFILEERRORBOX);
  938. {$IFDEF WIN32}
  939.   Result := LoadLibrary(PChar(LibName));
  940. {$ELSE}
  941.   Result := LoadLibrary(StrPCopy(P, LibName));
  942. {$ENDIF}
  943.   SetErrorMode(ErrMode);
  944.   if Result < HINSTANCE_ERROR then
  945. {$IFDEF WIN32}
  946.     Win32Check(False);
  947. {$ELSE}
  948.     raise EOutOfResources.CreateResFmt(SLoadLibError, [LibName]);
  949. {$ENDIF}
  950. end;
  951.  
  952. function RegisterServer(const ModuleName: string): Boolean;
  953. { RegisterServer procedure written by Vladimir Gaitanoff, 2:50/430.2 }
  954. type
  955.   TProc = procedure;
  956. var
  957.   Handle: THandle;
  958.   DllRegServ: Pointer;
  959. begin
  960.   Result := False;
  961.   Handle := LoadDLL(ModuleName);
  962.   try
  963.     DllRegServ := GetProcAddress(Handle, 'DllRegisterServer');
  964.     if Assigned(DllRegServ) then begin
  965.       TProc(DllRegServ);
  966.       Result := True;
  967.     end;
  968.   finally
  969.     FreeLibrary(Handle);
  970.   end;
  971. end;
  972.  
  973. procedure Beep;
  974. begin
  975.   MessageBeep(0);
  976. end;
  977.  
  978. procedure FreeUnusedOle;
  979. begin
  980. {$IFDEF WIN32}
  981.   FreeLibrary(GetModuleHandle('OleAut32'));
  982. {$ENDIF}
  983. end;
  984.  
  985. procedure NotImplemented;
  986. begin
  987.   Screen.Cursor := crDefault;
  988.   MessageDlg(LoadStr(SNotImplemented), mtInformation, [mbOk], 0);
  989.   Abort;
  990. end;
  991.  
  992. {$IFNDEF WIN32}
  993.  
  994. procedure MoveWindowOrg(DC: HDC; DX, DY: Integer);
  995. var
  996.   P: TPoint;
  997. begin
  998.   GetWindowOrgEx(DC, @P);
  999.   SetWindowOrgEx(DC, P.X - DX, P.Y - DY, nil);
  1000. end;
  1001.  
  1002. function IsLibrary: Boolean;
  1003. begin
  1004.   Result := (PrefixSeg = 0);
  1005. end;
  1006.  
  1007. {$ENDIF WIN32}
  1008.  
  1009. procedure PaintInverseRect(const RectOrg, RectEnd: TPoint);
  1010. var
  1011.   DC: HDC;
  1012.   R: TRect;
  1013. begin
  1014.   DC := GetDC(0);
  1015.   try
  1016.     R := Rect(RectOrg.X, RectOrg.Y, RectEnd.X, RectEnd.Y);
  1017.     InvertRect(DC, R);
  1018.   finally
  1019.     ReleaseDC(0, DC);
  1020.   end;
  1021. end;
  1022.  
  1023. procedure DrawInvertFrame(ScreenRect: TRect; Width: Integer);
  1024. var
  1025.   DC: HDC;
  1026.   I: Integer;
  1027. begin
  1028.   DC := GetDC(0);
  1029.   try
  1030.     for I := 1 to Width do begin
  1031.       DrawFocusRect(DC, ScreenRect);
  1032.       InflateRect(ScreenRect, -1, -1);
  1033.     end;
  1034.   finally
  1035.     ReleaseDC(0, DC);
  1036.   end;
  1037. end;
  1038.  
  1039. function WidthOf(R: TRect): Integer;
  1040. begin
  1041.   Result := R.Right - R.Left;
  1042. end;
  1043.  
  1044. function HeightOf(R: TRect): Integer;
  1045. begin
  1046.   Result := R.Bottom - R.Top;
  1047. end;
  1048.  
  1049. function PointInRect(const P: TPoint; const R: TRect): Boolean;
  1050. begin
  1051.   with R do
  1052.     Result := (Left <= P.X) and (Top <= P.Y) and
  1053.       (Right >= P.X) and (Bottom >= P.Y);
  1054. end;
  1055.  
  1056. function PointInPolyRgn(const P: TPoint; const Points: array of TPoint): Boolean;
  1057. type
  1058.   PPoints = ^TPoints;
  1059.   TPoints = array[0..0] of TPoint;
  1060. var
  1061.   Rgn: HRgn;
  1062. begin
  1063.   Rgn := CreatePolygonRgn(PPoints(@Points)^, High(Points) + 1, WINDING);
  1064.   try
  1065.     Result := PtInRegion(Rgn, P.X, P.Y);
  1066.   finally
  1067.     DeleteObject(Rgn);
  1068.   end;
  1069. end;
  1070.  
  1071. function PaletteColor(Color: TColor): Longint;
  1072. begin
  1073.   Result := ColorToRGB(Color) or PaletteMask;
  1074. end;
  1075.  
  1076. procedure KillMessage(Wnd: HWnd; Msg: Cardinal);
  1077. { Delete the requested message from the queue, but throw back }
  1078. { any WM_QUIT msgs that PeekMessage may also return.          }
  1079. { Copied from DbGrid.pas                                      }
  1080. var
  1081.   M: TMsg;
  1082. begin
  1083.   M.Message := 0;
  1084.   if PeekMessage(M, Wnd, Msg, Msg, PM_REMOVE) and (M.Message = WM_QUIT) then
  1085.     PostQuitMessage(M.WParam);
  1086. end;
  1087.  
  1088. function CreateRotatedFont(Font: TFont; Angle: Integer): HFont;
  1089. var
  1090.   LogFont: TLogFont;
  1091. begin
  1092.   FillChar(LogFont, SizeOf(LogFont), 0);
  1093.   with LogFont do begin
  1094.     lfHeight := Font.Height;
  1095.     lfWidth := 0;
  1096.     lfEscapement := Angle * 10;
  1097.     lfOrientation := 0;
  1098.     if fsBold in Font.Style then lfWeight := FW_BOLD
  1099.     else lfWeight := FW_NORMAL;
  1100.     lfItalic := Ord(fsItalic in Font.Style);
  1101.     lfUnderline := Ord(fsUnderline in Font.Style);
  1102.     lfStrikeOut := Byte(fsStrikeOut in Font.Style);
  1103. {$IFDEF RX_D3}
  1104.     lfCharSet := Byte(Font.Charset);
  1105.     if AnsiCompareText(Font.Name, 'Default') = 0 then
  1106.       StrPCopy(lfFaceName, DefFontData.Name)
  1107.     else
  1108.       StrPCopy(lfFaceName, Font.Name);
  1109. {$ELSE}
  1110.   {$IFDEF VER93}
  1111.     lfCharSet := Byte(Font.Charset);
  1112.   {$ELSE}
  1113.     lfCharSet := DEFAULT_CHARSET;
  1114.   {$ENDIF}
  1115.     StrPCopy(lfFaceName, Font.Name);
  1116. {$ENDIF}
  1117.     lfQuality := DEFAULT_QUALITY;
  1118.     lfOutPrecision := OUT_DEFAULT_PRECIS;
  1119.     lfClipPrecision := CLIP_DEFAULT_PRECIS;
  1120.     case Font.Pitch of
  1121.       fpVariable: lfPitchAndFamily := VARIABLE_PITCH;
  1122.       fpFixed: lfPitchAndFamily := FIXED_PITCH;
  1123.       else lfPitchAndFamily := DEFAULT_PITCH;
  1124.     end;
  1125.   end;
  1126.   Result := CreateFontIndirect(LogFont);
  1127. end;
  1128.  
  1129. procedure Delay(MSecs: Longint);
  1130. var
  1131.   FirstTickCount, Now: Longint;
  1132. begin
  1133.   FirstTickCount := GetTickCount;
  1134.   repeat
  1135.     Application.ProcessMessages;
  1136.     { allowing access to other controls, etc. }
  1137.     Now := GetTickCount;
  1138.   until (Now - FirstTickCount >= MSecs) or (Now < FirstTickCount);
  1139. end;
  1140.  
  1141. function PaletteEntries(Palette: HPALETTE): Integer;
  1142. begin
  1143.   GetObject(Palette, SizeOf(Integer), @Result);
  1144. end;
  1145.  
  1146. procedure CenterControl(Control: TControl);
  1147. var
  1148.   X, Y: Integer;
  1149. begin
  1150.   X := Control.Left;
  1151.   Y := Control.Top;
  1152.   if Control is TForm then begin
  1153.     with Control do begin
  1154.       if (TForm(Control).FormStyle = fsMDIChild) and
  1155.         (Application.MainForm <> nil) then
  1156.       begin
  1157.         X := (Application.MainForm.ClientWidth - Width) div 2;
  1158.         Y := (Application.MainForm.ClientHeight - Height) div 2;
  1159.       end
  1160.       else begin
  1161.         X := (Screen.Width - Width) div 2;
  1162.         Y := (Screen.Height - Height) div 2;
  1163.       end;
  1164.     end;
  1165.   end
  1166.   else if Control.Parent <> nil then begin
  1167.     with Control do begin
  1168.       Parent.HandleNeeded;
  1169.       X := (Parent.ClientWidth - Width) div 2;
  1170.       Y := (Parent.ClientHeight - Height) div 2;
  1171.     end;
  1172.   end;
  1173.   if X < 0 then X := 0;
  1174.   if Y < 0 then Y := 0;
  1175.   with Control do SetBounds(X, Y, Width, Height);
  1176. end;
  1177.  
  1178. procedure FitRectToScreen(var Rect: TRect);
  1179. var
  1180.   X, Y, Delta: Integer;
  1181. begin
  1182.   X := GetSystemMetrics(SM_CXSCREEN);
  1183.   Y := GetSystemMetrics(SM_CYSCREEN);
  1184.   with Rect do begin
  1185.     if Right > X then begin
  1186.       Delta := Right - Left;
  1187.       Right := X;
  1188.       Left := Right - Delta;
  1189.     end;
  1190.     if Left < 0 then begin
  1191.       Delta := Right - Left;
  1192.       Left := 0;
  1193.       Right := Left + Delta;
  1194.     end;
  1195.     if Bottom > Y then begin
  1196.       Delta := Bottom - Top;
  1197.       Bottom := Y;
  1198.       Top := Bottom - Delta;
  1199.     end;
  1200.     if Top < 0 then begin
  1201.       Delta := Bottom - Top;
  1202.       Top := 0;
  1203.       Bottom := Top + Delta;
  1204.     end;
  1205.   end;
  1206. end;
  1207.  
  1208. procedure CenterWindow(Wnd: HWnd);
  1209. var
  1210.   R: TRect;
  1211. begin
  1212.   GetWindowRect(Wnd, R);
  1213.   R := Rect((GetSystemMetrics(SM_CXSCREEN) - R.Right + R.Left) div 2,
  1214.     (GetSystemMetrics(SM_CYSCREEN) - R.Bottom + R.Top) div 2,
  1215.     R.Right - R.Left, R.Bottom - R.Top);
  1216.   FitRectToScreen(R);
  1217.   SetWindowPos(Wnd, 0, R.Left, R.Top, 0, 0, SWP_NOACTIVATE or
  1218.     SWP_NOSIZE or SWP_NOZORDER);
  1219. end;
  1220.  
  1221. procedure MergeForm(AControl: TWinControl; AForm: TForm; Align: TAlign;
  1222.   Show: Boolean);
  1223. var
  1224.   R: TRect;
  1225.   AutoScroll: Boolean;
  1226. begin
  1227.   AutoScroll := AForm.AutoScroll;
  1228.   AForm.Hide;
  1229.   THack(AForm).DestroyHandle;
  1230.   with AForm do begin
  1231.     BorderStyle := bsNone;
  1232.     BorderIcons := [];
  1233.     Parent := AControl;
  1234.   end;
  1235.   AControl.DisableAlign;
  1236.   try
  1237.     if Align <> alNone then AForm.Align := Align
  1238.     else begin
  1239.       R := AControl.ClientRect;
  1240.       AForm.SetBounds(R.Left + AForm.Left, R.Top + AForm.Top, AForm.Width,
  1241.         AForm.Height);
  1242.     end;
  1243.     AForm.AutoScroll := AutoScroll;
  1244.     AForm.Visible := Show;
  1245.   finally
  1246.     AControl.EnableAlign;
  1247.   end;
  1248. end;
  1249.  
  1250. {$IFDEF WIN32}
  1251.  
  1252. { ShowMDIClientEdge function has been copied from Inprise's FORMS.PAS unit,
  1253.   Delphi 4 version }
  1254. procedure ShowMDIClientEdge(ClientHandle: THandle; ShowEdge: Boolean);
  1255. var
  1256.   Style: Longint;
  1257. begin
  1258.   if ClientHandle <> 0 then
  1259.   begin
  1260.     Style := GetWindowLong(ClientHandle, GWL_EXSTYLE);
  1261.     if ShowEdge then
  1262.       if Style and WS_EX_CLIENTEDGE = 0 then
  1263.         Style := Style or WS_EX_CLIENTEDGE
  1264.       else
  1265.         Exit
  1266.     else if Style and WS_EX_CLIENTEDGE <> 0 then
  1267.       Style := Style and not WS_EX_CLIENTEDGE
  1268.     else
  1269.       Exit;
  1270.     SetWindowLong(ClientHandle, GWL_EXSTYLE, Style);
  1271.     SetWindowPos(ClientHandle, 0, 0,0,0,0, SWP_FRAMECHANGED or SWP_NOACTIVATE or
  1272.       SWP_NOMOVE or SWP_NOSIZE or SWP_NOZORDER);
  1273.   end;
  1274. end;
  1275.  
  1276. function MakeVariant(const Values: array of Variant): Variant;
  1277. begin
  1278.   if High(Values) - Low(Values) > 1 then
  1279.     Result := VarArrayOf(Values)
  1280.   else if High(Values) - Low(Values) = 1 then
  1281.     Result := Values[Low(Values)]
  1282.   else Result := Null;
  1283. end;
  1284.  
  1285. {$ENDIF WIN32}
  1286.  
  1287. { Shade rectangle }
  1288.  
  1289. procedure ShadeRect(DC: HDC; const Rect: TRect);
  1290. const
  1291.   HatchBits: array[0..7] of Word = ($11, $22, $44, $88, $11, $22, $44, $88);
  1292. var
  1293.   Bitmap: HBitmap;
  1294.   SaveBrush: HBrush;
  1295.   SaveTextColor, SaveBkColor: TColorRef;
  1296. begin
  1297.   Bitmap := CreateBitmap(8, 8, 1, 1, @HatchBits);
  1298.   SaveBrush := SelectObject(DC, CreatePatternBrush(Bitmap));
  1299.   try
  1300.     SaveTextColor := SetTextColor(DC, clWhite);
  1301.     SaveBkColor := SetBkColor(DC, clBlack);
  1302.     with Rect do PatBlt(DC, Left, Top, Right - Left, Bottom - Top, $00A000C9);
  1303.     SetBkColor(DC, SaveBkColor);
  1304.     SetTextColor(DC, SaveTextColor);
  1305.   finally
  1306.     DeleteObject(SelectObject(DC, SaveBrush));
  1307.     DeleteObject(Bitmap);
  1308.   end;
  1309. end;
  1310.  
  1311. function ScreenWorkArea: TRect;
  1312. {$IFNDEF WIN32}
  1313. const
  1314.   SPI_GETWORKAREA = 48;
  1315. {$ENDIF}
  1316. begin
  1317.   if not SystemParametersInfo(SPI_GETWORKAREA, 0, @Result, 0) then
  1318.     with Screen do Result := Bounds(0, 0, Width, Height);
  1319. end;
  1320.  
  1321. function WindowClassName(Wnd: HWnd): string;
  1322. var
  1323.   Buffer: array[0..255] of Char;
  1324. begin
  1325.   SetString(Result, Buffer, GetClassName(Wnd, Buffer, SizeOf(Buffer) - 1));
  1326. end;
  1327.  
  1328. {$IFDEF WIN32}
  1329.  
  1330. function GetAnimation: Boolean;
  1331. var
  1332.   Info: TAnimationInfo;
  1333. begin
  1334.   Info.cbSize := SizeOf(TAnimationInfo);
  1335.   if SystemParametersInfo(SPI_GETANIMATION, SizeOf(Info), @Info, 0) then
  1336. {$IFDEF RX_D3}
  1337.     Result := Info.iMinAnimate <> 0
  1338. {$ELSE}
  1339.     Result := Info.iMinAnimate
  1340. {$ENDIF}
  1341.   else Result := False;
  1342. end;
  1343.  
  1344. procedure SetAnimation(Value: Boolean);
  1345. var
  1346.   Info: TAnimationInfo;
  1347. begin
  1348.   Info.cbSize := SizeOf(TAnimationInfo);
  1349.   BOOL(Info.iMinAnimate) := Value;
  1350.   SystemParametersInfo(SPI_SETANIMATION, SizeOf(Info), @Info, 0);
  1351. end;
  1352.  
  1353. procedure ShowWinNoAnimate(Handle: HWnd; CmdShow: Integer);
  1354. var
  1355.   Animation: Boolean;
  1356. begin
  1357.   Animation := GetAnimation;
  1358.   if Animation then SetAnimation(False);
  1359.   ShowWindow(Handle, CmdShow);
  1360.   if Animation then SetAnimation(True);
  1361. end;
  1362.  
  1363. {$ELSE}
  1364.  
  1365. procedure ShowWinNoAnimate(Handle: HWnd; CmdShow: Integer);
  1366. begin
  1367.   ShowWindow(Handle, CmdShow);
  1368. end;
  1369.  
  1370. procedure SwitchToThisWindow(Wnd: HWnd; Restore: Bool); far; external 'USER'
  1371.   index 172;
  1372.  
  1373. {$ENDIF WIN32}
  1374.  
  1375. procedure SwitchToWindow(Wnd: HWnd; Restore: Boolean);
  1376. begin
  1377.   if IsWindowEnabled(Wnd) then begin
  1378. {$IFDEF WIN32}
  1379.     SetForegroundWindow(Wnd);
  1380.     if Restore and IsWindowVisible(Wnd) then begin
  1381.       if not IsZoomed(Wnd) then
  1382.         SendMessage(Wnd, WM_SYSCOMMAND, SC_RESTORE, 0);
  1383.       SetFocus(Wnd);
  1384.     end;
  1385. {$ELSE}
  1386.     SwitchToThisWindow(Wnd, Restore);
  1387. {$ENDIF}
  1388.   end;
  1389. end;
  1390.  
  1391. function GetWindowParent(Wnd: HWnd): HWnd;
  1392. begin
  1393. {$IFDEF WIN32}
  1394.   Result := GetWindowLong(Wnd, GWL_HWNDPARENT);
  1395. {$ELSE}
  1396.   Result := GetWindowWord(Wnd, GWW_HWNDPARENT);
  1397. {$ENDIF}
  1398. end;
  1399.  
  1400. procedure ActivateWindow(Wnd: HWnd);
  1401. begin
  1402.   if Wnd <> 0 then begin
  1403.     ShowWinNoAnimate(Wnd, SW_SHOW);
  1404. {$IFDEF WIN32}
  1405.     SetForegroundWindow(Wnd);
  1406. {$ELSE}
  1407.     SwitchToThisWindow(Wnd, True);
  1408. {$ENDIF}
  1409.   end;
  1410. end;
  1411.  
  1412. {$IFDEF CBUILDER}
  1413. function FindPrevInstance(const MainFormClass: ShortString;
  1414.   const ATitle: string): HWnd;
  1415. {$ELSE}
  1416. function FindPrevInstance(const MainFormClass, ATitle: string): HWnd;
  1417. {$ENDIF CBUILDER}
  1418. var
  1419.   BufClass, BufTitle: PChar;
  1420. begin
  1421.   Result := 0;
  1422.   if (MainFormClass = '') and (ATitle = '') then Exit;
  1423.   BufClass := nil; BufTitle := nil;
  1424.   if (MainFormClass <> '') then BufClass := StrPAlloc(MainFormClass);
  1425.   if (ATitle <> '') then BufTitle := StrPAlloc(ATitle);
  1426.   try
  1427.     Result := FindWindow(BufClass, BufTitle);
  1428.   finally
  1429.     StrDispose(BufTitle);
  1430.     StrDispose(BufClass);
  1431.   end;
  1432. end;
  1433.  
  1434. {$IFDEF WIN32}
  1435. function WindowsEnum(Handle: HWnd; Param: Longint): Bool; export; stdcall;
  1436. begin
  1437.   if WindowClassName(Handle) = 'TAppBuilder' then begin
  1438.     Result := False;
  1439.     PLongint(Param)^ := 1;
  1440.   end
  1441.   else Result := True;
  1442. end;
  1443. {$ENDIF}
  1444.  
  1445. {$IFDEF CBUILDER}
  1446. function ActivatePrevInstance(const MainFormClass: ShortString;
  1447.   const ATitle: string): Boolean;
  1448. {$ELSE}
  1449. function ActivatePrevInstance(const MainFormClass, ATitle: string): Boolean;
  1450. {$ENDIF CBUILDER}
  1451. var
  1452.   PrevWnd, PopupWnd, ParentWnd: HWnd;
  1453. {$IFDEF WIN32}
  1454.   IsDelphi: Longint;
  1455. {$ELSE}
  1456.   S: array[0..255] of Char;
  1457. {$ENDIF}
  1458. begin
  1459.   Result := False;
  1460.   PrevWnd := FindPrevInstance(MainFormClass, ATitle);
  1461.   if PrevWnd <> 0 then begin
  1462.     ParentWnd := GetWindowParent(PrevWnd);
  1463.     while (ParentWnd <> GetDesktopWindow) and (ParentWnd <> 0) do begin
  1464.       PrevWnd := ParentWnd;
  1465.       ParentWnd := GetWindowParent(PrevWnd);
  1466.     end;
  1467.     if WindowClassName(PrevWnd) = 'TApplication' then begin
  1468. {$IFDEF WIN32}
  1469.       IsDelphi := 0;
  1470.       EnumThreadWindows(GetWindowTask(PrevWnd), @WindowsEnum,
  1471.         LPARAM(@IsDelphi));
  1472.       if Boolean(IsDelphi) then Exit;
  1473. {$ELSE}
  1474.       GetModuleFileName(GetWindowTask(PrevWnd), S, SizeOf(S) - 1);
  1475.       if AnsiUpperCase(ExtractFileName(StrPas(S))) = 'DELPHI.EXE' then Exit;
  1476. {$ENDIF}
  1477.       if IsIconic(PrevWnd) then begin { application is minimized }
  1478.         SendMessage(PrevWnd, WM_SYSCOMMAND, SC_RESTORE, 0);
  1479.         Result := True;
  1480.         Exit;
  1481.       end
  1482.       else ShowWinNoAnimate(PrevWnd, SW_SHOWNOACTIVATE);
  1483.     end
  1484.     else ActivateWindow(PrevWnd);
  1485.     PopupWnd := GetLastActivePopup(PrevWnd);
  1486.     if (PrevWnd <> PopupWnd) and IsWindowVisible(PopupWnd) and
  1487.       IsWindowEnabled(PopupWnd) then
  1488.     begin
  1489. {$IFDEF WIN32}
  1490.       SetForegroundWindow(PopupWnd);
  1491. {$ELSE}
  1492.       BringWindowToTop(PopupWnd);
  1493. {$ENDIF}
  1494.     end
  1495.     else ActivateWindow(PopupWnd);
  1496.     Result := True;
  1497.   end;
  1498. end;
  1499.  
  1500. { Standard Windows MessageBox function }
  1501.  
  1502. function MsgBox(const Caption, Text: string; Flags: Integer): Integer;
  1503. begin
  1504.   Result := Application.MessageBox(PChar(Text), PChar(Caption), Flags);
  1505. end;
  1506.  
  1507. function MsgDlg(const Msg: string; AType: TMsgDlgType; AButtons: TMsgDlgButtons; HelpCtx: Longint): Word;
  1508. begin
  1509.   Result := MessageDlg(Msg, AType, AButtons, HelpCtx);
  1510. end;
  1511.  
  1512. { Gradient fill procedure - displays a gradient beginning with a chosen    }
  1513. { color and ending with another chosen color. Based on TGradientFill       }
  1514. { component source code written by Curtis White, cwhite@teleport.com.      }
  1515. procedure GradientFillRect(Canvas: TCanvas; ARect: TRect; StartColor,
  1516.   EndColor: TColor; Direction: TFillDirection; Colors: Byte);
  1517. var
  1518.   StartRGB: array[0..2] of Byte;    { Start RGB values }
  1519.   RGBDelta: array[0..2] of Integer; { Difference between start and end RGB values }
  1520.   ColorBand: TRect;                 { Color band rectangular coordinates }
  1521.   I, Delta: Integer;
  1522.   Brush: HBrush;
  1523. begin
  1524.   if IsRectEmpty(ARect) then Exit;
  1525.   if Colors < 2 then begin
  1526.     Brush := CreateSolidBrush(ColorToRGB(StartColor));
  1527.     FillRect(Canvas.Handle, ARect, Brush);
  1528.     DeleteObject(Brush);
  1529.     Exit;
  1530.   end;
  1531.   StartColor := ColorToRGB(StartColor);
  1532.   EndColor := ColorToRGB(EndColor);
  1533.   case Direction of
  1534.     fdTopToBottom, fdLeftToRight: begin
  1535.       { Set the Red, Green and Blue colors }
  1536.       StartRGB[0] := GetRValue(StartColor);
  1537.       StartRGB[1] := GetGValue(StartColor);
  1538.       StartRGB[2] := GetBValue(StartColor);
  1539.       { Calculate the difference between begin and end RGB values }
  1540.       RGBDelta[0] := GetRValue(EndColor) - StartRGB[0];
  1541.       RGBDelta[1] := GetGValue(EndColor) - StartRGB[1];
  1542.       RGBDelta[2] := GetBValue(EndColor) - StartRGB[2];
  1543.     end;
  1544.     fdBottomToTop, fdRightToLeft: begin
  1545.       { Set the Red, Green and Blue colors }
  1546.       { Reverse of TopToBottom and LeftToRight directions }
  1547.       StartRGB[0] := GetRValue(EndColor);
  1548.       StartRGB[1] := GetGValue(EndColor);
  1549.       StartRGB[2] := GetBValue(EndColor);
  1550.       { Calculate the difference between begin and end RGB values }
  1551.       { Reverse of TopToBottom and LeftToRight directions }
  1552.       RGBDelta[0] := GetRValue(StartColor) - StartRGB[0];
  1553.       RGBDelta[1] := GetGValue(StartColor) - StartRGB[1];
  1554.       RGBDelta[2] := GetBValue(StartColor) - StartRGB[2];
  1555.     end;
  1556.   end; {case}
  1557.   { Calculate the color band's coordinates }
  1558.   ColorBand := ARect;
  1559.   if Direction in [fdTopToBottom, fdBottomToTop] then begin
  1560.     Colors := Max(2, Min(Colors, HeightOf(ARect)));
  1561.     Delta := HeightOf(ARect) div Colors;
  1562.   end
  1563.   else begin
  1564.     Colors := Max(2, Min(Colors, WidthOf(ARect)));
  1565.     Delta := WidthOf(ARect) div Colors;
  1566.   end;
  1567.   with Canvas.Pen do begin { Set the pen style and mode }
  1568.     Style := psSolid;
  1569.     Mode := pmCopy;
  1570.   end;
  1571.   { Perform the fill }
  1572.   if Delta > 0 then begin
  1573.     for I := 0 to Colors do begin
  1574.       case Direction of
  1575.         { Calculate the color band's top and bottom coordinates }
  1576.         fdTopToBottom, fdBottomToTop: begin
  1577.           ColorBand.Top := ARect.Top + I * Delta;
  1578.           ColorBand.Bottom := ColorBand.Top + Delta;
  1579.         end;
  1580.         { Calculate the color band's left and right coordinates }
  1581.         fdLeftToRight, fdRightToLeft: begin
  1582.           ColorBand.Left := ARect.Left + I * Delta;
  1583.           ColorBand.Right := ColorBand.Left + Delta;
  1584.         end;
  1585.       end; {case}
  1586.       { Calculate the color band's color }
  1587.       Brush := CreateSolidBrush(RGB(
  1588.         StartRGB[0] + MulDiv(I, RGBDelta[0], Colors - 1),
  1589.         StartRGB[1] + MulDiv(I, RGBDelta[1], Colors - 1),
  1590.         StartRGB[2] + MulDiv(I, RGBDelta[2], Colors - 1)));
  1591.       FillRect(Canvas.Handle, ColorBand, Brush);
  1592.       DeleteObject(Brush);
  1593.     end;
  1594.   end;
  1595.   if Direction in [fdTopToBottom, fdBottomToTop] then
  1596.     Delta := HeightOf(ARect) mod Colors
  1597.   else Delta := WidthOf(ARect) mod Colors;
  1598.   if Delta > 0 then begin
  1599.     case Direction of
  1600.       { Calculate the color band's top and bottom coordinates }
  1601.       fdTopToBottom, fdBottomToTop: begin
  1602.         ColorBand.Top := ARect.Bottom - Delta;
  1603.         ColorBand.Bottom := ColorBand.Top + Delta;
  1604.       end;
  1605.       { Calculate the color band's left and right coordinates }
  1606.       fdLeftToRight, fdRightToLeft: begin
  1607.         ColorBand.Left := ARect.Right - Delta;
  1608.         ColorBand.Right := ColorBand.Left + Delta;
  1609.       end;
  1610.     end; {case}
  1611.     case Direction of
  1612.       fdTopToBottom, fdLeftToRight:
  1613.         Brush := CreateSolidBrush(EndColor);
  1614.       else {fdBottomToTop, fdRightToLeft }
  1615.         Brush := CreateSolidBrush(StartColor);
  1616.     end;
  1617.     FillRect(Canvas.Handle, ColorBand, Brush);
  1618.     DeleteObject(Brush);
  1619.   end;
  1620. end;
  1621.  
  1622. function MinimizeText(const Text: string; Canvas: TCanvas;
  1623.   MaxWidth: Integer): string;
  1624. var
  1625.   I: Integer;
  1626. begin
  1627.   Result := Text;
  1628.   I := 1;
  1629.   while (I <= Length(Text)) and (Canvas.TextWidth(Result) > MaxWidth) do begin
  1630.     Inc(I);
  1631.     Result := Copy(Text, 1, Max(0, Length(Text) - I)) + '...';
  1632.   end;
  1633. end;
  1634.  
  1635. function GetAveCharSize(Canvas: TCanvas): TPoint;
  1636. var
  1637.   I: Integer;
  1638.   Buffer: array[0..51] of Char;
  1639. begin
  1640.   for I := 0 to 25 do Buffer[I] := Chr(I + Ord('A'));
  1641.   for I := 0 to 25 do Buffer[I + 26] := Chr(I + Ord('a'));
  1642.   GetTextExtentPoint(Canvas.Handle, Buffer, 52, TSize(Result));
  1643.   Result.X := Result.X div 52;
  1644. end;
  1645.  
  1646. { Memory routines }
  1647.  
  1648. function AllocMemo(Size: Longint): Pointer;
  1649. begin
  1650.   if Size > 0 then
  1651.     Result := GlobalAllocPtr(HeapAllocFlags or GMEM_ZEROINIT, Size)
  1652.   else Result := nil;
  1653. end;
  1654.  
  1655. function ReallocMemo(fpBlock: Pointer; Size: Longint): Pointer;
  1656. begin
  1657.   Result := GlobalReallocPtr(fpBlock, Size,
  1658.     HeapAllocFlags or GMEM_ZEROINIT);
  1659. end;
  1660.  
  1661. procedure FreeMemo(var fpBlock: Pointer);
  1662. begin
  1663.   if fpBlock <> nil then begin
  1664.     GlobalFreePtr(fpBlock);
  1665.     fpBlock := nil;
  1666.   end;
  1667. end;
  1668.  
  1669. function GetMemoSize(fpBlock: Pointer): Longint;
  1670. var
  1671.   hMem: THandle;
  1672. begin
  1673.   Result := 0;
  1674.   if fpBlock <> nil then begin
  1675. {$IFDEF WIN32}
  1676.     hMem := GlobalHandle(fpBlock);
  1677. {$ELSE}
  1678.     hMem := LoWord(GlobalHandle(SelectorOf(fpBlock)));
  1679. {$ENDIF}
  1680.     if hMem <> 0 then Result := GlobalSize(hMem);
  1681.   end;
  1682. end;
  1683.  
  1684. function CompareMem(fpBlock1, fpBlock2: Pointer; Size: Cardinal): Boolean; assembler;
  1685. asm
  1686. {$IFDEF WIN32}
  1687.         PUSH    ESI
  1688.         PUSH    EDI
  1689.         MOV     ESI,fpBlock1
  1690.         MOV     EDI,fpBlock2
  1691.         MOV     ECX,Size
  1692.         MOV     EDX,ECX
  1693.         XOR     EAX,EAX
  1694.         AND     EDX,3
  1695.         SHR     ECX,2
  1696.         REPE    CMPSD
  1697.         JNE     @@2
  1698.         MOV     ECX,EDX
  1699.         REPE    CMPSB
  1700.         JNE     @@2
  1701. @@1:    INC     EAX
  1702. @@2:    POP     EDI
  1703.         POP     ESI
  1704. {$ELSE}
  1705.         PUSH    DS
  1706.         LDS     SI,fpBlock1
  1707.         LES     DI,fpBlock2
  1708.         MOV     CX,Size
  1709.         XOR     AX,AX
  1710.         CLD
  1711.         REPE    CMPSB
  1712.         JNE     @@1
  1713.         INC     AX
  1714. @@1:    POP     DS
  1715. {$ENDIF}
  1716. end;
  1717.  
  1718. {$IFNDEF RX_D5}
  1719. procedure FreeAndNil(var Obj);
  1720. var
  1721.   P: TObject;
  1722. begin
  1723.   P := TObject(Obj);
  1724.   TObject(Obj) := nil;
  1725.   P.Free;
  1726. end;
  1727. {$ENDIF}
  1728.  
  1729. { Manipulate huge pointers routines by Ray Lischner, The Waite Group, Inc. }
  1730.  
  1731. {$IFDEF WIN32}
  1732.  
  1733. procedure HugeInc(var HugePtr: Pointer; Amount: Longint);
  1734. begin
  1735.   HugePtr := PChar(HugePtr) + Amount;
  1736. end;
  1737.  
  1738. procedure HugeDec(var HugePtr: Pointer; Amount: Longint);
  1739. begin
  1740.   HugePtr := PChar(HugePtr) - Amount;
  1741. end;
  1742.  
  1743. function HugeOffset(HugePtr: Pointer; Amount: Longint): Pointer;
  1744. begin
  1745.   Result := PChar(HugePtr) + Amount;
  1746. end;
  1747.  
  1748. procedure HMemCpy(DstPtr, SrcPtr: Pointer; Amount: Longint);
  1749. begin
  1750.   Move(SrcPtr^, DstPtr^, Amount);
  1751. end;
  1752.  
  1753. procedure HugeMove(Base: Pointer; Dst, Src, Size: Longint);
  1754. var
  1755.   SrcPtr, DstPtr: PChar;
  1756. begin
  1757.   SrcPtr := PChar(Base) + Src * SizeOf(Pointer);
  1758.   DstPtr := PChar(Base) + Dst * SizeOf(Pointer);
  1759.   Move(SrcPtr^, DstPtr^, Size * SizeOf(Pointer));
  1760. end;
  1761.  
  1762. {$ELSE}
  1763.  
  1764. procedure __AHSHIFT; far; external 'KERNEL' index 113;
  1765.  
  1766. { Increment a huge pointer }
  1767. procedure HugeInc(var HugePtr: Pointer; Amount: Longint); assembler;
  1768. asm
  1769.         MOV     AX,Amount.Word[0]
  1770.         MOV     DX,Amount.Word[2]
  1771.         LES     BX,HugePtr
  1772.         ADD     AX,ES:[BX]
  1773.         ADC     DX,0
  1774.         MOV     CX,Offset __AHSHIFT
  1775.         SHL     DX,CL
  1776.         ADD     ES:[BX+2],DX
  1777.         MOV     ES:[BX],AX
  1778. end;
  1779.  
  1780. { Decrement a huge pointer }
  1781. procedure HugeDec(var HugePtr: Pointer; Amount: Longint); assembler;
  1782. asm
  1783.         LES     BX,HugePtr
  1784.         MOV     AX,ES:[BX]
  1785.         SUB     AX,Amount.Word[0]
  1786.         MOV     DX,Amount.Word[2]
  1787.         ADC     DX,0
  1788.         MOV     CX,OFFSET __AHSHIFT
  1789.         SHL     DX,CL
  1790.         SUB     ES:[BX+2],DX
  1791.         MOV     ES:[BX],AX
  1792. end;
  1793.  
  1794. { ADD an offset to a huge pointer and return the result }
  1795. function HugeOffset(HugePtr: Pointer; Amount: Longint): Pointer; assembler;
  1796. asm
  1797.         MOV     AX,Amount.Word[0]
  1798.         MOV     DX,Amount.Word[2]
  1799.         ADD     AX,HugePtr.Word[0]
  1800.         ADC     DX,0
  1801.         MOV     CX,OFFSET __AHSHIFT
  1802.         SHL     DX,CL
  1803.         ADD     DX,HugePtr.Word[2]
  1804. end;
  1805.  
  1806. { When setting the Count, one might add many new items, which
  1807.   must be set to zero at one time, to initialize all items to nil.
  1808.   You could use FillChar, which fills by bytes, but, as DoMove
  1809.   is to Move, ZeroBytes is to FillChar, except that it always
  1810.   fill with zero valued words }
  1811. procedure FillWords(DstPtr: Pointer; Size: Word; Fill: Word); assembler;
  1812. asm
  1813.         MOV     AX,Fill
  1814.         LES     DI,DstPtr
  1815.         MOV     CX,Size.Word[0]
  1816.         CLD
  1817.         REP     STOSW
  1818. end;
  1819.  
  1820. { Fill Length bytes of memory with Fill, starting at Ptr.
  1821.   This is just like the procedure in the Win32 API. The memory
  1822.   can be larger than 64K and can cross segment boundaries }
  1823. procedure FillMemory(Ptr: Pointer; Length: Longint; Fill: Byte);
  1824. var
  1825.   NBytes: Cardinal;
  1826.   NWords: Cardinal;
  1827.   FillWord: Word;
  1828. begin
  1829.   WordRec(FillWord).Hi := Fill;
  1830.   WordRec(FillWord).Lo := Fill;
  1831.   while Length > 1 do begin
  1832.     { Determine the number of bytes remaining in the segment }
  1833.     if Ofs(Ptr^) = 0 then NBytes := $FFFE
  1834.     else NBytes := $10000 - Ofs(Ptr^);
  1835.     if NBytes > Length then NBytes := Length;
  1836.     { Filling by words is faster than filling by bytes }
  1837.     NWords := NBytes div 2;
  1838.     FillWords(Ptr, NWords, FillWord);
  1839.     NBytes := NWords * 2;
  1840.     Dec(Length, NBytes);
  1841.     Ptr := HugeOffset(Ptr, NBytes);
  1842.   end;
  1843.   { If the fill size is odd, then fill the remaining byte }
  1844.   if Length > 0 then PByte(Ptr)^ := Fill;
  1845. end;
  1846.  
  1847. procedure ZeroMemory(Ptr: Pointer; Length: Longint);
  1848. begin
  1849.   FillMemory(Ptr, Length, 0);
  1850. end;
  1851.  
  1852. procedure cld; inline ($FC);
  1853. procedure std; inline ($FD);
  1854.  
  1855. function ComputeDownMoveSize(SrcOffset, DstOffset: Word): Word;
  1856. begin
  1857.   if SrcOffset > DstOffset then Result := Word($10000 - SrcOffset) div 2
  1858.   else Result := Word($10000 - DstOffset) div 2;
  1859.   if Result = 0 then Result := $7FFF;
  1860. end;
  1861.  
  1862. function ComputeUpMoveSize(SrcOffset, DstOffset: Word): Word;
  1863. begin
  1864.   if SrcOffset = $FFFF then Result := DstOffset div 2
  1865.   else if DstOffset = $FFFF then Result := SrcOffset div 2
  1866.   else if SrcOffset > DstOffset then Result := DstOffset div 2 + 1
  1867.   else Result := SrcOffset div 2 + 1;
  1868. end;
  1869.  
  1870. procedure MoveWords(SrcPtr, DstPtr: Pointer; Size: Word); assembler;
  1871. asm
  1872.         PUSH    DS
  1873.         LDS     SI,SrcPtr
  1874.         LES     DI,DstPtr
  1875.         MOV     CX,Size.Word[0]
  1876.         REP     MOVSW
  1877.         POP     DS
  1878. end;
  1879.  
  1880. procedure HugeMove(Base: Pointer; Dst, Src, Size: Longint);
  1881. var
  1882.   SrcPtr, DstPtr: Pointer;
  1883.   MoveSize: Word;
  1884. begin
  1885.   SrcPtr := HugeOffset(Base, Src * SizeOf(Pointer));
  1886.   DstPtr := HugeOffset(Base, Dst * SizeOf(Pointer));
  1887.   { Convert longword size to words }
  1888.   Size := Size * (SizeOf(Longint) div SizeOf(Word));
  1889.   if Src < Dst then begin
  1890.     { Start from the far end and work toward the front }
  1891.     std;
  1892.     HugeInc(SrcPtr, (Size - 1) * SizeOf(Word));
  1893.     HugeInc(DstPtr, (Size - 1) * SizeOf(Word));
  1894.     while Size > 0 do begin
  1895.       { Compute how many bytes to move in the current segment }
  1896.       MoveSize := ComputeUpMoveSize(Word(SrcPtr), Word(DstPtr));
  1897.       if MoveSize > Size then MoveSize := Word(Size);
  1898.       { Move the bytes }
  1899.       MoveWords(SrcPtr, DstPtr, MoveSize);
  1900.       { Update the number of bytes left to move }
  1901.       Dec(Size, MoveSize);
  1902.       { Update the pointers }
  1903.       HugeDec(SrcPtr, MoveSize * SizeOf(Word));
  1904.       HugeDec(DstPtr, MoveSize * SizeOf(Word));
  1905.     end;
  1906.     cld; { reset the direction flag }
  1907.   end
  1908.   else begin
  1909.     { Start from the beginning and work toward the end }
  1910.     cld;
  1911.     while Size > 0 do begin
  1912.       { Compute how many bytes to move in the current segment }
  1913.       MoveSize := ComputeDownMoveSize(Word(SrcPtr), Word(DstPtr));
  1914.       if MoveSize > Size then MoveSize := Word(Size);
  1915.       { Move the bytes }
  1916.       MoveWords(SrcPtr, DstPtr, MoveSize);
  1917.       { Update the number of bytes left to move }
  1918.       Dec(Size, MoveSize);
  1919.       { Advance the pointers }
  1920.       HugeInc(SrcPtr, MoveSize * SizeOf(Word));
  1921.       HugeInc(DstPtr, MoveSize * SizeOf(Word));
  1922.     end;
  1923.   end;
  1924. end;
  1925.  
  1926. {$ENDIF}
  1927.  
  1928. { String routines }
  1929.  
  1930. {$W+}
  1931. function GetEnvVar(const VarName: string): string;
  1932. var
  1933. {$IFDEF WIN32}
  1934.   S: array[0..2048] of Char;
  1935. {$ELSE}
  1936.   S: array[0..255] of Char;
  1937.   L: Cardinal;
  1938.   P: PChar;
  1939. {$ENDIF}
  1940. begin
  1941. {$IFDEF WIN32}
  1942.   if GetEnvironmentVariable(PChar(VarName), S, SizeOf(S) - 1) > 0 then
  1943.     Result := StrPas(S)
  1944.   else Result := '';
  1945. {$ELSE}
  1946.   L := Length(VarName);
  1947.   P := GetDosEnvironment;
  1948.   StrPLCopy(S, VarName, 255);
  1949.   while P^ <> #0 do begin
  1950.     if (StrLIComp(P, {$IFDEF WIN32} PChar(VarName) {$ELSE} S {$ENDIF}, L) = 0) and
  1951.       (P[L] = '=') then
  1952.     begin
  1953.       Result := StrPas(P + L + 1);
  1954.       Exit;
  1955.     end;
  1956.     Inc(P, StrLen(P) + 1);
  1957.   end;
  1958.   Result := '';
  1959. {$ENDIF}
  1960. end;
  1961. {$W-}
  1962.  
  1963. { function GetParamStr copied from SYSTEM.PAS unit of Delphi 2.0 }
  1964. function GetParamStr(P: PChar; var Param: string): PChar;
  1965. var
  1966.   Len: Integer;
  1967.   Buffer: array[Byte] of Char;
  1968. begin
  1969.   while True do
  1970.   begin
  1971.     while (P[0] <> #0) and (P[0] <= ' ') do Inc(P);
  1972.     if (P[0] = '"') and (P[1] = '"') then Inc(P, 2) else Break;
  1973.   end;
  1974.   Len := 0;
  1975.   while P[0] > ' ' do
  1976.     if P[0] = '"' then
  1977.     begin
  1978.       Inc(P);
  1979.       while (P[0] <> #0) and (P[0] <> '"') do
  1980.       begin
  1981.         Buffer[Len] := P[0];
  1982.         Inc(Len);
  1983.         Inc(P);
  1984.       end;
  1985.       if P[0] <> #0 then Inc(P);
  1986.     end else
  1987.     begin
  1988.       Buffer[Len] := P[0];
  1989.       Inc(Len);
  1990.       Inc(P);
  1991.     end;
  1992.   SetString(Param, Buffer, Len);
  1993.   Result := P;
  1994. end;
  1995.  
  1996. function ParamCountFromCommandLine(CmdLine: PChar): Integer;
  1997. var
  1998.   S: string;
  1999.   P: PChar;
  2000. begin
  2001.   P := CmdLine;
  2002.   Result := 0;
  2003.   while True do
  2004.   begin
  2005.     P := GetParamStr(P, S);
  2006.     if S = '' then Break;
  2007.     Inc(Result);
  2008.   end;
  2009. end;
  2010.  
  2011. function ParamStrFromCommandLine(CmdLine: PChar; Index: Integer): string;
  2012. var
  2013.   P: PChar;
  2014. begin
  2015.   P := CmdLine;
  2016.   while True do
  2017.   begin
  2018.     P := GetParamStr(P, Result);
  2019.     if (Index = 0) or (Result = '') then Break;
  2020.     Dec(Index);
  2021.   end;
  2022. end;
  2023.  
  2024. procedure SplitCommandLine(const CmdLine: string; var ExeName,
  2025.   Params: string);
  2026. var
  2027.   Buffer: PChar;
  2028.   Cnt, I: Integer;
  2029.   S: string;
  2030. begin
  2031.   ExeName := '';
  2032.   Params := '';
  2033.   Buffer := StrPAlloc(CmdLine);
  2034.   try
  2035.     Cnt := ParamCountFromCommandLine(Buffer);
  2036.     if Cnt > 0 then begin
  2037.       ExeName := ParamStrFromCommandLine(Buffer, 0);
  2038.       for I := 1 to Cnt - 1 do begin
  2039.         S := ParamStrFromCommandLine(Buffer, I);
  2040.         if Pos(' ', S) > 0 then S := '"' + S + '"';
  2041.         Params := Params + S;
  2042.         if I < Cnt - 1 then Params := Params + ' ';
  2043.       end;
  2044.     end;
  2045.   finally
  2046.     StrDispose(Buffer);
  2047.   end;
  2048. end;
  2049.  
  2050. function AnsiUpperFirstChar(const S: string): string;
  2051. var
  2052.   Temp: string[1];
  2053. begin
  2054.   Result := AnsiLowerCase(S);
  2055.   if S <> '' then begin
  2056.     Temp := Result[1];
  2057.     Temp := AnsiUpperCase(Temp);
  2058.     Result[1] := Temp[1];
  2059.   end;
  2060. end;
  2061.  
  2062. function StrPAlloc(const S: string): PChar;
  2063. begin
  2064.   Result := StrPCopy(StrAlloc(Length(S) + 1), S);
  2065. end;
  2066.  
  2067. function StringToPChar(var S: string): PChar;
  2068. begin
  2069. {$IFDEF WIN32}
  2070.   Result := PChar(S);
  2071. {$ELSE}
  2072.   if Length(S) = High(S) then Dec(S[0]);
  2073.   S[Length(S) + 1] := #0;
  2074.   Result := @(S[1]);
  2075. {$ENDIF}
  2076. end;
  2077.  
  2078. function DropT(const S: string): string;
  2079. begin
  2080.   if (UpCase(S[1]) = 'T') and (Length(S) > 1) then
  2081.     Result := Copy(S, 2, MaxInt)
  2082.   else Result := S;
  2083. end;
  2084.  
  2085. { Cursor routines }
  2086.  
  2087. {$IFDEF WIN32}
  2088. {$IFNDEF RX_D3}
  2089. const
  2090.   RT_ANICURSOR = MakeIntResource(21);
  2091. {$ENDIF}
  2092. function LoadAniCursor(Instance: THandle; ResID: PChar): HCursor;
  2093. { Unfortunately I don't know how we can load animated cursor from
  2094.   executable resource directly. So I write this routine using temporary
  2095.   file and LoadCursorFromFile function. }
  2096. var
  2097.   S: TFileStream;
  2098.   Path, FileName: array[0..MAX_PATH] of Char;
  2099.   Rsrc: HRSRC;
  2100.   Res: THandle;
  2101.   Data: Pointer;
  2102. begin
  2103.   Result := 0;
  2104.   Rsrc := FindResource(Instance, ResID, RT_ANICURSOR);
  2105.   if Rsrc <> 0 then begin
  2106.     Win32Check(GetTempPath(MAX_PATH, Path) <> 0);
  2107.     Win32Check(GetTempFileName(Path, 'ANI', 0, FileName) <> 0);
  2108.     try
  2109.       Res := LoadResource(Instance, Rsrc);
  2110.       try
  2111.         Data := LockResource(Res);
  2112.         if Data <> nil then
  2113.         try
  2114.           S := TFileStream.Create(StrPas(FileName), fmCreate);
  2115.           try
  2116.             S.WriteBuffer(Data^, SizeOfResource(Instance, Rsrc));
  2117.           finally
  2118.             S.Free;
  2119.           end;
  2120.           Result := LoadCursorFromFile(FileName);
  2121.         finally
  2122.           UnlockResource(Res);
  2123.         end;
  2124.       finally
  2125.         FreeResource(Res);
  2126.       end;
  2127.     finally
  2128.       Windows.DeleteFile(FileName);
  2129.     end;
  2130.   end;
  2131. end;
  2132. {$ENDIF}
  2133.  
  2134. function DefineCursor(Instance: THandle; ResID: PChar): TCursor;
  2135. var
  2136.   Handle: HCursor;
  2137. begin
  2138.   Handle := LoadCursor(Instance, ResID);
  2139. {$IFDEF WIN32}
  2140.   if Handle = 0 then
  2141.     Handle := LoadAniCursor(Instance, ResID);
  2142. {$ENDIF}
  2143.   if Handle = 0 then ResourceNotFound(ResID);
  2144.   for Result := 100 to High(TCursor) do { Look for an unassigned cursor index }
  2145.     if (Screen.Cursors[Result] = Screen.Cursors[crDefault]) then begin
  2146.       Screen.Cursors[Result] := Handle;
  2147.       Exit;
  2148.     end;
  2149.   DestroyCursor(Handle);
  2150.   raise EOutOfResources.Create(ResStr(SOutOfResources));
  2151. end;
  2152.  
  2153. const
  2154.   WaitCount: Integer = 0;
  2155.   SaveCursor: TCursor = crDefault;
  2156.  
  2157. procedure StartWait;
  2158. begin
  2159.   if WaitCount = 0 then begin
  2160.     SaveCursor := Screen.Cursor;
  2161.     Screen.Cursor := WaitCursor;
  2162.   end;
  2163.   Inc(WaitCount);
  2164. end;
  2165.  
  2166. procedure StopWait;
  2167. begin
  2168.   if WaitCount > 0 then begin
  2169.     Dec(WaitCount);
  2170.     if WaitCount = 0 then Screen.Cursor := SaveCursor;
  2171.   end;
  2172. end;
  2173.  
  2174. { Grid drawing }
  2175.  
  2176. const
  2177.   DrawBitmap: TBitmap = nil;
  2178.  
  2179. procedure UsesBitmap;
  2180. begin
  2181.   if DrawBitmap = nil then DrawBitmap := TBitmap.Create;
  2182. end;
  2183.  
  2184. procedure ReleaseBitmap; far;
  2185. begin
  2186.   if DrawBitmap <> nil then DrawBitmap.Free;
  2187.   DrawBitmap := nil;
  2188. end;
  2189.  
  2190. procedure WriteText(ACanvas: TCanvas; ARect: TRect; DX, DY: Integer;
  2191.   const Text: string; Alignment: TAlignment; WordWrap: Boolean
  2192.   {$IFDEF RX_D4}; ARightToLeft: Boolean = False {$ENDIF});
  2193. const
  2194.   AlignFlags: array [TAlignment] of Integer =
  2195.     (DT_LEFT or DT_EXPANDTABS or DT_NOPREFIX,
  2196.      DT_RIGHT or DT_EXPANDTABS or DT_NOPREFIX,
  2197.      DT_CENTER or DT_EXPANDTABS or DT_NOPREFIX);
  2198.   WrapFlags: array[Boolean] of Integer = (0, DT_WORDBREAK);
  2199. {$IFDEF RX_D4}
  2200.   RTL: array [Boolean] of Integer = (0, DT_RTLREADING);
  2201. {$ENDIF}
  2202. var
  2203. {$IFNDEF WIN32}
  2204.   S: array[0..255] of Char;
  2205. {$ENDIF}
  2206.   B, R: TRect;
  2207.   I, Left: Integer;
  2208. begin
  2209.   UsesBitmap;
  2210.   I := ColorToRGB(ACanvas.Brush.Color);
  2211.   if not WordWrap and (Integer(GetNearestColor(ACanvas.Handle, I)) = I) and
  2212.     (Pos(#13, Text) = 0) then
  2213.   begin { Use ExtTextOut for solid colors }
  2214. {$IFDEF RX_D4}
  2215.     { In BiDi, because we changed the window origin, the text that does not
  2216.       change alignment, actually gets its alignment changed. }
  2217.     if (ACanvas.CanvasOrientation = coRightToLeft) and (not ARightToLeft) then
  2218.       ChangeBiDiModeAlignment(Alignment);
  2219. {$ENDIF}
  2220.     case Alignment of
  2221.       taLeftJustify: Left := ARect.Left + DX;
  2222.       taRightJustify: Left := ARect.Right - ACanvas.TextWidth(Text) - 3;
  2223.       else { taCenter }
  2224.         Left := ARect.Left + (ARect.Right - ARect.Left) shr 1
  2225.           - (ACanvas.TextWidth(Text) shr 1);
  2226.     end;
  2227. {$IFDEF RX_D4}
  2228.     ACanvas.TextRect(ARect, Left, ARect.Top + DY, Text);
  2229. {$ELSE}
  2230.   {$IFDEF WIN32}
  2231.     ExtTextOut(ACanvas.Handle, Left, ARect.Top + DY, ETO_OPAQUE or
  2232.       ETO_CLIPPED, @ARect, PChar(Text), Length(Text), nil);
  2233.   {$ELSE}
  2234.     ExtTextOut(ACanvas.Handle, Left, ARect.Top + DY, ETO_OPAQUE or
  2235.       ETO_CLIPPED, @ARect, StrPCopy(S, Text), Length(Text), nil);
  2236.   {$ENDIF}
  2237. {$ENDIF}
  2238.   end
  2239.   else begin { Use FillRect and DrawText for dithered colors }
  2240. {$IFDEF RX_D3}
  2241.     DrawBitmap.Canvas.Lock;
  2242.     try
  2243. {$ENDIF}
  2244.       with DrawBitmap, ARect do { Use offscreen bitmap to eliminate flicker and }
  2245.       begin                     { brush origin tics in painting / scrolling.    }
  2246.         Width := Max(Width, Right - Left);
  2247.         Height := Max(Height, Bottom - Top);
  2248.         R := Rect(DX, DY, Right - Left - {$IFDEF WIN32} 1 {$ELSE} 2 {$ENDIF},
  2249.           Bottom - Top - 1);
  2250.         B := Rect(0, 0, Right - Left, Bottom - Top);
  2251.       end;
  2252.       with DrawBitmap.Canvas do begin
  2253.         Font := ACanvas.Font;
  2254.         Font.Color := ACanvas.Font.Color;
  2255.         Brush := ACanvas.Brush;
  2256.         Brush.Style := bsSolid;
  2257.         FillRect(B);
  2258.         SetBkMode(Handle, TRANSPARENT);
  2259. {$IFDEF RX_D4}
  2260.         if (ACanvas.CanvasOrientation = coRightToLeft) then
  2261.           ChangeBiDiModeAlignment(Alignment);
  2262.         DrawText(Handle, PChar(Text), Length(Text), R, AlignFlags[Alignment]
  2263.           or RTL[ARightToLeft] or WrapFlags[WordWrap]);
  2264. {$ELSE}
  2265.   {$IFDEF WIN32}
  2266.         DrawText(Handle, PChar(Text), Length(Text), R,
  2267.           AlignFlags[Alignment] or WrapFlags[WordWrap]);
  2268.   {$ELSE}
  2269.         DrawText(Handle, StrPCopy(S, Text), Length(Text), R,
  2270.           AlignFlags[Alignment] or WrapFlags[WordWrap]);
  2271.   {$ENDIF}
  2272. {$ENDIF}
  2273.       end;
  2274.       ACanvas.CopyRect(ARect, DrawBitmap.Canvas, B);
  2275. {$IFDEF RX_D3}
  2276.     finally
  2277.       DrawBitmap.Canvas.Unlock;
  2278.     end;
  2279. {$ENDIF}
  2280.   end;
  2281. end;
  2282.  
  2283. {$IFDEF RX_D4}
  2284.  
  2285. procedure DrawCellTextEx(Control: TCustomControl; ACol, ARow: Longint;
  2286.   const S: string; const ARect: TRect; Align: TAlignment;
  2287.   VertAlign: TVertAlignment; WordWrap: Boolean; ARightToLeft: Boolean);
  2288. const
  2289.   MinOffs = 2;
  2290. var
  2291.   H: Integer;
  2292. begin
  2293.   case VertAlign of
  2294.     vaTopJustify: H := MinOffs;
  2295.     vaCenter:
  2296.       with THack(Control) do
  2297.         H := Max(1, (ARect.Bottom - ARect.Top -
  2298.           Canvas.TextHeight('W')) div 2);
  2299.     else {vaBottomJustify} begin
  2300.       with THack(Control) do
  2301.         H := Max(MinOffs, ARect.Bottom - ARect.Top -
  2302.           Canvas.TextHeight('W'));
  2303.     end;
  2304.   end;
  2305.   WriteText(THack(Control).Canvas, ARect, MinOffs, H, S, Align, WordWrap,
  2306.     ARightToLeft);
  2307. end;
  2308.  
  2309. procedure DrawCellText(Control: TCustomControl; ACol, ARow: Longint;
  2310.   const S: string; const ARect: TRect; Align: TAlignment;
  2311.   VertAlign: TVertAlignment; ARightToLeft: Boolean);
  2312. begin
  2313.   DrawCellTextEx(Control, ACol, ARow, S, ARect, Align, VertAlign,
  2314.     Align = taCenter, ARightToLeft);
  2315. end;
  2316.  
  2317. {$ENDIF}
  2318.  
  2319. procedure DrawCellTextEx(Control: TCustomControl; ACol, ARow: Longint;
  2320.   const S: string; const ARect: TRect; Align: TAlignment;
  2321.   VertAlign: TVertAlignment; WordWrap: Boolean);
  2322. const
  2323.   MinOffs = 2;
  2324. var
  2325.   H: Integer;
  2326. begin
  2327.   case VertAlign of
  2328.     vaTopJustify: H := MinOffs;
  2329.     vaCenter:
  2330.       with THack(Control) do
  2331.         H := Max(1, (ARect.Bottom - ARect.Top -
  2332.           Canvas.TextHeight('W')) div 2);
  2333.     else {vaBottomJustify} begin
  2334.       with THack(Control) do
  2335.         H := Max(MinOffs, ARect.Bottom - ARect.Top -
  2336.           Canvas.TextHeight('W'));
  2337.     end;
  2338.   end;
  2339.   WriteText(THack(Control).Canvas, ARect, MinOffs, H, S, Align, WordWrap);
  2340. end;
  2341.  
  2342. procedure DrawCellText(Control: TCustomControl; ACol, ARow: Longint;
  2343.   const S: string; const ARect: TRect; Align: TAlignment;
  2344.   VertAlign: TVertAlignment);
  2345. begin
  2346.   DrawCellTextEx(Control, ACol, ARow, S, ARect, Align, VertAlign,
  2347.     Align = taCenter);
  2348. end;
  2349.  
  2350. procedure DrawCellBitmap(Control: TCustomControl; ACol, ARow: Longint;
  2351.   Bmp: TGraphic; Rect: TRect);
  2352. begin
  2353.   Rect.Top := (Rect.Bottom + Rect.Top - Bmp.Height) div 2;
  2354.   Rect.Left := (Rect.Right + Rect.Left - Bmp.Width) div 2;
  2355.   THack(Control).Canvas.Draw(Rect.Left, Rect.Top, Bmp);
  2356. end;
  2357.  
  2358. { TScreenCanvas }
  2359.  
  2360. destructor TScreenCanvas.Destroy;
  2361. begin
  2362.   FreeHandle;
  2363.   inherited Destroy;
  2364. end;
  2365.  
  2366. procedure TScreenCanvas.CreateHandle;
  2367. begin
  2368.   if FDeviceContext = 0 then FDeviceContext := GetDC(0);
  2369.   Handle := FDeviceContext;
  2370. end;
  2371.  
  2372. procedure TScreenCanvas.FreeHandle;
  2373. begin
  2374.   if FDeviceContext <> 0 then begin
  2375.     Handle := 0;
  2376.     ReleaseDC(0, FDeviceContext);
  2377.     FDeviceContext := 0;
  2378.   end;
  2379. end;
  2380.  
  2381. procedure TScreenCanvas.SetOrigin(X, Y: Integer);
  2382. var
  2383.   FOrigin: TPoint;
  2384. begin
  2385.   SetWindowOrgEx(Handle, -X, -Y, @FOrigin);
  2386. end;
  2387.  
  2388. {$IFNDEF WIN32}
  2389.  
  2390. { TBits }
  2391.  
  2392. const
  2393.   BitsPerInt = SizeOf(Integer) * 8;
  2394.  
  2395. type
  2396.   TBitEnum = 0..BitsPerInt - 1;
  2397.   TBitSet = set of TBitEnum;
  2398.   PBitArray = ^TBitArray;
  2399.   TBitArray = array[0..4096] of TBitSet;
  2400.  
  2401. destructor TBits.Destroy;
  2402. begin
  2403.   SetSize(0);
  2404.   inherited Destroy;
  2405. end;
  2406.  
  2407. procedure TBits.SetSize(Value: Integer);
  2408. var
  2409.   NewMem: Pointer;
  2410.   NewMemSize: Integer;
  2411.   OldMemSize: Integer;
  2412. begin
  2413.   if Value <> Size then begin
  2414.     NewMemSize := ((Value + BitsPerInt - 1) div BitsPerInt) * SizeOf(Integer);
  2415.     OldMemSize := ((Size + BitsPerInt - 1) div BitsPerInt) * SizeOf(Integer);
  2416.     if NewMemSize <> OldMemSize then begin
  2417.       NewMem := nil;
  2418.       if NewMemSize <> 0 then begin
  2419.         GetMem(NewMem, NewMemSize);
  2420.         FillChar(NewMem^, NewMemSize, 0);
  2421.       end
  2422.       else NewMem := nil;
  2423.       if OldMemSize <> 0 then begin
  2424.         if NewMem <> nil then
  2425.           Move(FBits^, NewMem^, Min(OldMemSize, NewMemSize));
  2426.         FreeMem(FBits, OldMemSize);
  2427.       end;
  2428.       FBits := NewMem;
  2429.     end;
  2430.     FSize := Value;
  2431.   end;
  2432. end;
  2433.  
  2434. procedure TBits.SetBit(Index: Integer; Value: Boolean);
  2435. begin
  2436.   if Value then
  2437.     Include(PBitArray(FBits)^[Index div BitsPerInt], Index mod BitsPerInt)
  2438.   else
  2439.     Exclude(PBitArray(FBits)^[Index div BitsPerInt], Index mod BitsPerInt);
  2440. end;
  2441.  
  2442. function TBits.GetBit(Index: Integer): Boolean;
  2443. begin
  2444.   Result := Index mod BitsPerInt in PBitArray(FBits)^[Index div BitsPerInt];
  2445. end;
  2446.  
  2447. function TBits.OpenBit: Integer;
  2448. var
  2449.   I: Integer;
  2450.   B: TBitSet;
  2451.   J: TBitEnum;
  2452.   E: Integer;
  2453. begin
  2454.   E := (Size + BitsPerInt - 1) div BitsPerInt - 1;
  2455.   for I := 0 to E do
  2456.     if PBitArray(FBits)^[I] <> [0..BitsPerInt - 1] then begin
  2457.       B := PBitArray(FBits)^[I];
  2458.       for J := Low(J) to High(J) do begin
  2459.         if not (J in B) then begin
  2460.           Result := I * BitsPerInt + J;
  2461.           if Result >= Size then Result := Size;
  2462.           Exit;
  2463.         end;
  2464.       end;
  2465.     end;
  2466.   Result := Size;
  2467. end;
  2468.  
  2469. (*
  2470.   To create a metafile image from scratch, you must draw the image in
  2471.   a metafile canvas.  When the canvas is destroyed, it transfers the
  2472.   image into the metafile object provided to the canvas constructor.
  2473.   After the image is drawn on the canvas and the canvas is destroyed,
  2474.   the image is 'playable' in the metafile object.  Like this:
  2475.  
  2476.   MyMetafile := TMetafile.Create;
  2477.   with TMetafileCanvas.Create(MyMetafile, 0) do
  2478.   try
  2479.     Brush.Color := clRed;
  2480.     Ellipse(0,0,100,100);
  2481.     ...
  2482.   finally
  2483.     Free;
  2484.   end;
  2485.   Form1.Canvas.Draw(0,0,MyMetafile);  { 1 red circle  }
  2486.  
  2487.   To add to an existing metafile image, create a metafile canvas
  2488.   and play the source metafile into the metafile canvas.  Like this:
  2489.  
  2490.   { continued from previous example, so MyMetafile contains an image }
  2491.   with TMetafileCanvas.Create(MyMetafile, 0) do
  2492.   try
  2493.     Draw(0,0,MyMetafile);
  2494.     Brush.Color := clBlue;
  2495.     Ellipse(100,100,200,200);
  2496.     ...
  2497.   finally
  2498.     Free;
  2499.   end;
  2500.   Form1.Canvas.Draw(0,0,MyMetafile);  { 1 red circle and 1 blue circle }
  2501. *)
  2502.  
  2503. constructor TMetafileCanvas.Create(AMetafile: TMetafile; ReferenceDevice: HDC);
  2504. var
  2505.   Temp: HDC;
  2506. begin
  2507.   inherited Create;
  2508.   FMetafile := AMetafile;
  2509.   Temp := CreateMetafile(nil);
  2510.   if Temp = 0 then
  2511.     raise EOutOfResources.Create(ResStr(SOutOfResources));
  2512.   Handle := Temp;
  2513.   FMetafile.Inch := Screen.PixelsPerInch;
  2514. end;
  2515.  
  2516. destructor TMetafileCanvas.Destroy;
  2517. var
  2518.   Temp: HDC;
  2519.   KeepInch, KeepWidth, KeepHeight: Integer;
  2520. begin
  2521.   Temp := Handle;
  2522.   Handle := 0;
  2523.   with FMetafile do begin
  2524.     KeepWidth := Width;
  2525.     KeepHeight := Height;
  2526.     KeepInch := Inch;
  2527.     Handle := CloseMetafile(Temp);
  2528.     Width := KeepWidth;
  2529.     Height := KeepHeight;
  2530.     Inch := KeepInch;
  2531.   end;
  2532.   inherited Destroy;
  2533. end;
  2534.  
  2535. { TResourceStream }
  2536.  
  2537. constructor TResourceStream.Create(Instance: THandle; const ResName: string;
  2538.   ResType: PChar);
  2539. var
  2540.   ResID: array[0..255] of Char;
  2541. begin
  2542.   CreateFromPChar(Instance, StrPCopy(ResID, ResName), ResType);
  2543. end;
  2544.  
  2545. constructor TResourceStream.CreateFromID(Instance: THandle; ResID: Integer;
  2546.   ResType: PChar);
  2547. begin
  2548.   CreateFromPChar(Instance, MakeIntResource(ResID), ResType);
  2549. end;
  2550.  
  2551. constructor TResourceStream.CreateFromPChar(Instance: THandle; ResName,
  2552.   ResType: PChar);
  2553. var
  2554.   ResInfo: THandle;
  2555.   Handle: Integer;
  2556. begin
  2557.   ResInfo := FindResource(Instance, ResName, ResType);
  2558.   if ResInfo = 0 then ResourceNotFound(ResName);
  2559.   Handle := AccessResource(Instance, ResInfo);
  2560.   if Handle < 0 then ResourceNotFound(ResName);
  2561.   inherited Create(Handle);
  2562.   FStartPos := inherited Seek(0, soFromCurrent);
  2563.   FEndPos := FStartPos + SizeOfResource(Instance, ResInfo);
  2564. end;
  2565.  
  2566. destructor TResourceStream.Destroy;
  2567. begin
  2568.   if Handle >= 0 then FileClose(Handle);
  2569.   inherited Destroy;
  2570. end;
  2571.  
  2572. function TResourceStream.Write(const Buffer; Count: Longint): Longint;
  2573. begin
  2574.   raise EStreamError.CreateRes(SWriteError);
  2575. end;
  2576.  
  2577. function TResourceStream.Seek(Offset: Longint; Origin: Word): Longint;
  2578. begin
  2579.   case Origin of
  2580.     soFromBeginning:
  2581.       Result := inherited Seek(FStartPos + Offset, Origin) - FStartPos;
  2582.     soFromCurrent:
  2583.       Result := inherited Seek(Offset, Origin) - FStartPos;
  2584.     soFromEnd:
  2585.       Result := inherited Seek(FEndPos + Offset, soFromBeginning) - FStartPos;
  2586.   end;
  2587.   if Result > FEndPos then raise EStreamError.CreateRes(SReadError);
  2588. end;
  2589.  
  2590. function GetCurrentDir: string;
  2591. begin
  2592.   GetDir(0, Result);
  2593. end;
  2594.  
  2595. {$I-}
  2596. function SetCurrentDir(const Dir: string): Boolean;
  2597. begin
  2598.   ChDir(Dir);
  2599.   Result := IOResult = 0;
  2600. end;
  2601.  
  2602. {$ENDIF WIN32}
  2603.  
  2604. {$IFDEF WIN32}
  2605.  
  2606. procedure RaiseWin32Error(ErrorCode: DWORD);
  2607. var
  2608.   Error: EOSError;
  2609. begin
  2610.   if ErrorCode <> ERROR_SUCCESS then begin
  2611.     Error := EOSError.CreateFmt(SOSError, [ErrorCode, SysErrorMessage(ErrorCode)]);
  2612.     Error.ErrorCode := ErrorCode;
  2613.     raise Error;
  2614.   end;
  2615. end;
  2616.  
  2617. { Win32Check is used to check the return value of a Win32 API function
  2618.   which returns a BOOL to indicate success. }
  2619.  
  2620. {$IFNDEF RX_D3}
  2621. function Win32Check(RetVal: Bool): Bool;
  2622. var
  2623.   LastError: DWORD;
  2624. begin
  2625.   if not RetVal then begin
  2626.     LastError := GetLastError;
  2627.     raise Exception.CreateFmt('%s (%d)', [SysErrorMessage(LastError),
  2628.       LastError]);
  2629.   end;
  2630.   Result := RetVal;
  2631. end;
  2632. {$ENDIF RX_D3}
  2633.  
  2634. function CheckWin32(OK: Boolean): Boolean;
  2635. begin
  2636.   Result := Win32Check(Ok);
  2637. end;
  2638.  
  2639. {$ENDIF WIN32}
  2640.  
  2641. {$IFNDEF RX_D3}
  2642. function ResStr(Ident: Cardinal): string;
  2643. begin
  2644.   Result := LoadStr(Ident);
  2645. end;
  2646. {$ELSE}
  2647. function ResStr(const Ident: string): string;
  2648. begin
  2649.   Result := Ident;
  2650. end;
  2651. {$ENDIF}
  2652.  
  2653. { Check if this is the active Windows task }
  2654. { Copied from implementation of FORMS.PAS  }
  2655.  
  2656. type
  2657.   PCheckTaskInfo = ^TCheckTaskInfo;
  2658.   TCheckTaskInfo = record
  2659.     FocusWnd: HWnd;
  2660.     Found: Boolean;
  2661.   end;
  2662.  
  2663. function CheckTaskWindow(Window: HWnd; Data: Longint): WordBool;
  2664.   {$IFDEF WIN32} stdcall {$ELSE} export {$ENDIF};
  2665. begin
  2666.   Result := True;
  2667.   if PCheckTaskInfo(Data)^.FocusWnd = Window then begin
  2668.     Result := False;
  2669.     PCheckTaskInfo(Data)^.Found := True;
  2670.   end;
  2671. end;
  2672.  
  2673. function IsForegroundTask: Boolean;
  2674. var
  2675.   Info: TCheckTaskInfo;
  2676. {$IFNDEF WIN32}
  2677.   Proc: TFarProc;
  2678. {$ENDIF}
  2679. begin
  2680.   Info.FocusWnd := GetActiveWindow;
  2681.   Info.Found := False;
  2682. {$IFDEF WIN32}
  2683.   EnumThreadWindows(GetCurrentThreadID, @CheckTaskWindow, Longint(@Info));
  2684. {$ELSE}
  2685.   Proc := MakeProcInstance(@CheckTaskWindow, HInstance);
  2686.   try
  2687.     EnumTaskWindows(GetCurrentTask, Proc, Longint(@Info));
  2688.   finally
  2689.     FreeProcInstance(Proc);
  2690.   end;
  2691. {$ENDIF}
  2692.   Result := Info.Found;
  2693. end;
  2694.  
  2695. function GetWindowsVersion: string;
  2696. {$IFDEF WIN32}
  2697. const
  2698.   sWindowsVersion = 'Windows %s %d.%.2d.%.3d %s';
  2699. var
  2700.   Ver: TOsVersionInfo;
  2701.   Platform: string[4];
  2702. begin
  2703.   Ver.dwOSVersionInfoSize := SizeOf(Ver);
  2704.   GetVersionEx(Ver);
  2705.   with Ver do begin
  2706.     case dwPlatformId of
  2707.       VER_PLATFORM_WIN32s: Platform := '32s';
  2708.       VER_PLATFORM_WIN32_WINDOWS:
  2709.         begin
  2710.           dwBuildNumber := dwBuildNumber and $0000FFFF;
  2711.           if (dwMajorVersion > 4) or ((dwMajorVersion = 4) and
  2712.             (dwMinorVersion >= 10)) then Platform := '98'
  2713.           else Platform := '95';
  2714.         end;
  2715.       VER_PLATFORM_WIN32_NT: Platform := 'NT';
  2716.     end;
  2717.     Result := Trim(Format(sWindowsVersion, [Platform, dwMajorVersion,
  2718.       dwMinorVersion, dwBuildNumber, szCSDVersion]));
  2719.   end;
  2720. end;
  2721. {$ELSE}
  2722. const
  2723.   sWindowsVersion = 'Windows%s %d.%d';
  2724.   sNT: array[Boolean] of string[3] = ('', ' NT');
  2725. var
  2726.   Ver: Longint;
  2727. begin
  2728.   Ver := GetVersion;
  2729.   Result := Format(sWindowsVersion, [sNT[not Boolean(HiByte(LoWord(Ver)))],
  2730.     LoByte(LoWord(Ver)), HiByte(LoWord(Ver))]);
  2731. end;
  2732. {$ENDIF WIN32}
  2733.  
  2734. initialization
  2735. {$IFDEF WIN32}
  2736. finalization
  2737.   ReleaseBitmap;
  2738. {$ELSE}
  2739.   AddExitProc(ReleaseBitmap);
  2740. {$ENDIF}
  2741. end.