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