{

  CoolUtilities ver. 1.08 Registered!
  Copyright (c) 1997-2003 by Artem A. Berman
  Copyright (c) 1997-2003 by CoolDev.Com

}

{$I versions.inc}
unit CoolUtils;

interface

uses
  Windows, Messages, Classes, Graphics, StdCtrls, ExtCtrls, Dialogs, Controls,
  ComCtrls, CommCtrl, Buttons, SysUtils, Menus, Forms, FileCtrl, Registry;

type
  // Positions the shadow relatively to the main text.
  // <TABLE>
  // Value              Meaning
  // -------            -------------------------
  // spLeftTop          Shadow is in the Left Top direction.
  // spLeftBottom       Shadow is in the Left Bottom direction.
  // spRightBottom      Shadow is in the Right Bottom direction.
  // spRightTop         Shadow is in the Right Top direction.
  // </TABLE>
  TShadowPosition = (spLeftTop,
                     spLeftBottom,
                     spRightBottom,
                     spRightTop);

  // Determines the type of bevel to be drawn with the items.
  //<TABLE>
  // Value                   Meaning
  // -----                   -------
  // bsBevelBoth             Bevel for both text and image.
  // bsBevelOnlyImage        Bevel for image only
  // bsBevelOnlyText         Bevel for text only
  //</TABLE>
  TBevelStyleEx = (bsBevelBoth, 
                   bsBevelOnlyImage,
                   bsBevelOnlyText);

  // Event sent when window receives the message.
  TWinMessageEvent = procedure(Sender: TObject;
                               var Msg: TMessage;
                               var Handled: Boolean) of object;

  // TWndHook encapsulates the hook that can be installed for a window
  // hoo allows to preview messages sent to the window.
  TWndHook = class(TComponent)
  private
    FActive: Boolean;
    FWinControl: TWinControl;
    FOnBeforeMessage,
    FOnAfterMessage: TWinMessageEvent;
    FOnChangeWinControl: TNotifyEvent;
    procedure SetActive(Value: Boolean);
    function GetHandle: THandle;
    procedure SetWinControl(Value: TWinControl);
  protected
    FNewProc, FDefProc: Pointer;
    procedure HookWnd(AHandle: THandle); virtual;
    procedure UnhookWnd(AHandle: THandle); virtual;
    procedure UnhookWndEx(AHandle: THandle); virtual;
    procedure WndProc(var Msg: TMessage); virtual;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    // Procedure can be used to remove and set back the hook for window.
    procedure RehookWnd; virtual;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    // Use  Active to activate and deactivate the installed hook for
    // the window.
    property Active: Boolean read FActive write SetActive default False;
    // Use WinControl to specify the windowed control (TWinControl descendant) that
    // you want to monitor for messages sent.
    property WinControl: TWinControl read FWinControl write SetWinControl;
    // Use handle property to address the particular instance of the TWndHook.
    property Handle: THandle read GetHandle;
    // Event fired right before message being processed by the destination control.
    //
    // See Also:
    //   WinControl
    property OnBeforeMessage: TWinMessageEvent read FOnBeforeMessage write FOnBeforeMessage;
    // Event fired right after message was processed by the destination control.
    //
    // See Also:
    //   WinControl
    property OnAfterMessage: TWinMessageEvent read FOnAfterMessage write FOnAfterMessage;
    // Event fired when WinControl value has been modified.
    property OnChangeWinControl: TNotifyEvent read FOnChangeWinControl write FOnChangeWinControl;
  end;

  // TGlyphList is advanced TImageList class that used to store normal and masked glyphs.
  TGlyphList = class(TImageList)
  private
    Used: TBits;
    FCount: Integer;
    function AllocateIndex: Integer;
  public
    constructor CreateSize(AWidth, AHeight: Integer);
    destructor Destroy; override;
    // Adds bitmap image to the list.
    //
    // Parameters:
    //   Image - Bitmap image to be added to the list.
    //   Mask  - Bitmap Mask.
    function Add(Image, Mask: TBitmap): Integer;
    // Adds bitmap image to the list.
    //
    // Parameters:
    //   Image      - Bitmap image to be added to the list.
    //   MaskColor  - Color of the Mask.
    function AddMasked(Image: TBitmap; MaskColor: TColor): Integer;
    // Deletes image from the list.
    procedure Delete(Index: Integer);
    property Count: Integer read FCount;
  end;

  // TGlyphCache is sinternal class that returns references to the TGlyphList.
  TGlyphCache = class
  private
    GlyphLists: TList;
  public
    constructor Create;
    destructor Destroy; override;
    function GetList(AWidth, AHeight: Integer): TGlyphList;
    procedure ReturnList(List: TGlyphList);
    function Empty: Boolean;
  end;

  // TGlyph encapsulates glyph (bitmap image) with the attached caption
  // and routines to draw the glyph in many various ways.
  TGlyph = class
  private
    FOriginal: TBitmap;
    FGlyphList: TGlyphList;
    FIndexs: array[Boolean] of Integer;
    FTransparentColor: TColor;
    FNumGlyphs: TNumGlyphs;
    FOnChange: TNotifyEvent;
    FSimpleCaption: Boolean;
    procedure GlyphChanged(Sender: TObject);
    procedure SetGlyph(Value: TBitmap);
    procedure SetNumGlyphs(Value: TNumGlyphs);
    procedure Invalidate;
    function CreateGlyph(State: Boolean): Integer;
    procedure CalcButtonLayout(Canvas: TCanvas; const Client: TRect;
      const Offset: TPoint; const Caption: string; Layout: TButtonLayout;
      Margin, Spacing: Integer; var GlyphPos: TPoint; var TextBounds: TRect;
      BiDiFlags: Longint);
  public
    constructor Create;
    destructor Destroy; override;

    // Draws the caption on the canvas.
    procedure DrawCaption(Canvas: TCanvas; const Caption: string;
      TextBounds: TRect; State: Boolean; SimpleView: Boolean; ShadowPos: TShadowPosition;
      ShadowColor: TColor; ShadowSize: Integer; BiDiFlags: Longint);

    // Draws the image on the canvas.
    procedure DrawImage(Canvas: TCanvas; const GlyphPos: TPoint;
      State: Boolean; Transparent: Boolean; BkColor: TColor);

    // Draws the image on the canvas with extra parameters.
    procedure DrawImageEx(Canvas: TCanvas; const Client: TRect; const Offset: TPoint; const Caption: string; Layout: TButtonLayout;
      Margin, Spacing: Integer; State: Boolean; Transparent: Boolean; BkColor: TColor; BiDiFlags: Longint);

    // Draws bevels around specified rect.
    procedure DrawBevels(Canvas: TCanvas; const Client: TRect; const Offset: TPoint; const Caption: string; Layout: TButtonLayout;
      Margin, Spacing: Integer; BevelInner, BevelOuter: TPanelBevel; BevelStyle: TBevelStyleEx; BiDiFlags: Longint);

    // Draws complete glyphs content.
    function Draw(Canvas: TCanvas; const Client: TRect; const Offset: TPoint;
      const Caption: string; Layout: TButtonLayout; Margin, Spacing: Integer;
      State: Boolean; Transparent: Boolean; BkColor: TColor; SimpleView: Boolean; ShadowPos: TShadowPosition;
      ShadowColor: TColor; ShadowSize: Integer; BiDiFlags: Longint): TRect;

    // Draws complete glyphs content with the double-buffering.
    function DrawFast(Canvas: TCanvas; const Client: TRect; const Offset: TPoint;
      const Caption: string; Layout: TButtonLayout; Margin, Spacing: Integer;
      State: Boolean; Transparent: Boolean; BkColor: TColor; SimpleView: Boolean; ShadowPos: TShadowPosition;
      ShadowColor: TColor; ShadowSize: Integer; BiDiFlags: Longint): TRect;

    // Bitmap associated with the object.
    property Glyph: TBitmap read FOriginal write SetGlyph;
    // Number of glyphs the Glyph property contains.
    //
    // See Also:
    //   NumGlyphs
    property NumGlyphs: TNumGlyphs read FNumGlyphs write SetNumGlyphs;
    // Event fired when glyph changed.
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    // Caption associated with the glyph.
    property SimpleCaption: Boolean read FSimpleCaption write FSimpleCaption;
  end;

// Determines whether Delphi or C++Builder (any versions) is running.
//
// Result:
//  Boolean value indicating function result. 
function DelphiRunning: Boolean;
// Determines whether Delphi or C++Builder (any versions) is running by checking file name. If it's Delphi's name
// then we drun from within IDE.
//
// Result:
//  Boolean value indicating function result. 
function DelphiRunningByExeName(AFileName: TFileName): Boolean;
// Paints bitmap wallpapers on the specified device context.
//
// Parameters:
//   DC        - The handle of the device context painting will occur on.
//   Bitmap    - Bitmap image to be drawn on the specified DC.
//   Recty     - Bounding rectangle the painting will occur within.
//   IsStretch - Determines whether wallpapers should be painted in tiled or stretched manner.
//   Mode      - Determines painting mode.
procedure DrawWallpaper(DC: HDC; Bitmap: TBitmap; Recty: TRect; IsStretch: Boolean; Mode: Integer);
// Paints part of the bitmap wallpapers on the specified device context.
//
// Parameters:
//   DC        - The handle of the device context painting will occur on.
//   Bitmap    - Bitmap image to be drawn on the specified DC.
//   Recty     - Bounding rectangle the painting will occur within.
//   SubRect   - Defines the part of the Bitmap we would like to draw.
//   IsStretch - Determines whether wallpapers should be painted in tiled or stretched manner.
//   Mode      - Determines painting mode.
procedure DrawWallpaperEx(DC: HDC; Bitmap: TBitmap; Recty, SubRect: TRect; IsStretch: Boolean; Mode: Integer);
// Paints wallpaper on the specified context in a stretched manner.
//
// Parameters:
//   DC        - The handle of the device context painting will occur on.
//   Bitmap    - Bitmap image to be drawn on the specified DC.
//   DCRecty   - Bounding rectangle the painting will occur within.
//   ImgRecty  - Defines the part of the Bitmap we would like to draw.
//   Mode      - Determines painting mode.
procedure StretchDrawWallpaper(DC: HDC; Bitmap: TBitmap; DCRecty, ImgRecty: TRect; Mode: Integer);
// Invalidates (repaints) the devicwe context.
//
// Parameters:
//   Handle - Handle of the device context to be invalidated.
//   R      - Bounding rectangle that will be invalidated.
//   bErase - Whether the DC should be erased.
function InvalidateRectEx(Handle: THandle; const R: TRect; bErase: Boolean): Boolean;
// Inflates (resizes) the rectangle.
//
// Parameters:
//   R       - Rectangle to be resized.
//   lOffset - Units to inflate left coordinate of the rectangle on.
//   tOffset - Units to inflate top coordinate of the rectangle on.
//   rOffset - Units to inflate right coordinate of the rectangle on.
//   bOffset - Units to inflate bottom coordinate of the rectangle on.
procedure InflateRectEx(var R: TRect; lOffset, tOffset, rOffset, bOffset: Integer);
// Determines whether the given font is True Type One (TTF).
//
// Parameters:
//   FontMane - name of the font we're performing scwheckig for.
//
// Result:
//  Boolean value indicating function result. 
function CheckTTFont(FontName: string): Boolean;
// Fills specified canvas gradientally.
//
// Parameters:
//   DC          - Device context painting occurs on.
//   Rect        - Rectangle the painting occwurs within.
//   BeginColor  - Starting color of the gradient fill.
//   EndColor    - Ending color of the gradient fill.
//   Colors      - Number of colors gradient set contains.
//   LeftToRight - Whether the painting occurs in horizontal or vertical dimensions.
procedure FillGradientRect(DC: HDC; Rect: TRect; BeginColor, EndColor: TColor; Colors: Integer; LeftToRight: Boolean);
// Paints on he specified control's device context background of the underlying parent control.
//
// Parameters:
//   Control  - control to paint the backround for (transparent control).
//   DC       - device context to paerform the painting on.
//   DoParent - whether the background should be taken from the parent of the specified control or the control points to the control with the background.
procedure PaintBackground(Control: TWinControl; DC: HDC; DoParent: Boolean);
// Paints on he specified control's device context background of the underlying parent control.
//
// Parameters:
//   Control  - control to paint the backround for (transparent control).
//   DC       - device context to paerform the painting on.
//   R        - bounding rectangle that defines area to be painted.
//   DoParent - whether the background should be taken from the parent of the specified control or the control points to the control with the background.
procedure PaintBackgroundEx(Control: TWinControl; DC: HDC; R: TRect; DoParent: Boolean);
// Paints on he specified control's device context background of the underlying parent control.
//
// Parameters:
//   Control     - control to paint the backround for (transparent control).
//   DC          - device context to paerform the painting on.
//   R           - bounding rectangle that defines area to be painted.
//   SubR        - subrect part of the rectangle R.
//   CombineMode - Mode to combine two regions with.
//   DoParent    - whether the background should be taken from the parent of the specified control or the control points to the control with the background.
procedure PaintBackgroundCombineRgn(Control: TWinControl; DC: HDC; R, SubR: TRect; CombineMode: Integer; DoParent: Boolean);
// Returns the color found in the Pt point on the control's Control canvas.
//
// Parameters:
//   Control    - Control that canvas will be examined.
//   Pt         - Point in which the color will be obtained.
//
// Result:
//   Color returned by the function.
function GetUnderlyingColor(Control: TWinControl; Pt: TPoint): TColor;
// Rotates the font on specified degree.
//
// Parameters:
//   AFont   - The font we're going to rotate.
//   ADegree - The degree we're rotating font on.
procedure SetAngledFont(const AFont: TFont; ADegree: Integer);
// Converts Icon into the Bitmap.
//
// Parameters:
//   Result  - The bitmap icon will be converted to.
//   Icon    - Source icon.
//   BgColor - Color used as background for the conversion.
procedure GetBitmapFromIcon(const Result: TBitmap; Icon: TIcon; BgColor: TColor);
// Obtains the default system menu font.
//
// Parameters:
//   AFont - TFont object that will be assigned to dthe default menu font.
//
// Result:
//   Returns size of the font used as system default.
function GetMenuDefaultFont(const AFont: TFont): Integer;
// Inverts the specified color.
// 
// Parameters:
//    FColor - color to be inverted.
//
// Result:
//    Returned color value.
function GetInvertedColor(FColor: TColor): TColor;
// Creates the mono bitmap from the normal given one.
//
// Parameters:
//    Result            - resulting monochrome bitmap.
//    TransparentColor  - color in a resulting bitmap marked as transparent.
//    BrushColor        - background brush color.
//    State             - bitmap's state.
//    OldStyle          - There are two possible ways to paint bitmap. This property determines which one will be used.
procedure CreateMonoBitmap(const Result: TBitmap; TransparentColor, BrushColor: TColor; State: Integer; OldStyle: Boolean);
// Draws rectangular edge with the rounded corners on the specified device.
//
// Parameters:
//   Canvas       - Canvas to paint edges on.
//   Recty        - Bounding rect of the edges.   
//   BgColor      - Background color used to draw edges.
//   BdColor      - Foreground color. 
//   Rounded      - Angle to round edges.
//   AInnerEdges  - Inner edges.
//   AOuterEdges  - Outer edges.
procedure DrawRoundedEdge(Canvas: TCanvas; Recty: TRect; BgColor, SdColor, BdColor: TColor; Rounded, AInnerEdges, AOuterEdges: Integer);
// Allows to justify the items in the main menu bar.
//
// Parameters:
//   Menu      - Menu containing item we're to set the justification for.
//   MenuItem  - Menu item we're to set the justification for.
//   Justify   - Justification (0,1).
procedure SetJustify(Menu: TMenu; MenuItem: TMenuItem; Justify: Byte);
// Obtains the number of system colors for specified canvas.
//
// Parameters:
//   Canvas - Canvas to obtain number of colors from.
// 
// Result:
//   Returns number of system colors available.
function GetSysColorsNumber(Canvas: TCanvas): LongInt;
// Determines whether the two points are equal that is have the same coordinates.
//
// Parameters:
//   APoint1 - Point 1 to compare.
//   APoint2 - Point 2 to compare.
//   Offset  - Allowed offset.
//
// Result:
//   Boolean value that indicates function result.
function PointsFakeEqual(APoint1, APoint2: TPoint; Offset: Integer): Boolean;
// Loads bitmap from either bitmap or icon resource.
// 
// Parameters:
//   AInstance      - Module to load the resource from.
//   AResourceName  - Name of the resource to be loaded.
//
// Result:
//   Returns handle of the resulting bitmap image.
function LoadBitmapIcon(AInstance: THandle; AResourceName: PChar): THandle;
// Opens bitmap from either bitmap or icon file.
// 
// Parameters:
//   FileName - name of the file to open bitmap from.
//
// Result:
//   Returns handle of the resulting bitmap image.
function OpenBitmapIcon(FileName: TFileName): THandle;
// Sets the delay in system.
//
// Parameters:
//   msecs - Time to pause he application on.
procedure Delay(msecs: DWORD);
// Rotates the bitmap image on the specified angle.
// 
// Parameters:
//   ABitmap - Image to be rotated by the specified angle.
//   AAngle  - Angle image will be rotated on.
procedure BitmapRotate(const ABitmap: TBitmap; AAngle: Integer);
// Determines whether the keyboard state has been changed.
//
// Parameters:
//   Keys - Keys to be examined.
//
// Result:
//   Boolean value that indicates function's result.
function KeyboardChanged(Keys: TKeyboardState): Boolean;
// Activates popup menu for the control using control's coordinates.
//
// Parameters:
//   WinControl - control which coordinates will be used to obtain the point we're going to activate the menu at.
//   Menu       - popup menu to activate.
//
// Result:
//   Boolean value that indicates function's result.
function Popup(WinControl: TWinControl; Menu: TPopupMenu): Boolean;
// Activates popup menu for the control using specified coordinates.
//
// Parameters:
//   WinControl - control which coordinates will be used to obtain the point we're going to activate the menu at.
//   Menu       - popup menu to activate.
//   X          - X coordinate.
//   Y          - Y coordinate.
//
// Result:
//   Boolean value that indicates function's result.
function PopupEx(WinControl: TWinControl; Menu: TPopupMenu; X, Y: Integer): Boolean;
// Creates new menu item.
//
// Parameters:
//   ACaption    - Caption of the newly created item.
//   AShortCut   - Shortcut of the newly created item.
//   ARadioItem  - Whether the item we're creating is radio item.
//   AChecked    - Whether the item we're creating should be checked.
//   AEnabled    - Whether the item we're creating should be enabled.
//   AOnClick    - OnClick procedure for item.
//   hCtx        - Help context for the newly created item.
//   ABreak      - Break staste for the item.
//   AName       - Name of the item.
//
// Result:
//   TMenuItem class created by the function.
function NewItemEx(const ACaption: string; AShortCut: TShortCut; ARadioItem, AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent; hCtx: Word; ABreak: TMenuBreak; const AName: string): TMenuItem;
// Returns min of two values.
//
// Parameters:
//   A - First integer to compare.
//   B  - Second integer to compare.
//
// Result:
//   Smaller from two itegers.
function MinVal(A, B: Integer): Integer;
// Returns max of two values.
//
// Parameters:
//   A - First integer to compare.
//   B  - Second integer to compare.
//
// Result:
//   Bigger from two itegers.
function MaxVal(A, B: Integer): Integer;
// Emulates the start button click.
//
// Result:
//   Boolean value that indicates function's result.
function FakeStartBtnClick: Boolean;
// Converts Boolean value into the string representation.
//
// Parameters:
//   Value - Boolean to be converted.
//
// Result:
//   String representation of the boolean.
function BoolToStr(Value: Boolean): string;
// Converts String value into the boolean representation.
//
// Parameters:
//   Value - String to be converted.
//
// Result:
//   Boolean representation of the string.
function StrToBool(Value: string): Boolean;
// Returns position of the symbol from the right (end of the string). As opposite to the known Pos function.
//
// Parameters:
//   SubStr  - Sub string to search the position of.
//   S       - String to search the position in.
//
// Result:
//   The position of the sub string. -1 if it was not found.
function RPos(SubStr, S: string): LongInt;
// Returns the name of the parent folder relatively to the specified one.
//
// Parameters:
//   FolderName - Name of the folder we're searching the parent of.
//
// Result:
//   Name of the parent folder.
function GetParentFolder(FolderName: TFileName): TFileName;
// Draws the text with shadow effect.
//
// Parameters:
//   DC          - Device context we're painting the text on.
//   R           - Bounding rectangle we're painting the text within.
//   ShadowPos   - Type of the shadow.
//   Text        - Text we're writing.
//   Flags       - Flags to paint the text with. See DrawText() API.
//   ColorText   - Color of the text.
//   ColorShadow - Color of the shadow.
//   ShadowSize  - Offset of the shadow.
//
// Result:
//   Boolean value that indicates function's result.
procedure Draw3DText(DC: HDC; var R: TRect; ShadowPos: TShadowPosition; Text: PChar; Flags: Longint; ColorText, ColorShadow: TColor; ShadowSize: Integer);
{$IFDEF VER90}
// Paints the bitmap transparently and stretches it to the given dimensions.
// 
// Parameters:
//   DstDC   - Device context we're  to paint the bitmap on.
//   DstX    - X coordinate on the destination device context.
//   DstY    - Y coordinate on the destination device context.
//   DstW    - Width of the bitmap on the destination device context.
//   DstH    - Height of the bitmap on the destination device context.
//   SrcDC   - Source device context.
//   SrcX    - X coordinate on the source device context.
//   SrcY    - Y coordinate on the source device context.
//   SrcW    - Width of the bitmap on the source device context.
//   SrcH    - Height of the bitmap on the source device context.
//   MaskDC  - DC with the mask image.
//   MaskX   - X coordinate on the mask device context.
//   MaskY   - Y coordinate on the mask device context.
function TransparentStretchBlt(DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
  SrcDC: HDC; SrcX, SrcY, SrcW, SrcH: Integer; MaskDC: HDC; MaskX,
  MaskY: Integer): Boolean;
// Copies mask of the bitmap image.
//
// Parameters:
//   Handle           - Handle of the bitmap to take the mask from.
//   Palette          - Palette used to take the mask.
//   TransparentColor - Color marked as transparent.
//
// Result:
//   Boolean value that indicates function's result.
function CopyBitmapAsMask(Handle: HBITMAP; Palette: HPALETTE;
  TransparentColor: TColorRef): HBITMAP;
{$ENDIF}
// Paints image transparently and stretches it when paints.
//
// Parameters:
//   DestDC      - Destination device context.
//   SourceDC    - Source device context.
//   DestRect    - Destination rectangle.
//   SourceRect  - Source rectangle.
//   TrColor     - Color marked as transparent.
procedure TransparentStretchBltEx(DestDC, SourceDC: HDC; DestRect, SourceRect: TRect; TrColor: TColor);
// Decreases the value on specified amount.
//
// Parameters:
//   Value   - value to be decreased.
//   Amount  - amount to decrease the value at.
//
// Result:
//   Resulting value.
function PredEx(Value, Amount: Integer): Integer;
// Increases the value on specified amount.
//
// Parameters:
//   Value   - value to be increased.
//   Amount  - amount to increase the value at.
//
// Result:
//   Resulting value.
function SuccEx(Value, Amount: Integer): Integer;
// Determines whether the component is in the design time,
//
// Parameters:
//   Component - component to be examined.
//
// Result:
//   Boolean value that indicates function's result.
function DesignTime(Component: TComponent): Boolean;
// Paints the pattern on the device.
//
// Parameters:
//   Canvas - canvas to paint the pattern on.
//   R      - bounding rectangle to paint the pattern within. 
procedure PaintPatternBackground(Canvas: TCanvas; R: TRect);
// Moves the point.
//
// Parameters:
//   P   - point to be moved.
//   X   - units to move the point horizontally.
//   Y   - units to move the point vertically.
procedure OffsetPoint(var P: TPoint; X, Y: Integer);
// Returrns the parent of the control. Deep to the TransparencyLevel.
//
// Parameters:
//   SelfControl        - control that we're to get the parent of.
//   TransparencyLevel  - Level of the parent search.
//
// Result:
//  Either nil or obtained parent.
function TrControl(SelfControl: TWinControl; TransparencyLevel: Byte): TWinControl;
// Checks whether mouse cursor is within the control's bounding rect.
//
// Parameter:
//   Control   - control that will be examined.
//
// Result:
//   Boolean value that indicates function's result.
function MouseInCtl(Control: TControl): Boolean;
// Reurns current state of the special buttons.
//
// Result:
//   Current shift state.
function CurrentShiftState: TShiftState;
// Forces the CM_MOUSELEAVE to be sent. Not the best solution
// however because the message never sent if you move the mouse outta
// control fast - it's acceptable.
//
// Parameters:
//   Control - Control we will be sending the message to.
//   CheckTimeoit - When elasped and apparently mouse is not in a control we send message.
procedure ForceMouseLeaveMessage(Control: TControl; CheckTimeout: Cardinal);
// Returns alphabetically sorted list of the files and directories in the current folder.
//
// Parameters:
//   FDirectory - Folder which contents we're obtaining.
//   Filter - Valid DOS mask.
//   Attr - Attributes of the files to be included.
// Result:
//   String list with the file and folder names. 
function GetFileDirList(FDirectory, Filter: TFileName; Attr: Integer): TStringList;

implementation

var
  GlyphCache: TGlyphCache = nil;

type
  {THookList}
  THookList = class(TList)
  private
    FHandle: HWnd;
    procedure WndProc(var Msg: TMessage);
  public
    constructor Create;
    destructor Destroy; override;
    property Handle: HWnd read FHandle;
  end;

const
  CM_DESTROYHOOK = WM_USER+301;
  CM_RECREATEWND = WM_USER+302;

var
  HookList: THookList;

{Function been taken from SWAG}
function DelphiRunning: Boolean;
var
  H1, H2, H3, H4: Hwnd;
const
  {$IFNDEF BCB}
     {$IFDEF VER90}
       A0: array[0..10] of Char = 'Delphi 2.0'#0;
     {$ENDIF}
     {$IFDEF VER100}
       A0: array[0..8] of Char = 'Delphi 3'#0;
     {$ENDIF}
     {$IFDEF VER120}
       A0: array[0..8] of Char = 'Delphi 4'#0;
     {$ENDIF}
     {$IFDEF VER130}
       A0: array[0..8] of Char = 'Delphi 5'#0;
     {$ENDIF}
     {$IFDEF VER140}
        A0: array[0..8] of Char = 'Delphi 6'#0;
     {$ENDIF}
     {$IFDEF VER150}
        A0: array[0..8] of Char = 'Delphi 7'#0;
     {$ENDIF}
  {$ELSE}
    {$IFDEF VER140}
      A0: array[0..12] of Char = 'C++Builder 6'#0;
    {$ENDIF}

    {$IFDEF VER130}
      A0: array[0..12] of Char = 'C++Builder 5'#0;
    {$ENDIF}

    {$IFDEF VER125}
      A0: array[0..12] of Char = 'C++Builder 3'#0;
    {$ENDIF}
  {$ENDIF}
  A1: array[0..12] of Char = 'TApplication'#0;
  A2: array[0..15] of Char = 'TAlignPalette'#0;
  A3: array[0..18] of Char = 'TPropertyInspector'#0;
  A4: array[0..11] of Char = 'TAppBuilder'#0;
begin
  H1 := FindWindow(A1, A0);
  H2 := FindWindow(A2, nil);
  H3 := FindWindow(A3, nil);
  H4 := FindWindow(A4, nil);
  Result := (H1 <> 0) and (H2 <> 0) and (H3 <> 0) and (H4 <> 0);
end;

function DelphiRunningByExeName(AFileName: TFileName): Boolean;
begin
  with TRegIniFile.Create('') do
  try
    RootKey := HKEY_LOCAL_MACHINE;
    Result := (CompareText(AFileName, ReadString('Software\Borland\Delphi\2.0', 'Delphi 2.0', '')) = 0) or
              (CompareText(AFileName, ReadString('Software\Borland\Delphi\3.0', 'Delphi 3', '')) = 0) or
              (CompareText(AFileName, ReadString('Software\Borland\Delphi\4.0', 'Delphi 4', '')) = 0) or
              (CompareText(AFileName, ReadString('Software\Borland\Delphi\5.0', 'App', '')) = 0) or
              (CompareText(AFileName, ReadString('Software\Borland\Delphi\6.0', 'App', '')) = 0) or
              (CompareText(AFileName, ReadString('Software\Borland\Delphi\7.0', 'App', '')) = 0) or
              (CompareText(AFileName, ReadString('Software\Borland\C++Builder\1.0', 'App', '')) = 0) or
              (CompareText(AFileName, ReadString('Software\Borland\C++Builder\3.0', 'App', '')) = 0) or
              (CompareText(AFileName, ReadString('Software\Borland\C++Builder\4.0', 'App', '')) = 0) or
              (CompareText(AFileName, ReadString('Software\Borland\C++Builder\5.0', 'App', '')) = 0) or
              (CompareText(AFileName, ReadString('Software\Borland\C++Builder\6.0', 'App', '')) = 0);
  finally
    Free;
  end;
end;

procedure DrawWallpaper(DC: HDC; Bitmap: TBitmap; Recty: TRect; IsStretch: Boolean;
                        Mode: Integer);
var
  X, Y: Integer;
begin
  with Recty, Bitmap do
    if IsStretch then
      StretchDrawWallpaper(DC, Bitmap, Recty, Rect(0, 0, Width, Height), Mode)
    else
      begin
        X := Left;
        Y := Top;
        while Y < Bottom do
        begin
          while X < Right do
          begin
            BitBlt(DC, X, Y, Right-X, Bottom-Y, Canvas.Handle, 0, 0, Mode);
            Inc(X, Width);
          end;
          X := Left;
          Inc(Y, Height);
        end;
      end;
end;

procedure DrawWallpaperEx(DC: HDC; Bitmap: TBitmap; Recty, SubRect: TRect; IsStretch: Boolean; Mode: Integer);
var
  Rgn: HRGN;
  SaveIndex: Integer;
begin
  if EqualRect(SubRect, Recty) then
    DrawWallpaper(DC, Bitmap, SubRect, IsStretch, Mode) else
    begin
      SaveIndex := SaveDC(DC);
      try
        Rgn := CreateRectRgnIndirect(SubRect);
        try
          SelectClipRgn(DC, Rgn);
          DrawWallpaper(DC, Bitmap, Recty, IsStretch, Mode);
          SelectClipRgn(DC, 0);
        finally
          DeleteObject(Rgn);
        end;
      finally
        RestoreDC(DC, SaveIndex);
      end;
    end;
end;

procedure StretchDrawWallpaper(DC: HDC; Bitmap: TBitmap; DCRecty, ImgRecty: TRect;
                        Mode: Integer);
begin
  with Bitmap do
    StretchBlt(DC, DCRecty.Left, DCRecty.Top, DCRecty.Right - DCRecty.Left, DCRecty.Bottom - DCRecty.Top,
               Canvas.Handle,
               ImgRecty.Left, ImgRecty.Top, ImgRecty.Right - ImgRecty.Left, ImgRecty.Bottom - ImgRecty.Top,
               Mode);
end;

function InvalidateRectEx(Handle: THandle; const R: TRect; bErase: Boolean): Boolean;
begin
  Result := InvalidateRect(Handle, @R, bErase);
end;

type
  TWinCtl = class(TWinControl);

procedure PaintBackground(Control: TWinControl; DC: HDC; DoParent: Boolean);
var
  P: TPoint;
  SaveIndex: Integer;
begin
  if Assigned(Control) then
  begin
    SaveIndex := SaveDC(DC);
    try
      P := Control.ClientOrigin;
      ScreenToClient(Control.Parent.Handle, P);
      MoveWindowOrg(DC, -P.X, -P.Y);
      if Assigned(Control.Parent) and DoParent then
      begin
        SendMessage(Control.Parent.Handle, WM_ERASEBKGND, DC, 0);
        TWinCtl(Control.Parent).PaintControls(DC, nil);
      end else
      begin
        SendMessage(Control.Handle, WM_ERASEBKGND, DC, 0);
        TWinCtl(Control).PaintControls(DC, nil);
      end;
    finally
      RestoreDC(DC, SaveIndex);
    end;
  end;
end;

procedure PaintBackgroundEx(Control: TWinControl; DC: HDC; R: TRect; DoParent: Boolean);
var
  Rgn: HRGN;
  SaveIndex: Integer;
begin
  SaveIndex := SaveDC(DC);
  try
    Rgn := CreateRectRgnIndirect(R);
    try
      SelectClipRgn(DC, Rgn);
      PaintBackground(Control, DC, DoParent);
      SelectClipRgn(DC, 0);
    finally
      DeleteObject(Rgn);
    end;
  finally
    RestoreDC(DC, SaveIndex);
  end;
end;

procedure PaintBackgroundCombineRgn(Control: TWinControl; DC: HDC; R, SubR: TRect; CombineMode: Integer; DoParent: Boolean);
var
  Rgn1, Rgn2: HRGN;
  SaveIndex: Integer;
begin
  SaveIndex := SaveDC(DC);
  try
    Rgn1 := CreateRectRgnIndirect(R);
    try
      Rgn2 := CreateRectRgnIndirect(SubR);
      try
        CombineRgn(Rgn1, Rgn1, Rgn2, CombineMode);
        SelectClipRgn(DC, Rgn1);
        PaintBackground(Control, DC, DoParent);
        SelectClipRgn(DC, 0);
      finally
        DeleteObject(Rgn2);
      end;
    finally
      DeleteObject(Rgn1);
    end;
  finally
    RestoreDC(DC, SaveIndex);
  end;
end;

function GetUnderlyingColor(Control: TWinControl; Pt: TPoint): TColor;
var
  TmpBmp: TBitmap;
begin
  Result := clNone;
  if Assigned(Control) and Assigned(Control.Parent) then
  begin
    TmpBmp := TBitmap.Create;
    try
      TmpBmp.Width := Control.Parent.Width;
      TmpBmp.Height := Control.Parent.Height;
      SendMessage(Control.Parent.Handle, WM_ERASEBKGND, TmpBmp.Canvas.Handle, 0);
      Result := TmpBmp.Canvas.Pixels[Pt.X, Pt.Y];
    finally
      TmpBmp.Free;
    end;
  end;
end;

function CheckTTFont(FontName: string): Boolean;
var
  DC: HDC;
  Font: TFont;
  SaveFont: HFont;
  Metrics: TTextMetric;
begin
  DC := GetDC(0);
  try
    Font := TFont.Create;
    try
      Font.Name := FontName;
      SaveFont := SelectObject(DC, Font.Handle);
      GetTextMetrics(DC, Metrics);
      SelectObject(DC, SaveFont);
      Result := (Metrics.tmPitchandFamily and TMPF_TRUETYPE) <> 0;
    finally
      Font.Free;
    end;
  finally
    ReleaseDC(0, DC);
  end;
end;

procedure InflateRectEx(var R: TRect; lOffset, tOffset, rOffset, bOffset: Integer);
begin
  with R do
  begin
    Left := Left+lOffset;
    Top := Top+tOffset;
    Right := Right+rOffset;
    Bottom := Bottom+bOffset;
  end;
end;

procedure FillGradientRect(DC: HDC; Rect: TRect; BeginColor, EndColor: TColor; Colors: Integer; LeftToRight: Boolean);
var
  RGBFrom: array[0..2] of Byte;
  RGBDiff: array[0..2] of integer;
  ColorBand : TRect;

  I: Integer;
  R,G,B: Byte;

  Brush: HBrush;
begin
  { extract from RGB values }
  RGBFrom[0] := GetRValue (ColorToRGB (BeginColor));
  RGBFrom[1] := GetGValue (ColorToRGB (BeginColor));
  RGBFrom[2] := GetBValue (ColorToRGB (BeginColor));
  { calculate difference of from and to RGB values }
  RGBDiff[0] := GetRValue (ColorToRGB (EndColor)) - RGBFrom[0];
  RGBDiff[1] := GetGValue (ColorToRGB (EndColor)) - RGBFrom[1];
  RGBDiff[2] := GetBValue (ColorToRGB (EndColor)) - RGBFrom[2];

  ColorBand := Rect;
  for I := 0 to Colors do
  begin
    { calculate color band's top and bottom coordinates }
    if LeftToRight then
    begin
      ColorBand.Left := MulDiv (I, Rect.Right - Rect.Left, Colors);
      ColorBand.Right := MulDiv (Succ(I), Rect.Right - Rect.Left, Colors);

      ColorBand.Left := ColorBand.Left + Rect.Left;
      ColorBand.Right := ColorBand.Right + Rect.Left;
    end else         
    begin
      ColorBand.Top := MulDiv (I, Rect.Bottom - Rect.Top, Colors);
      ColorBand.Bottom := MulDiv (Succ(I), Rect.Bottom - Rect.Top, Colors);

      ColorBand.Top := ColorBand.Top + Rect.Top;
      ColorBand.Bottom := ColorBand.Bottom + Rect.Top;
    end;

    { calculate color band color }
    R := RGBFrom[0] + MulDiv (I, RGBDiff[0], Colors);
    G := RGBFrom[1] + MulDiv (I, RGBDiff[1], Colors);
    B := RGBFrom[2] + MulDiv (I, RGBDiff[2], Colors);

    { select brush and paint color band }
    Brush := CreateSolidBrush(RGB(R, G, B));
    FillRect(DC, ColorBand, Brush);
    DeleteObject(Brush);
  end;
end;

procedure SetAngledFont(const AFont: TFont; ADegree: Integer);
var
  LogRec: TLOGFONT;
begin
  GetObject(AFont.Handle, SizeOf(LogRec), @LogRec);
  LogRec.lfEscapement := ADegree*10;
  AFont.Handle := CreateFontIndirect(LogRec);
end;

procedure GetBitmapFromIcon(const Result: TBitmap; Icon: TIcon; BgColor: TColor);
begin
  with Result, Result.Canvas do
  try
    Width := Icon.Width;
    Height := Icon.Height;

    Brush.Color := BgColor;
    FillRect(Rect(0, 0, Width, Height));
    Draw(0, 0, Icon);
  except
    raise;
  end;
end;

function GetMenuDefaultFont(const AFont: TFont): Integer;
var
  Metrics: TNonClientMetrics;
begin
  Metrics.cbSize := SizeOf(Metrics);

  if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @Metrics, 0) then
    AFont.Handle := CreateFontIndirect(Metrics.lfMenuFont) else
      AFont.Handle := GetStockObject(SYSTEM_FONT);

  Result := AFont.Height;
end;

function GetInvertedColor(FColor: TColor): TColor;
var
  R, G, B: LongInt;
begin
  R := GetRValue(ColorToRGB(FColor));
  G := GetGValue(ColorToRGB(FColor));
  B := GetBValue (ColorToRGB(FColor));

  R := 255 - R;
  G := 255 - G;
  B := 255 - B;

  Result := TColor((B*256 + G)*256 + R);
end;

procedure CreateMonoBitmap(const Result: TBitmap; TransparentColor, BrushColor: TColor; State: Integer; OldStyle: Boolean);
const
  ROP_DSPDxax = $00E20746;
  ROP_PSDPxax = $00B8074A;
var
  TmpImage, DDB, MonoBmp: TBitmap;
  IWidth, IHeight: Integer;
  IRect, ORect: TRect;
const
  Add = 1;
begin
  IWidth := Result.Width;
  IHeight := Result.Height;

  IRect := Rect(0, 0, IWidth, IHeight);
  ORect := Rect(0, 0, IWidth, IHeight);

  TmpImage := TBitmap.Create;
  try
    TmpImage.Width := IWidth;
    TmpImage.Height := IHeight;
    TmpImage.Canvas.Brush.Color := clBtnFace;
    {$ifndef ver90}
    TmpImage.Palette := CopyPalette(Result.Palette);
    {$endif}

    MonoBmp := TBitmap.Create;
    try
      DDB := TBitmap.Create;
      try
        DDB.Assign(Result);
        {$ifndef ver90}
        DDB.HandleType := bmDDB;
        {$endif}

        if OldStyle then
        begin
          //Stabdard Inprise technique
          with MonoBmp do
          begin
            Assign(Result);
            {$ifndef ver90}
            HandleType := bmDDB;
            {$endif}            

            Canvas.Brush.Color := clBlack;
            if Monochrome then
            begin
              Canvas.Font.Color := clWhite;
              Monochrome := False;
              Canvas.Brush.Color := clWhite;
            end;
            Monochrome := True;
          end;
          with TmpImage.Canvas do
          begin
            Brush.Color := BrushColor;
            FillRect(IRect);

            if (State and ODS_SELECTED) <> 0 then
              Brush.Color := clBtnShadow else
                Brush.Color := clBtnHighlight;

            SetTextColor(Handle, clBlack);
            SetBkColor(Handle, clWhite);
            BitBlt(Handle, 1, 1, IWidth-Add, IHeight-Add,
            MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
            Brush.Color := clBtnShadow;
            SetTextColor(Handle, clBlack);
            SetBkColor(Handle, clWhite);
            BitBlt(Handle, 0, 0, IWidth-Add, IHeight-Add,
            MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
          end;
        end else
        begin
          // Idea from Jordan Russell's ToolBar97
          MonoBmp.Monochrome := True;
          MonoBmp.Width := IWidth;
          MonoBmp.Height := IHeight;

          with TmpImage.Canvas do
          begin
            CopyRect (Rect(0, 0, IWidth-Add, IHeight-Add), DDB.Canvas, ORect);

            { Generate the mask in MonoBmp. Mask FTransparentColor }
            SetBkColor(Handle, ColorToRGB(TransparentColor));
            BitBlt(MonoBmp.Canvas.Handle, 0, 0, IWidth, IHeight, Handle,
                   ORect.Left, ORect.Top, SRCCOPY);
            { and clWhite }
            SetBkColor (Handle, clWhite);
            BitBlt(MonoBmp.Canvas.Handle, 0, 0, IWidth, IHeight, Handle,
                  ORect.Left, ORect.Top, SRCPAINT);
            { and clSilver }
            SetBkColor (Handle, clSilver);
            BitBlt(MonoBmp.Canvas.Handle, 0, 0, IWidth, IHeight, Handle,
                  ORect.Left, ORect.Top, SRCPAINT);

            Brush.Color := BrushColor;
            FillRect(IRect);

            if (State and ODS_SELECTED) <> 0 then
              Brush.Color := clBtnShadow else
                Brush.Color := clBtnHighlight;

            SetTextColor(Handle, clBlack);
            SetBkColor(Handle, clWhite);
            BitBlt(Handle, 1, 1, IWidth-1, IHeight-1,
            MonoBmp.Canvas.Handle, 0, 0, ROP_PSDPxax);
            Brush.Color := clBtnShadow;
            SetTextColor(Handle, clBlack);
            SetBkColor(Handle, clWhite);
            BitBlt(Handle, 0, 0, IWidth, IHeight,
                   MonoBmp.Canvas.Handle, 0, 0, ROP_PSDPxax);
          end;
        end;
        Result.Assign(TmpImage);
      finally
        DDB.Free;
      end;
    finally
      MonoBmp.Free;
    end;
  finally
    TmpImage.Free;
  end;
end;

procedure DrawRoundedEdge(Canvas: TCanvas; Recty: TRect; BgColor, SdColor, BdColor: TColor;
                          Rounded, AInnerEdges, AOuterEdges: Integer);
var
  InL, InR, InT, InB,
  OutL, OutR, OutT, OutB: Integer;
begin
  with Canvas, Recty do
  begin
    InL := Left;
    InR := Right-2;
    InT := Top;
    InB := Bottom-2;

    OutL := Left+1;
    OutR := Right-1;
    OutT := Top+1;
    OutB := Bottom-1;
    Brush.Style := bsClear;
    Brush.Color := BgColor;
    Pen.Width := 1;

    if AInnerEdges = BDR_RAISEDINNER then
    begin
      Pen.Color := BdColor;
      RoundRect(InL, InT, InR, InB, Rounded, Rounded);
    end;
    if AInnerEdges = BDR_SUNKENINNER then
    begin
      Pen.Color := SdColor;
      RoundRect(InL, InT, InR, InB, Rounded, Rounded);
    end;
    if AOuterEdges = BDR_SUNKENOUTER then
    begin
      Pen.Color := BdColor;
      RoundRect(OutL, OutT, OutR, OutB, Rounded, Rounded);
    end;
    if AOuterEdges = BDR_RAISEDOUTER then
    begin
      Pen.Color := SdColor;
      RoundRect(OutL, OutT, OutR, OutB, Rounded, Rounded);
    end;

    Pen.Color := BgColor;
    RoundRect(OutL, OutT, InR, InB, Rounded, Rounded);
  end;
end;

procedure SetJustify(Menu: TMenu; MenuItem: TMenuItem; Justify: Byte);
var
  ItemInfo: TMenuItemInfo;
  Buffer: array[0..79] of Char;
begin
  with ItemInfo do
  begin
    {$IFNDEF DELPHI4_OR_ABOVE}
    cbSize := SizeOf(TMenuItemInfo);
    {$ELSE}
    cbSize := 44;
    {$ENDIF}
    fMask := MIIM_TYPE;

    dwTypeData := Buffer;
    cch := SizeOf(Buffer);

    GetMenuItemInfo(Menu.Handle, MenuItem.Command, False, ItemInfo);

    if Justify = 1 then
      fType := fType or MFT_RIGHTJUSTIFY else
        fType := fType and not MFT_RIGHTJUSTIFY;

    SetMenuItemInfo(Menu.Handle, MenuItem.Command, False, ItemInfo);
  end;
end;

function GetSysColorsNumber(Canvas: TCanvas): LongInt;
begin
  Result := (LongInt(1) shl GetDeviceCaps(Canvas.Handle, BitsPixel))*LongInt(GetDeviceCaps(Canvas.Handle, Planes));
end;

function PointsFakeEqual(APoint1, APoint2: TPoint; Offset: Integer): Boolean;
begin
  Result := PtInRect(Rect(APoint1.X-Offset, APoint1.Y-Offset, APoint1.X+Offset, APoint1.Y+Offset), APoint2);
end;

function LoadBitmapIcon(AInstance: THandle; AResourceName: PChar): THandle;
var
  Bitmap: TBitmap;
  Icon: TIcon;
begin
  Result := LoadBitmap(AInstance, AResourceName);
  if Result = 0 then
  begin
    Bitmap := TBitmap.Create;
    try
      Icon := TIcon.Create;
      try
        Icon.Handle := LoadIcon(AInstance, AResourceName);
        GetBitmapFromIcon(Bitmap, Icon, clOlive);
        Result := Bitmap.ReleaseHandle;
      finally
        Icon.Free;
      end;
    finally
      Bitmap.Free;
    end;
  end;
end;

function OpenBitmapIcon(FileName: TFileName): THandle;
var
  Icon: TIcon;
  Bitmap: TBitmap;
begin
  if FileExists(FileName) then
    if ExtractFileExt(FileName) = '.bmp' then
    begin
      Bitmap := TBitmap.Create;
      try
        Bitmap.LoadFromFile(FileName);
        Result := Bitmap.ReleaseHandle;
      finally
        Bitmap.Free;
      end;
    end else
    if ExtractFileExt(FileName) = '.ico' then
    begin
      Bitmap := TBitmap.Create;
      try
        Icon := TIcon.Create;
        try
          Icon.LoadFromFile(FileName);
          GetBitmapFromIcon(Bitmap, Icon, clOlive);
          Result := Bitmap.ReleaseHandle;
        finally
          Icon.Free;
        end;
      finally
        Bitmap.Free;
      end;
    end 
    else
    Result := 0
    else
    Result := 0
end;

procedure Delay(msecs : DWORD);
var
  EndTime: DWORD;
begin
  EndTime := GetTickCount + msecs;
  while EndTime > GetTickCount do
    if Application.Terminated then
      Break else Application.ProcessMessages;
end;

procedure BitmapRotate(const ABitmap: TBitmap; AAngle: Integer);
var
  I, x, y,
  nx, ny: Integer;
  lpBitmap: TBitmap;
begin
  lpBitmap := TBitmap.Create;
  try
    for I := 0 to AAngle do
    begin
      lpBitmap.Height := ABitmap.Width;
      lpBitmap.Width := ABitmap.Height;
      nx := lpBitmap.Width;

      for y := 0 to Pred(ABitmap.Height) do
      begin
        Dec(nx);
        ny := 0;
        for x := 0 to Pred(ABitmap.Width) do
        begin
          lpBitmap.Canvas.Pixels[nx, ny] := ABitmap.Canvas.Pixels[x, y];
          Inc(ny);
        end;
      end;
      ABitmap.Assign(lpBitmap);
    end;
  finally
    lpBitmap.Free;
  end;
end;

function KeyboardChanged(Keys: TKeyboardState): Boolean;
var
  I: Byte;
begin
  Result := False;
  for I := Low(Keys) to High(Keys) do
    if GetAsyncKeyState(I) <> Keys[I] then
    begin
      Result := True;
      Break;
    end;
end;

function Popup(WinControl: TWinControl; Menu: TPopupMenu): Boolean;
const
  Flags: array [TPopupAlignment] of Word = (TPM_LEFTALIGN, TPM_RIGHTALIGN, TPM_CENTERALIGN);
var
  Point: TPoint;
begin
  if Assigned(WinControl) and Assigned(Menu) then
  begin
    GetCursorPos(Point);
    Result := TrackPopupMenu(Menu.Handle, Flags[Menu.Alignment], Point.X, Point.Y, 0, WinControl.Handle, nil);
  end else Result := False;
end;

function PopupEx(WinControl: TWinControl; Menu: TPopupMenu; X, Y: Integer): Boolean;
const
  Flags: array [TPopupAlignment] of Word = (TPM_LEFTALIGN, TPM_RIGHTALIGN, TPM_CENTERALIGN);
begin
  if Assigned(WinControl) and Assigned(Menu) then
    Result := TrackPopupMenuEx(Menu.Handle, Flags[Menu.Alignment], X, Y, WinControl.Handle, nil) else
      Result := False;
end;

function NewItemEx(const ACaption: string; AShortCut: TShortCut; ARadioItem, AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent; hCtx: Word; ABreak: TMenuBreak; const AName: string): TMenuItem;
begin
  Result := NewItem(ACaption, AShortCut, AChecked, AEnabled, AOnClick, hCtx, AName);
  Result.RadioItem := ARadioItem;
  Result.Break := ABreak;
end;

function MinVal(A, B: Integer): Integer;
begin 
  if A < B then Result := A else Result := B; 
end;

function MaxVal(A, B: Integer): Integer;
begin
  if A > B then Result := A else Result := B;
end;

function FakeStartBtnClick: Boolean;
begin
  Result := SendMessage(GetDesktopWindow, WM_SYSCOMMAND, SC_TASKLIST, 0) = 0;
end;

function BoolToStr(Value: Boolean): string;
const
  StrResults: array[Boolean] of string = ('False', 'True');
begin
  Result := StrResults[Value];
end;

function StrToBool(Value: string): Boolean;
begin
  Result := CompareText(Value, 'True') = 0;
end;

function RPos(SubStr, S: string): LongInt;

  function MirrorString(Value: string): string;
  begin
    Result := '';
    while Length(Value) <> 0 do
    begin
      Result := Result + Value[Length(Value)];
      SetLength(Value, Length(Value)-1);
    end;
  end;

begin
  SubStr := MirrorString(SubStr);
  S := MirrorString(S);
  Result := Pos(SubStr, S);
end;

function GetParentFolder(FolderName: TFileName): TFileName;
var
  Index: Integer;
begin
  Result := FolderName;

  if Result[Length(Result)] = '\' then
    SetLength(Result, Pred(Length(Result)));

  Index := RPos('\', Result);
  Result := Copy(Result, 0, Length(Result) - Pred(Index));
end;

procedure Draw3DText(DC: HDC; var R: TRect; ShadowPos: TShadowPosition; Text: PChar; Flags: Longint; ColorText, ColorShadow: TColor; ShadowSize: Integer);
var
  RShadow: TRect;
begin
  RShadow := R;

  case ShadowPos of
    spLeftTop:
      OffsetRect(R, ShadowSize, ShadowSize);
    spRightBottom:
      OffsetRect(RShadow, ShadowSize, ShadowSize);
    spLeftBottom:
      begin
        OffsetRect(R, ShadowSize, 0);
        OffsetRect(RShadow, 0, ShadowSize);
      end;
    spRightTop:
      begin
        OffsetRect(R, 0, ShadowSize);
        OffsetRect(RShadow, ShadowSize, 0);
      end;
  end;

  SetTextColor(DC, ColorToRGB(ColorShadow));
  DrawText(DC, PChar(Text), Length(Text), RShadow, Flags);

  SetBkMode(DC, Transparent);
  SetTextColor(DC, ColorToRGB(ColorText));
  DrawText(DC, PChar(Text), Length(Text), R, Flags);
end;

{$IFDEF VER90}
function TransparentStretchBlt(DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
  SrcDC: HDC; SrcX, SrcY, SrcW, SrcH: Integer; MaskDC: HDC; MaskX,
  MaskY: Integer): Boolean;
const
  ROP_DstCopy = $00AA0029;
var
  MemDC  : THandle;
  MemBmp : THandle;
  Save   : THandle;
  crText : TColorRef;
  crBack : TColorRef;
begin
  Result := True;
  if (Win32Platform = VER_PLATFORM_WIN32_NT) and (SrcW = DstW) and (SrcH = DstH) then
    begin
      MemBmp := CreateCompatibleBitmap(SrcDC, 1, 1);
      MemBmp := SelectObject(MaskDC, MemBmp);
      MaskBlt(DstDC, DstX, DstY, DstW, DstH, SrcDC, SrcX, SrcY, MemBmp, MaskX,
              MaskY, MakeRop4(ROP_DstCopy, SrcCopy));
      MemBmp := SelectObject(MaskDC, MemBmp);
      DeleteObject(MemBmp);
      exit;
    end;

  MemDC := CreateCompatibleDC(0);
  MemBmp := CreateCompatibleBitmap(SrcDC, SrcW, SrcH);
  Save := SelectObject(MemDC, MemBmp);
  StretchBlt(MemDC, 0, 0, SrcW, SrcH, MaskDC, MaskX, MaskY, SrcW, SrcH, SrcCopy);
  StretchBlt(MemDC, 0, 0, SrcW, SrcH, SrcDC, SrcX, SrcY, SrcW, SrcH, SrcErase);
  crText := SetTextColor(DstDC, $0);
  crBack := SetBkColor(DstDC, $FFFFFF);
  StretchBlt(DstDC, DstX, DstY, DstW, DstH, MaskDC, MaskX, MaskY, SrcW, SrcH, SrcAnd);
  StretchBlt(DstDC, DstX, DstY, DstW, DstH, MemDC, 0, 0, SrcW, SrcH, SrcInvert);
  SetTextColor(DstDC, crText);
  SetTextColor(DstDC, crBack);
  SelectObject(MemDC, Save);
  DeleteObject(MemBmp);
  DeleteDC(MemDC);
end;

function CopyBitmapAsMask(Handle: HBITMAP; Palette: HPALETTE;
  TransparentColor: TColorRef): HBITMAP;
var
  DIB: TDIBSection;
  ScreenDC, BitmapDC, MonoDC: HDC;
  BkColor: TColorRef;
  SaveBitmap, SaveMono: HBITMAP;
begin
  Result := 0;
  if (Handle <> 0) and (GetObject(Handle, SizeOf(DIB), @DIB) <> 0) then
  begin
    ScreenDC := 0;
    MonoDC := 0;
    try
      ScreenDC := GetDC(0);
      MonoDC := CreateCompatibleDC(ScreenDC);
      with DIB, dsBm do
      begin
        Result := CreateBitmap(bmWidth, bmHeight, 1, 1, nil);
        if Result <> 0 then
        begin
          SaveMono := SelectObject(MonoDC, Result);
          if TransparentColor = TColorRef(clNone) then
            PatBlt(MonoDC, 0, 0, bmWidth, bmHeight, Blackness)
          else
          begin
            BitmapDC := CreateCompatibleDC(ScreenDC);
            try
              SaveBitmap := SelectObject(BitmapDC, Handle);
              if Palette <> 0 then
              begin
                SelectPalette(BitmapDC, Palette, False);
                RealizePalette(BitmapDC);
                SelectPalette(MonoDC, Palette, False);
                RealizePalette(MonoDC);
              end;
              BkColor := SetBkColor(BitmapDC, TransparentColor);
              BitBlt(MonoDC, 0, 0, bmWidth, bmHeight, BitmapDC, 0, 0, SrcCopy);
              SetBkColor(BitmapDC, BkColor);
              if SaveBitmap <> 0 then SelectObject(BitmapDC, SaveBitmap);
            finally
              DeleteDC(BitmapDC);
            end;
          end;
          if SaveMono <> 0 then SelectObject(MonoDC, SaveMono);
        end;
      end;
    finally
      if MonoDC <> 0 then DeleteDC(MonoDC);
      if ScreenDC <> 0 then ReleaseDC(0, ScreenDC);
    end;
  end;
end;
{$ENDIF}

procedure TransparentStretchBltEx(DestDC, SourceDC: HDC; DestRect, SourceRect: TRect; TrColor: TColor);
var
  MonoDC: HDC;
  Width,Height: Integer;
  OldBkColor: Longint;
  MonoBitmap: HBITMAP;
  OldBitmap : HBITMAP;
begin
  with SourceRect do
  begin
    Width := Right - Left;
    Height := Bottom - Top;
    MonoDC := CreateCompatibleDC(SourceDC);
    try
      MonoBitmap := CreateCompatibleBitmap(MonoDC, Width, Height);
      try
        OldBitmap := SelectObject(MonoDC, MonoBitmap);

        OldBkColor := SetBkColor(SourceDC, ColorToRGB(TrColor));
        BitBlt(MonoDC, 0, 0, Width, Height, SourceDC, 0, 0, SRCCOPY);
        SetBkColor(SourceDC, OldBkColor);
        TransparentStretchBlt(DestDC, DestRect.Left, DestRect.Top, DestRect.Right - DestRect.Left, DestRect.Bottom - DestRect.Top,
                              SourceDC, Left, Top, Width, Height,
                              MonoDC, 0, 0);

        SelectObject(MonoDC, OldBitmap);
      finally
        DeleteObject(MonoBitmap);
      end;
    finally
      DeleteDC(MonoDC);
    end;
  end;
end;

function PredEx(Value, Amount: Integer): Integer;
begin
  Result := Value - Amount;
end;

function SuccEx(Value, Amount: Integer): Integer;
begin
  Result := Value + Amount;
end;

function DesignTime(Component: TComponent): Boolean;
begin
  Result := csDesigning in Component.ComponentState;
end;

procedure PaintPatternBackground(Canvas: TCanvas; R: TRect);
var
  X, Y: Integer;
  Pattern: TBitmap;
begin
  Pattern := TBitmap.Create;
  try
    Pattern.Width := 8;
    Pattern.Height := 8;

    for Y := 0 to 7 do
      for X := 0 to 7 do
        if (Y mod 2) = (X mod 2) then
          Pattern.Canvas.Pixels[X, Y] := clBtnHighlight else
            Pattern.Canvas.Pixels[X, Y] := clBtnFace;

    Canvas.Brush.Bitmap := Pattern;
    Canvas.FillRect(R);

  finally
    Pattern.Free;
  end;
end;

procedure OffsetPoint(var P: TPoint; X, Y: Integer);
begin
  P.X := SuccEx(P.X, X);
  P.Y := SuccEx(P.Y, Y);
end;

function TrControl(SelfControl: TWinControl; TransparencyLevel: Byte): TWinControl;
var
  Index: Byte;
begin
  Result := SelfControl;
  if TransparencyLevel > 0 then
    for Index := 0 to Pred(TransparencyLevel) do
      if Result.Parent <> nil then
        Result := Result.Parent else
          Break;
end;

function MouseInCtl(Control: TControl): Boolean;
var
  P: TPoint;
  R: TRect;
begin
  Result := Assigned(Control) and Assigned(Control.Parent);
  if Result then
    with Control do
    begin
      GetCursorPos(P);
      P := Parent.ScreenToClient(P);
      R := Rect(Left, Top, Left + Width, Top + Height);
      Result := PtInRect(R, P);
    end;
end;

// This forces the CM_MOUSELEAVE to be sent. Not the best solution
// however because the message never sent if you move the mouse outta
// control fast - it's acceptable.
procedure ForceMouseLeaveMessage(Control: TControl; CheckTimeout: Cardinal);
var
  Timer: TTimer;
  Evnt: TNotifyEvent;

  procedure TimerEvent(Data: Pointer; Sender: TObject);
  begin
    if not MouseInCtl(TControl(Data)) then
      TControl(Data).Perform(CM_MOUSELEAVE, 0, 0);

    TTimer(Sender).Enabled := False;
  end;

begin
  Timer := TTimer.Create(Application);
  try
    TMethod(Evnt).Code := @TimerEvent;
    TMethod(Evnt).Data := Control;

    Timer.OnTimer := Evnt;
    Timer.Interval := CheckTimeout;
    Timer.Enabled := True;

    while Timer.Enabled do
      Application.ProcessMessages;
  finally
    Timer.Free;
  end;
end;

function CurrentShiftState: TShiftState;
{$IFDEF DELPHI5_OR_ABOVE}
var
  KeyState: TKeyboardState;
{$ENDIF}
begin
  {$IFDEF DELPHI5_OR_ABOVE}
  GetKeyboardState(KeyState);
  Result := KeyboardStateToShiftState(KeyState);
  {$ELSE}
  Result := [];
  if GetAsyncKeyState(VK_SHIFT) <> 0 then Include(Result, ssShift);
  if GetAsyncKeyState(VK_CONTROL) <> 0 then Include(Result, ssCtrl);
  if GetAsyncKeyState(VK_MENU) <> 0 then Include(Result, ssAlt);
  if GetAsyncKeyState(VK_LBUTTON) <> 0 then Include(Result, ssLeft);
  if GetAsyncKeyState(VK_RBUTTON) <> 0 then Include(Result, ssRight);
  if GetAsyncKeyState(VK_MBUTTON) <> 0 then Include(Result, ssMiddle);
  {$ENDIF}
end;

function GetFileDirList(FDirectory, Filter: TFileName; Attr: Integer): TStringList;
var
  ARec: TSearchRec;
  Res: Integer;
  I, DirID: Integer;
  Found: Boolean;
begin
  DirID := 0;
  if FDirectory[Length(FDirectory)] <> '\' then
    FDirectory := FDirectory + '\';

  Result := TStringList.Create;
  try
    Res := FindFirst(FDirectory + Filter, Attr, ARec);
    while Res = 0 do
    begin
      if ((ARec.Attr and Attr) = ARec.Attr) and (ARec.Name <> '.') and (ARec.Name <> '..') then
      begin
        if DirectoryExists(FDirectory + ARec.Name) then
        begin
          Found := False;
          for I := 0 to DirID-1 do
            if CompareText(ARec.Name, Result[I]) < 0 then
            begin
              Result.Insert(I, ARec.Name);
              Found := True;
              break;
            end;

          if not Found then
            Result.Insert(DirID, ARec.Name);

          Inc(DirID);
        end else
        begin
          if FileExists(FDirectory + ARec.Name) then
          begin
            Found := False;
            for I := DirID to Result.Count-1 do
              if CompareText(ARec.Name, Result[I]) < 0 then
              begin
                Result.Insert(I, ARec.Name);
                Found := True;
                break;
              end;

            if not Found then
              Result.Add(ARec.Name);
          end;
        end;
      end;
      Res := FindNext(ARec);
    end;
    FindClose(ARec);
  except
    Result.Free;
  end;
end;

{TWndHook}
constructor TWndHook.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FNewProc := nil;
  FDefProc := nil;
  FWinControl := nil;
  FActive := False;

  if not Assigned(HookList) then
    HookList := THookList.Create;

  HookList.Add(Self);
end;

destructor TWndHook.Destroy;
begin
  WinControl := nil;

  if Assigned(HookList) then
  begin
    HookList.Remove(Self);
    if HookList.Count = 0 then
    begin
      HookList.Free;
      HookList := nil;
    end;
  end;

  inherited Destroy;
end;

procedure TWndHook.SetActive(Value: Boolean);
begin
  if FActive <> Value then
    if Value then HookWnd(Handle) else
       SendMessage(HookList.FHandle, CM_DESTROYHOOK, LongInt(FWinControl), Longint(Self));
end;

procedure TWndHook.SetWinControl(Value: TWinControl);
begin
  if FWinControl <> Value then
  begin
    SendMessage(HookList.FHandle, CM_DESTROYHOOK, LongInt(FWinControl), Longint(Self));
    FWinControl := Value;
    if Assigned(FOnChangeWinControl) then
      FOnChangeWinControl(Value);
  end;
end;

function TWndHook.GetHandle: THandle;
begin
  if Assigned(FWinControl) and FWinControl.HandleAllocated then
    Result := FWinControl.Handle else
      Result := INVALID_HANDLE_VALUE;
end;

procedure TWndHook.HookWnd(AHandle: THandle);
begin
  if AHandle <> INVALID_HANDLE_VALUE then
  begin
    FActive := True;

    FNewProc := MakeObjectInstance(WndProc);
    FDefProc := Pointer(SetWindowLong(AHandle, GWL_WNDPROC, LongInt(FNewProc)));
  end;
end;

procedure TWndHook.UnhookWnd(AHandle: THandle);
begin
  if AHandle <> INVALID_HANDLE_VALUE then
  begin
    FreeObjectInstance(FNewProc);
    FActive := False;
    FNewProc := nil;
    FDefProc := nil;
  end;
end;

procedure TWndHook.UnhookWndEx(AHandle: THandle);
begin
  if AHandle <> INVALID_HANDLE_VALUE then
  begin
    SetWindowLong(AHandle, GWL_WNDPROC, LongInt(FDefProc));
    UnhookWnd(AHandle);
  end;
end;

procedure TWndHook.RehookWnd;
begin
  SendMessage(HookList.FHandle, CM_DESTROYHOOK, LongInt(FWinControl), Longint(Self));
  HookWnd(Handle);
end;

procedure TWndHook.WndProc(var Msg: TMessage);
const
  Handled: Boolean = False;
begin
  if Handle <> 0 then
  try
    if Msg.Msg = WM_DESTROY then
      if Assigned(HookList) and not (csDestroying in FWinControl.ComponentState) then
        PostMessage(HookList.FHandle, CM_RECREATEWND, 0, Longint(Self));

    if Assigned(FOnBeforeMessage) then
      FOnBeforeMessage(Self, Msg, Handled);

    if not Handled then
      Msg.Result := CallWindowProc(FDefProc, Handle, Msg.Msg, Msg.WParam, Msg.LParam);

    //Everything can be freed in the previous csll so lets check.
    if Assigned(HookList) and Assigned(Self) and (HookList.IndexOf(Self) <> -1) then
      if Assigned(FOnAfterMessage) then
        FOnAfterMessage(Self, Msg, Handled);
  except
    Application.HandleException(Self);
  end;
end;

procedure TWndHook.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and Assigned(FWinControl) and (AComponent = FWinControl) then
    WinControl := nil;
end;

{THookList}
constructor THookList.Create;
begin
  inherited Create;
  FHandle := AllocateHWnd(WndProc);
end;

destructor THookList.Destroy;
begin
  DeallocateHWnd(FHandle);
  inherited Destroy;
end;

procedure THookList.WndProc(var Msg: TMessage);
var
  I,
  Index: Integer;
  Hook,
  HookPred,
  HookSucc: TWndHook;
begin
  try
    with Msg do

      case Msg of
        CM_RECREATEWND:
          begin
            Hook := TWndHook(LParam);
            if (Hook <> nil) and (IndexOf(Hook) >= 0) then
              Hook.ReHookWnd;
          end;

        CM_DESTROYHOOK:
          begin
            Hook := TWndHook(lParam);
            if Assigned(Hook) then
            begin
              Index := IndexOf(Hook);

              HookPred := nil;
              HookSucc := nil;

              if Pred(Index) >= 0 then
                for I := Pred(Index) downto 0 do
                  if TWndHook(Items[I]).WinControl = TWinControl(wParam) then
                  begin
                    HookPred := TWndHook(Items[I]);
                    Break;
                  end;

              if Succ(Index) <= Pred(Count) then
                for I := Succ(Index) to Pred(Count) do
                  if TWndHook(Items[I]).WinControl = TWinControl(wParam) then
                  begin
                    HookSucc := TWndHook(Items[I]);
                    Break;
                  end;

              if Assigned(HookPred) and Assigned(HookSucc) then
              begin
                HookSucc.FDefProc := HookPred.FNewProc;
                Hook.UnhookWnd(Hook.Handle);
              end
              else
              if not Assigned(HookPred) and Assigned(HookSucc) then
              begin
                HookSucc.FDefProc := Hook.FDefProc;
                Hook.UnhookWnd(Hook.Handle);
              end
              else
              Hook.UnhookWndEx(Hook.Handle);
            end;
          end;

        else Result := DefWindowProc(FHandle, Msg, wParam, lParam);
      end;

  except
    Application.HandleException(Self);
  end;
end;

{TGlyphList}
constructor TGlyphList.CreateSize(AWidth, AHeight: Integer);
begin
  inherited CreateSize(AWidth, AHeight);
  Used := TBits.Create;
end;

destructor TGlyphList.Destroy;
begin
  Used.Free;
  inherited Destroy;
end;
    
function TGlyphList.AllocateIndex: Integer;
begin
  Result := Used.OpenBit;
  if Result >= Used.Size then
  begin
    Result := inherited Add(nil, nil);
    Used.Size := Result + 1;
  end;
  Used[Result] := True;
end;

function TGlyphList.Add(Image, Mask: TBitmap): Integer;
begin
  Result := AllocateIndex;
  Replace(Result, Image, Mask);
  Inc(FCount);
end;

function TGlyphList.AddMasked(Image: TBitmap; MaskColor: TColor): Integer;
begin
  Result := AllocateIndex;
  ReplaceMasked(Result, Image, MaskColor);
  Inc(FCount);
end;
    
procedure TGlyphList.Delete(Index: Integer);
begin
  if Used[Index] then
  begin
    Dec(FCount);
    Used[Index] := False;
  end;
end;
    
{TGlyphCache}     
constructor TGlyphCache.Create;
begin
  inherited Create;
  GlyphLists := TList.Create;
end;
    
destructor TGlyphCache.Destroy;
begin
  GlyphLists.Free;
  inherited Destroy;
end;
    
function TGlyphCache.GetList(AWidth, AHeight: Integer): TGlyphList;
var
  I: Integer;
begin
  for I := GlyphLists.Count - 1 downto 0 do
  begin
    Result := GlyphLists[I];
    with Result do
      if (AWidth = Width) and (AHeight = Height) then Exit;
  end;
  Result := TGlyphList.CreateSize(AWidth, AHeight);
  GlyphLists.Add(Result);
end;
    
procedure TGlyphCache.ReturnList(List: TGlyphList);
begin
  if List = nil then Exit;
  if List.Count = 0 then
  begin
    GlyphLists.Remove(List);
    List.Free;
  end;
end;
    
function TGlyphCache.Empty: Boolean;
begin
  Result := GlyphLists.Count = 0;
end;

{TGlyph}
constructor TGlyph.Create;
var
  I: Boolean;
begin
  inherited Create;
  FOriginal := TBitmap.Create;
  FOriginal.OnChange := GlyphChanged;
  FTransparentColor := clOlive;
  FNumGlyphs := 1;
  FSimpleCaption := False;

  for I := Low(I) to High(I) do
    FIndexs[I] := -1;

  if GlyphCache = nil then
    GlyphCache := TGlyphCache.Create;
end;

destructor TGlyph.Destroy;
begin
  FOriginal.Free;
  Invalidate;
  if Assigned(GlyphCache) and GlyphCache.Empty then
  begin
    GlyphCache.Free;
    GlyphCache := nil;
  end;
  inherited Destroy;
end;

procedure TGlyph.Invalidate;
var
  I: Boolean;
begin
  for I := Low(I) to High(I) do
  begin
    if FIndexs[I] <> -1 then
      FGlyphList.Delete(FIndexs[I]);

    FIndexs[I] := -1;
  end;

  GlyphCache.ReturnList(FGlyphList);
  FGlyphList := nil;
end;

procedure TGlyph.GlyphChanged(Sender: TObject);
begin
  if Sender = FOriginal then
  begin
    FTransparentColor := FOriginal.TransparentColor;
    Invalidate;
    if Assigned(FOnChange) then FOnChange(Self);
  end;
end;

procedure TGlyph.SetGlyph(Value: TBitmap);
var
  Glyphs: Integer;
begin
  Invalidate;
  FOriginal.Assign(Value);
  if (Value <> nil) and (Value.Height > 0) then
  begin
    FTransparentColor := Value.TransparentColor;
    if Value.Width mod Value.Height = 0 then
    begin
      Glyphs := Value.Width div Value.Height;
      if Glyphs > 4 then Glyphs := 1;
      SetNumGlyphs(Glyphs);
    end;
  end;
end;

procedure TGlyph.SetNumGlyphs(Value: TNumGlyphs);
begin
  if (Value <> FNumGlyphs) and (Value > 0) then
  begin
    Invalidate;
    FNumGlyphs := Value;
    GlyphChanged(Glyph);
  end;
end;

function TGlyph.CreateGlyph(State: Boolean): Integer;
const
  ROP_DSPDxax = $00E20746;
var
  TmpImage, DDB, MonoBmp: TBitmap;
  IWidth, IHeight: Integer;
  IRect, ORect: TRect;
  DestDC: HDC;
  I: Boolean;
begin
  Result := FIndexs[State];
  if Result <> -1 then Exit;

  if (FOriginal.Width or FOriginal.Height) = 0 then Exit;
  IWidth := FOriginal.Width div FNumGlyphs;
  IHeight := FOriginal.Height;

  if FGlyphList = nil then
  begin
    if GlyphCache = nil then GlyphCache := TGlyphCache.Create;
    FGlyphList := GlyphCache.GetList(IWidth, IHeight);
  end;
  TmpImage := TBitmap.Create;
  try
    TmpImage.Width := IWidth;
    TmpImage.Height := IHeight;
    IRect := Rect(0, 0, IWidth, IHeight);
    TmpImage.Canvas.Brush.Color := clBtnFace;
    {$IFNDEF VER90}
    TmpImage.Palette := CopyPalette(FOriginal.Palette);
    {$ENDIF}
    I := not State;
    if Ord(I) >= NumGlyphs then I := True;
    ORect := Rect(Ord(I) * IWidth, 0, (Ord(I) + 1) * IWidth, IHeight);

    if State then
    begin
      {$IFDEF VER90}
      TmpImage.Handle := CopyBitmapAsMask(FOriginal.Handle, FOriginal.Palette, FTransparentColor);
      FIndexs[State] := FGlyphList.Add(FOriginal, TmpImage);
      {$ELSE}
      TmpImage.Canvas.CopyRect(IRect, FOriginal.Canvas, ORect);
      if FOriginal.TransparentMode = tmFixed then
        FIndexs[State] := FGlyphList.AddMasked(TmpImage, FTransparentColor) else
          FIndexs[State] := FGlyphList.AddMasked(TmpImage, clDefault);
      {$ENDIF}
    end else
    begin
      MonoBmp := nil;
      DDB := nil;
      try
        MonoBmp := TBitmap.Create;
        DDB := TBitmap.Create;
        DDB.Assign(FOriginal);
        {$IFNDEF VER90}
        DDB.HandleType := bmDDB;
        {$ENDIF}
        if NumGlyphs > 1 then
        with TmpImage.Canvas do
        begin    { Change white & gray to clBtnHighlight and clBtnShadow }
          CopyRect(IRect, DDB.Canvas, ORect);
          MonoBmp.Monochrome := True;
          MonoBmp.Width := IWidth;
          MonoBmp.Height := IHeight;

          { Convert white to clBtnHighlight }
          DDB.Canvas.Brush.Color := clWhite;
          MonoBmp.Canvas.CopyRect(IRect, DDB.Canvas, ORect);
          Brush.Color := clBtnHighlight;
          DestDC := Handle;
          SetTextColor(DestDC, clBlack);
          SetBkColor(DestDC, clWhite);
          BitBlt(DestDC, 0, 0, IWidth, IHeight,
                 MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);

          { Convert gray to clBtnShadow }
          DDB.Canvas.Brush.Color := clGray;
          MonoBmp.Canvas.CopyRect(IRect, DDB.Canvas, ORect);
          Brush.Color := clBtnShadow;
          DestDC := Handle;
          SetTextColor(DestDC, clBlack);
          SetBkColor(DestDC, clWhite);
          BitBlt(DestDC, 0, 0, IWidth, IHeight,
                 MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);

          { Convert transparent color to clBtnFace }
          DDB.Canvas.Brush.Color := ColorToRGB(FTransparentColor);
          MonoBmp.Canvas.CopyRect(IRect, DDB.Canvas, ORect);
          Brush.Color := clBtnFace;
          DestDC := Handle;
          SetTextColor(DestDC, clBlack);
          SetBkColor(DestDC, clWhite);
          BitBlt(DestDC, 0, 0, IWidth, IHeight,
                 MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
        end
        else
        begin
          { Create a disabled version }
          with MonoBmp do
          begin
            Assign(FOriginal);
            {$IFNDEF VER90}
            HandleType := bmDDB;
            {$ENDIF}
            Canvas.Brush.Color := clBlack;
            Width := IWidth;
            if Monochrome then
            begin
              Canvas.Font.Color := clWhite;
              Monochrome := False;
              Canvas.Brush.Color := clWhite;
            end;
            Monochrome := True;
          end;
          with TmpImage.Canvas do
          begin
            Brush.Color := clBtnFace;
            FillRect(IRect);
            Brush.Color := clBtnHighlight;
            SetTextColor(Handle, clBlack);
            SetBkColor(Handle, clWhite);
            BitBlt(Handle, 1, 1, IWidth, IHeight,
              MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
            Brush.Color := clBtnShadow;
            SetTextColor(Handle, clBlack);
            SetBkColor(Handle, clWhite);
            BitBlt(Handle, 0, 0, IWidth, IHeight,
              MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
          end;
        end;
      finally
        DDB.Free;
        MonoBmp.Free;
      end;
      {$IFNDEF VER90}
      FIndexs[State] := FGlyphList.AddMasked(TmpImage, clDefault);
      {$ELSE}
      FIndexs[State] := FGlyphList.Add(TmpImage, nil);
      {$ENDIF}
    end;
  finally
    TmpImage.Free;
  end;
  Result := FIndexs[State];
  FOriginal.Dormant;
end;

procedure TGlyph.DrawCaption(Canvas: TCanvas; const Caption: string;
  TextBounds: TRect; State: Boolean; SimpleView: Boolean; ShadowPos: TShadowPosition;
  ShadowColor: TColor; ShadowSize: Integer; BiDiFlags: LongInt);
begin
  with Canvas do
  begin
    Brush.Style := bsClear;
    if not State then
      Draw3DText(Handle, TextBounds, spRightBottom, PChar(Caption), DT_CENTER or DT_VCENTER or BiDiFlags, clBtnShadow, clBtnHighlight, 1) else
        if SimpleView then
          DrawText(Handle, PChar(Caption),  Length(Caption), TextBounds, DT_CENTER or DT_VCENTER or BiDiFlags) else
            Draw3DText(Handle, TextBounds, ShadowPos, PChar(Caption), DT_CENTER or DT_VCENTER  or BiDiFlags, Font.Color, ShadowColor, ShadowSize);
  end;
end;

procedure TGlyph.CalcButtonLayout(Canvas: TCanvas; const Client: TRect;
  const Offset: TPoint; const Caption: string; Layout: TButtonLayout; Margin,
  Spacing: Integer; var GlyphPos: TPoint; var TextBounds: TRect;
  BiDiFlags: LongInt);
var
  TextPos: TPoint;
  ClientSize, GlyphSize, TextSize: TPoint;
  TotalSize: TPoint;
begin
  if (BiDiFlags and DT_RIGHT) = DT_RIGHT then
    if Layout = blGlyphLeft then Layout := blGlyphRight
    else
      if Layout = blGlyphRight then Layout := blGlyphLeft;
  { calculate the item sizes }
  ClientSize := Point(Client.Right - Client.Left, Client.Bottom -
    Client.Top);

  if FOriginal <> nil then
    GlyphSize := Point(FOriginal.Width div FNumGlyphs, FOriginal.Height) else
    GlyphSize := Point(0, 0);

  if Length(Caption) > 0 then
  begin
    if FSimpleCaption then
      TextBounds := Rect(0, 0, Canvas.TextWidth(Caption), Canvas.TextHeight(Caption)) else
        begin
          TextBounds := Rect(0, 0, Client.Right - Client.Left, 0);
          DrawText(Canvas.Handle, PChar(Caption), Length(Caption), TextBounds,
            DT_CALCRECT or BiDiFlags);
        end;

    TextSize := Point(TextBounds.Right - TextBounds.Left, TextBounds.Bottom -
      TextBounds.Top);
  end
  else
  begin
    TextBounds := Rect(0, 0, 0, 0);
    TextSize := Point(0,0);
  end;

  { If the layout has the glyph on the right or the left, then both the
    text and the glyph are centered vertically.  If the glyph is on the top
    or the bottom, then both the text and the glyph are centered horizontally.}
  if Layout in [blGlyphLeft, blGlyphRight] then
  begin
    GlyphPos.Y := (ClientSize.Y - GlyphSize.Y + 1) div 2;
    TextPos.Y := (ClientSize.Y - TextSize.Y + 1) div 2;
  end
  else
  begin
    GlyphPos.X := (ClientSize.X - GlyphSize.X + 1) div 2;
    TextPos.X := (ClientSize.X - TextSize.X + 1) div 2;
  end;

  { if there is no text or no bitmap, then Spacing is irrelevant }
  if (TextSize.X = 0) or (GlyphSize.X = 0) then
    Spacing := 0;

  { adjust Margin and Spacing }
  if Margin = -1 then
  begin
    if Spacing = -1 then
    begin
      TotalSize := Point(GlyphSize.X + TextSize.X, GlyphSize.Y + TextSize.Y);
      if Layout in [blGlyphLeft, blGlyphRight] then
        Margin := (ClientSize.X - TotalSize.X) div 3
      else
        Margin := (ClientSize.Y - TotalSize.Y) div 3;
      Spacing := Margin;
    end
    else
    begin
      TotalSize := Point(GlyphSize.X + Spacing + TextSize.X, GlyphSize.Y +
        Spacing + TextSize.Y);
      if Layout in [blGlyphLeft, blGlyphRight] then
        Margin := (ClientSize.X - TotalSize.X + 1) div 2
      else
        Margin := (ClientSize.Y - TotalSize.Y + 1) div 2;
    end;
  end
  else
  begin
    if Spacing = -1 then
    begin
      TotalSize := Point(ClientSize.X - (Margin + GlyphSize.X), ClientSize.Y -
        (Margin + GlyphSize.Y));
      if Layout in [blGlyphLeft, blGlyphRight] then
        Spacing := (TotalSize.X - TextSize.X) div 2
      else
        Spacing := (TotalSize.Y - TextSize.Y) div 2;
    end;
  end;

  case Layout of
    blGlyphLeft:
      begin
        GlyphPos.X := Margin;
        TextPos.X := GlyphPos.X + GlyphSize.X + Spacing;
      end;
    blGlyphRight:
      begin
        GlyphPos.X := ClientSize.X - Margin - GlyphSize.X;
        TextPos.X := GlyphPos.X - Spacing - TextSize.X;
      end;
    blGlyphTop:
      begin
        GlyphPos.Y := Margin;
        TextPos.Y := GlyphPos.Y + GlyphSize.Y + Spacing;
      end;
    blGlyphBottom:
      begin
        GlyphPos.Y := ClientSize.Y - Margin - GlyphSize.Y;
        TextPos.Y := GlyphPos.Y - Spacing - TextSize.Y;
      end;
  end;
    
  { fixup the result variables }
  with GlyphPos do
  begin
    Inc(X, Client.Left + Offset.X);
    Inc(Y, Client.Top + Offset.Y);
  end;
  OffsetRect(TextBounds, TextPos.X + Client.Left + Offset.X,
    TextPos.Y + Client.Top + Offset.X);
end;

procedure TGlyph.DrawImage(Canvas: TCanvas; const GlyphPos: TPoint;
  State: Boolean; Transparent: Boolean; BkColor: TColor);
const
  Selecteds: array[Boolean] of Integer = (ILD_SELECTED, 0);
var
  Index: Integer;
begin
  if (FOriginal <> nil) and (FOriginal.Width <> 0) and (FOriginal.Height <> 0) then
  begin
    Index := CreateGlyph(State);
    with GlyphPos do
      if Transparent then
        ImageList_DrawEx(FGlyphList.Handle, Index, Canvas.Handle, X, Y, 0, 0,
          CLR_NONE, CLR_NONE, ILD_Transparent or Selecteds[BkColor = clNone]) else

        ImageList_DrawEx(FGlyphList.Handle, Index, Canvas.Handle, X, Y, 0, 0,
          ColorToRGB(BkColor), clNone, ILD_Normal);
  end;
end;

procedure TGlyph.DrawImageEx(Canvas: TCanvas; const Client: TRect; const Offset: TPoint; const Caption: string; Layout: TButtonLayout; Margin, Spacing: Integer; State: Boolean; Transparent: Boolean; BkColor: TColor; BiDiFlags: Longint);
var
  Bounds: TRect;
  GlyphPos: TPoint;
begin
  CalcButtonLayout(Canvas, Client, Offset, Caption, Layout, Margin, Spacing,
    GlyphPos, Bounds, BiDiFlags);
  DrawImage(Canvas, GlyphPos, State, Transparent, BkColor);
end;

procedure TGlyph.DrawBevels(Canvas: TCanvas; const Client: TRect; const Offset: TPoint; const Caption: string; Layout: TButtonLayout;
  Margin, Spacing: Integer; BevelInner, BevelOuter: TPanelBevel; BevelStyle: TBevelStyleEx; BiDiFlags: Longint);
const
{$IFNDEF DELPHI4_OR_ABOVE}
  FInnerEdges: array[TPanelBevel] of Integer = (0, BDR_SUNKENINNER, BDR_RAISEDINNER {$IFDEF VER125}, 0{$ENDIF});
  FOuterEdges: array[TPanelBevel] of Integer = (0, BDR_SUNKENOUTER, BDR_RAISEDOUTER {$IFDEF VER125}, 0{$ENDIF});
{$ELSE}
  FInnerEdges: array[TPanelBevel] of Integer = (0, BDR_SUNKENINNER, BDR_RAISEDINNER, 0);
  FOuterEdges: array[TPanelBevel] of Integer = (0, BDR_SUNKENOUTER, BDR_RAISEDOUTER, 0);
{$ENDIF}
var
  R: TRect;
  GlyphPos: TPoint;
begin
  if (BevelInner <> bvNone) or (BevelOuter <> bvNone) then
    case BevelStyle of
      bsBevelBoth:
        begin
          R := Client;
          DrawEdge(Canvas.Handle, R, FInnerEdges[BevelInner] or FOuterEdges[BevelOuter], BF_RECT);
        end;
      bsBevelOnlyImage:
        begin
          CalcButtonLayout(Canvas, Client, Offset, Caption, Layout, Margin, Spacing,
            GlyphPos, R, BiDiFlags);

          R := Rect(GlyphPos.X, GlyphPos.Y, GlyphPos.X + Glyph.Width div NumGlyphs, GlyphPos.Y + Glyph.Height);
          InflateRect(R, Margin div 2, Spacing div 2);
          DrawEdge(Canvas.Handle, R, FInnerEdges[BevelInner] or FOuterEdges[BevelOuter], BF_RECT);
        end;
      bsBevelOnlyText:
        begin
          CalcButtonLayout(Canvas, Client, Offset, Caption, Layout, Margin, Spacing,
            GlyphPos, R, BiDiFlags);

          InflateRect(R, Margin div 2, Spacing div 2);
          DrawEdge(Canvas.Handle, R, FInnerEdges[BevelInner] or FOuterEdges[BevelOuter], BF_RECT);
        end;
    end;
end;

function TGlyph.Draw(Canvas: TCanvas; const Client: TRect; const Offset: TPoint;
  const Caption: string; Layout: TButtonLayout; Margin, Spacing: Integer;
  State: Boolean; Transparent: Boolean; BkColor: TColor; SimpleView: Boolean;
  ShadowPos: TShadowPosition; ShadowColor: TColor; ShadowSize: Integer; BiDiFlags: Longint): TRect;
var
  GlyphPos: TPoint;
  Rgn: Hrgn;
begin
  Rgn := CreateRectRgnIndirect(Client);
  try
    SelectClipRgn(Canvas.Handle, Rgn);
    try
      CalcButtonLayout(Canvas, Client, Offset, Caption, Layout, Margin, Spacing,
        GlyphPos, Result, BiDiFlags);
      DrawImage(Canvas, GlyphPos, State, Transparent, BkColor);
      DrawCaption(Canvas, Caption, Result, State, SimpleView, ShadowPos, ShadowColor, ShadowSize, BiDiFlags);
    finally
      SelectClipRgn(Canvas.Handle, 0);
    end;
  finally
    DeleteObject(Rgn);
  end;
end;

function TGlyph.DrawFast(Canvas: TCanvas; const Client: TRect; const Offset: TPoint;
  const Caption: string; Layout: TButtonLayout; Margin, Spacing: Integer;
  State: Boolean; Transparent: Boolean; BkColor: TColor; SimpleView: Boolean;
  ShadowPos: TShadowPosition; ShadowColor: TColor; ShadowSize: Integer; BiDiFlags: Longint): TRect;
var
  GlyphPos: TPoint;
begin
  CalcButtonLayout(Canvas, Client, Offset, Caption, Layout, Margin, Spacing,
    GlyphPos, Result, BiDiFlags);
  DrawImage(Canvas, GlyphPos, State, Transparent, BkColor);
  DrawCaption(Canvas, Caption, Result, State, SimpleView, ShadowPos, ShadowColor, ShadowSize, BiDiFlags);
end;

end.
