unit TB2Common;

{$MODE Delphi}

{
  Toolbar2000
  Copyright (C) 1998-2008 by Jordan Russell
  All rights reserved.

  The contents of this file are subject to the "Toolbar2000 License"; you may
  not use or distribute this file except in compliance with the
  "Toolbar2000 License". A copy of the "Toolbar2000 License" may be found in
  TB2k-LICENSE.txt or at:
    http://www.jrsoftware.org/files/tb2k/TB2k-LICENSE.txt

  Alternatively, the contents of this file may be used under the terms of the
  GNU General Public License (the "GPL"), in which case the provisions of the
  GPL are applicable instead of those in the "Toolbar2000 License". A copy of
  the GPL may be found in GPL-LICENSE.txt or at:
    http://www.jrsoftware.org/files/tb2k/GPL-LICENSE.txt
  If you wish to allow use of your version of this file only under the terms of
  the GPL and not to allow others to use your version of this file under the
  "Toolbar2000 License", indicate your decision by deleting the provisions
  above and replace them with the notice and other provisions required by the
  GPL. If you do not delete the provisions above, a recipient may use your
  version of this file under either the "Toolbar2000 License" or the GPL.

  $jrsoftware: tb2k/Source/TB2Common.pas,v 1.48 2008/09/17 19:46:30 jr Exp $
}

interface

{$I TB2Ver.inc}

uses
  LCLIntf, LCLType, LMessages, Classes, SysUtils, Messages, Controls, Forms;

type
  THandleWMPrintNCPaintProc = procedure(Wnd: HWND; DC: HDC; AppData: TObject);
  TPaintHandlerProc = procedure(var Message: TWMPaint) of object;

  { The type of item a TList holds; it differs between Win32 and .NET VCL }
  TListItemType = {$IFNDEF CLR} Pointer {$ELSE} TObject {$ENDIF};

  {$IFNDEF CLR}
  ClipToLongint = Longint;
  {$ENDIF}

function AddToFrontOfList(var List: TList; Item: TObject): Boolean;
function AddToList(var List: TList; Item: TObject): Boolean;
function ApplicationIsActive: Boolean;
function AreFlatMenusEnabled: Boolean;
function AreKeyboardCuesEnabled: Boolean;
procedure CallLockSetForegroundWindow(const ALock: Boolean);
function CallTrackMouseEvent(const Wnd: HWND; const Flags: DWORD): Boolean;
function CharToLower(const C: Char): Char;
{$IFDEF CLR}
function ClipToLongint(const I: Int64): Longint; inline;
{$ENDIF}
function CreateHalftoneBrush: HBRUSH;
function CreateMonoBitmap(const AWidth, AHeight: Integer;
  const ABits: array of Byte): HBITMAP;
function CreateRotatedFont(DC: HDC): HFONT;
procedure DoubleBufferedRepaint(const Wnd: HWND);
procedure DrawHalftoneInvertRect(const DC: HDC; const NewRect, OldRect: TRect;
  const NewSize, OldSize: TSize);
procedure DrawRotatedText(const DC: HDC; AText: String; const ARect: TRect;
  const AFormat: Cardinal);
procedure DrawSmallWindowCaption(const Wnd: HWND; const DC: HDC;
  const ARect: TRect; const AText: String; const AActive: Boolean);
function DrawTextStr(const DC: HDC; const AText: String; var ARect: TRect;
  const AFormat: UINT): Integer;
function EscapeAmpersands(const S: String): String;
procedure FillRectWithGradient(const DC: HDC; const R: TRect;
  const StartColor, EndColor: TColorRef; const HorizontalDirection: Boolean);
function FindAccelChar(const S: String): Char;
{$IFNDEF JR_D5}
procedure FreeAndNil(var Obj);
{$ENDIF}
function GetInputLocaleCodePage: UINT;
function GetMenuShowDelay: Integer;
function GetMessagePosAsPoint: TPoint;
function GetRectOfMonitorContainingPoint(const P: TPoint; const WorkArea: Boolean): TRect;
function GetRectOfMonitorContainingRect(const R: TRect; const WorkArea: Boolean): TRect;
function GetRectOfMonitorContainingWindow(const W: HWND; const WorkArea: Boolean): TRect;
function GetRectOfPrimaryMonitor(const WorkArea: Boolean): TRect;
function GetSystemNonClientMetrics(var Metrics: TNonClientMetrics): Boolean;
function GetSystemParametersInfoBool(const Param: UINT; const Default: BOOL): BOOL;
function GetTextExtentPoint32Str(const DC: HDC; const AText: String;
  out ASize: TSize): BOOL;
function GetTextHeight(const DC: HDC): Integer;
function GetTextWidth(const DC: HDC; S: String; const Prefix: Boolean): Integer;
procedure HandleWMPrint(const Wnd: HWND; var Message: TMessage;
  const NCPaintFunc: THandleWMPrintNCPaintProc; const AppData: TObject);
procedure HandleWMPrintClient(const PaintHandlerProc: TPaintHandlerProc;
  const Message: {$IFNDEF CLR} TMessage {$ELSE} TWMPrintClient {$ENDIF});
function IsWindowsXP: Boolean;
procedure InitTrackMouseEvent;
{$IFNDEF JR_D6}
function InvalidPoint(const At: TPoint): Boolean;
{$ENDIF}
function IsFillRectWithGradientAvailable: Boolean;
function Max(A, B: Integer): Integer;
function Min(A, B: Integer): Integer;
{$IFNDEF CLR}
function MethodsEqual(const M1, M2: TMethod): Boolean;
{$ENDIF}
function NeedToPlaySound(const Alias: String): Boolean;
procedure PlaySystemSound(const Alias: String);
procedure ProcessPaintMessages;
{$IFNDEF JR_D6}
procedure RaiseLastOSError;
{$ENDIF}
procedure RemoveMessages(const AMin, AMax: Integer);
procedure RemoveFromList(var List: TList; Item: TObject);
procedure SelectNCUpdateRgn(Wnd: HWND; DC: HDC; Rgn: HRGN);
function StripAccelChars(const S: String): String;
function StripTrailingPunctuation(const S: String): String;
function TextOutStr(const DC: HDC; const X, Y: Integer;
  const AText: String): BOOL;
function UsingMultipleMonitors: Boolean;

const
  PopupMenuWindowNCSize = 3;
  DT_HIDEPREFIX = $00100000;

implementation

uses
  {$IFDEF CLR} Types, System.Security, System.Runtime.InteropServices,
    System.Text, MultiMon, {$ENDIF}
  MMSYSTEM, TB2Version;

function ApplicationIsActive: Boolean;
{ Returns True if the application is in the foreground }
begin
  Result := GetActiveWindow <> 0;
end;

type
  {$IFNDEF CLR}
  PPrintEnumProcData = ^TPrintEnumProcData;
  TPrintEnumProcData = record
  {$ELSE}
  TPrintEnumProcData = class
  private
  {$ENDIF}
    PrintChildren: Boolean;
    ParentWnd: HWND;
    DC: HDC;
    PrintFlags: LPARAM;
    {$IFDEF CLR}
    function PrintEnumProc(Wnd: HWND; LParam: LPARAM): BOOL;
    {$ENDIF}
  end;

{$IFNDEF CLR}
function PrintEnumProc(Wnd: HWND; LParam: LPARAM): BOOL; stdcall;
{$ELSE}
function TPrintEnumProcData.PrintEnumProc(Wnd: HWND; LParam: LPARAM): BOOL;
{$ENDIF}
var
  R: TRect;
  SaveIndex: Integer;
begin
  Result := True;  { continue enumerating }
  {$IFNDEF CLR}
  with PPrintEnumProcData(LParam)^ do
  {$ENDIF}
  begin
    { Skip window if it isn't a child/owned window of ParentWnd or isn't visible }
    if (HWND(GetWindowLong(Wnd, GWL_HWNDPARENT)) <> ParentWnd) or
       (GetWindowLong(Wnd, GWL_STYLE) and WS_VISIBLE = 0) then
         { ^ don't use IsWindowVisible since it returns False if the window's
           parent window is not visible }
      Exit;
    GetWindowRect(Wnd, R);
    MapWindowPoints(0, ParentWnd, R, 2);
    SaveIndex := SaveDC(DC);
    { Like Windows, offset the window origin to the top-left coordinates of
      the child/owned window }
    MoveWindowOrg(DC, R.Left, R.Top);
    { Like Windows, intersect the clipping region with the entire rectangle of
      the child/owned window }
    OffsetRect(R, -R.Left, -R.Top);
    IntersectClipRect(DC, R.Left, R.Top, R.Right, R.Bottom);
    { Send a WM_PRINT message to the child/owned window }
    SendMessage(Wnd, WM_PRINT, WPARAM(DC), PrintFlags);
    { Restore the DC's state, in case the WM_PRINT handler didn't put things
      back the way it found them }
    RestoreDC(DC, SaveIndex);
  end;
end;

procedure HandleWMPrint(const Wnd: HWND; var Message: TMessage;
  const NCPaintFunc: THandleWMPrintNCPaintProc; const AppData: TObject);
{ note: AppData is an application-defined value which is passed to NCPaintFunc }
var
  DC: HDC;
  SaveIndex, SaveIndex2: Integer;
  R: TRect;
  P: TPoint;
  Data: TPrintEnumProcData;
begin
  if (Message.LParam and PRF_CHECKVISIBLE = 0) or IsWindowVisible(Wnd) then begin
    DC := HDC(Message.WParam);
    SaveIndex2 := SaveDC(DC);
    try
      if Message.LParam and PRF_NONCLIENT <> 0 then begin
        SaveIndex := SaveDC(DC);
        if Assigned(NCPaintFunc) then
          NCPaintFunc(Wnd, DC, AppData);
        RestoreDC(DC, SaveIndex);
      end;
      { Calculate the difference between the top-left corner of the window
        and the top-left corner of its client area }
      GetWindowRect(Wnd, R);
      P.X := 0;  P.Y := 0;
      ClientToScreen(Wnd, P);
      Dec(P.X, R.Left);  Dec(P.Y, R.Top);
      if Message.LParam and PRF_CLIENT <> 0 then begin
        { Like Windows, the flags PRF_ERASEBKGND, PRF_CHILDREN, and PRF_OWNED
          are ignored if PRF_CLIENT isn't also specified }
        if Message.LParam and PRF_ERASEBKGND <> 0 then begin
          { Send WM_ERASEBKGND }
          SaveIndex := SaveDC(DC);
          if Message.LParam and PRF_NONCLIENT <> 0 then
            MoveWindowOrg(DC, P.X, P.Y);
          SendMessage(Wnd, WM_ERASEBKGND, Message.WParam, 0);
          RestoreDC(DC, SaveIndex);
        end;
        { Send WM_PRINTCLIENT }
        SaveIndex := SaveDC(DC);
        if Message.LParam and PRF_NONCLIENT <> 0 then
          MoveWindowOrg(DC, P.X, P.Y);
        SendMessage(Wnd, WM_PRINTCLIENT, Message.WParam, 0);
        RestoreDC(DC, SaveIndex);
        { Like Windows, always offset child/owned windows by the size of the
          client area even if PRF_NONCLIENT isn't specified (a bug?) }
        MoveWindowOrg(DC, P.X, P.Y);
        {$IFDEF CLR}
        Data := TPrintEnumProcData.Create;
        {$ENDIF}
        Data.ParentWnd := Wnd;
        Data.DC := DC;
        { Send WM_PRINT to child/owned windows }
        if Message.LParam and PRF_CHILDREN <> 0 then begin
          Data.PrintChildren := True;
          Data.PrintFlags := (Message.LParam or (PRF_NONCLIENT or PRF_CLIENT or
            PRF_ERASEBKGND or PRF_CHILDREN)) and not PRF_CHECKVISIBLE;
          {$IFNDEF CLR}
          EnumChildWindows(Wnd, @PrintEnumProc, LPARAM(@Data));
          {$ELSE}
          EnumChildWindows(Wnd, Data.PrintEnumProc, 0);
          {$ENDIF}
        end;
        if Message.LParam and PRF_OWNED <> 0 then begin
          Data.PrintChildren := False;
          Data.PrintFlags := Message.LParam;
          {$IFNDEF CLR}
          EnumWindows(@PrintEnumProc, LPARAM(@Data));
          {$ELSE}
          EnumWindows(Data.PrintEnumProc, 0);
          {$ENDIF}
        end;
      end;
    finally
      RestoreDC(DC, SaveIndex2);
    end;
    Message.Result := 1;
  end
  else begin
    { Like Windows, return 0 when the PRF_CHECKVISIBLE flag is specified and
      the window is not visible }
    Message.Result := 0;
  end;
end;

procedure HandleWMPrintClient(const PaintHandlerProc: TPaintHandlerProc;
  const Message: {$IFNDEF CLR} TMessage {$ELSE} TWMPrintClient {$ENDIF});
var
  DC: HDC;
  Msg: TWMPaint;
  SaveIndex: Integer;
begin
  {$IFNDEF CLR}
  DC := HDC(Message.WParam);
  {$ELSE}
  DC := Message.DC;
  Msg := TWMPaint.Create;
  {$ENDIF}
  Msg.Msg := WM_PAINT;
  Msg.DC := DC;
  {$IFNDEF CLR}
  Msg.Unused := 0;
  {$ENDIF}
  Msg.Result := 0;
  SaveIndex := SaveDC(DC);
  try
    PaintHandlerProc(Msg);
  finally
    RestoreDC(DC, SaveIndex);
  end;
end;

function GetTextHeight(const DC: HDC): Integer;
var
  TextMetric: TTextMetric;
begin
  GetTextMetrics(DC, TextMetric);
  Result := TextMetric.tmHeight;
end;

function StripAccelChars(const S: String): String;
var
  I: Integer;
begin
  Result := S;
  I := 1;
  while I <= Length(Result) do begin
    {$IFNDEF JR_WIDESTR}
    if not(Result[I] in LeadBytes) then begin
    {$ENDIF}
      if Result[I] = '&' then
        Delete(Result, I, 1);
      Inc(I);
    {$IFNDEF JR_WIDESTR}
    end
    else
      Inc(I, 2);
    {$ENDIF}
  end;
end;

function EscapeAmpersands(const S: String): String;
{ Replaces any '&' characters with '&&' }
var
  I: Integer;
begin
  Result := S;
  I := 1;
  while I <= Length(Result) do begin
    {$IFNDEF JR_WIDESTR}
    if not(Result[I] in LeadBytes) then begin
    {$ENDIF}
      if Result[I] = '&' then begin
        Inc(I);
        Insert('&', Result, I);
      end;
      Inc(I);
    {$IFNDEF JR_WIDESTR}
    end
    else
      Inc(I, 2);
    {$ENDIF}
  end;
end;

function StripTrailingPunctuation(const S: String): String;
{ Removes any colon (':') or ellipsis ('...') from the end of S and returns
  the resulting string }
var
  L: Integer;
begin
  Result := S;
  L := Length(Result);
  if (L > 1) and (Result[L] = ':') {$IFNDEF JR_WIDESTR} and (ByteType(Result, L) = mbSingleByte) {$ENDIF} then
    SetLength(Result, L-1)
  else if (L > 3) and (Result[L-2] = '.') and (Result[L-1] = '.') and
     (Result[L] = '.') {$IFNDEF JR_WIDESTR} and (ByteType(Result, L-2) = mbSingleByte) {$ENDIF} then
    SetLength(Result, L-3);
end;

function GetTextWidth(const DC: HDC; S: String; const Prefix: Boolean): Integer;
{ Returns the width of the specified string using the font currently selected
  into DC. If Prefix is True, it first removes "&" characters as necessary. }
var
  Size: TSize;
begin
  { This procedure is 10x faster than using DrawText with the DT_CALCRECT flag }
  if Prefix then
    S := StripAccelChars(S);
  GetTextExtentPoint32Str(DC, S, Size);
  Result := Size.cx;
end;

procedure ProcessPaintMessages;
{ Dispatches all pending WM_PAINT messages. In effect, this is like an
  'UpdateWindow' on all visible windows }
var
  Msg: TMsg;
begin
  while PeekMessage(Msg, 0, WM_PAINT, WM_PAINT, PM_NOREMOVE) do begin
    case Integer(GetMessage(Msg, 0, WM_PAINT, WM_PAINT)) of
      -1: Break; { if GetMessage failed }
      0: begin
           { Repost WM_QUIT messages }
           PostQuitMessage(ClipToLongint(Msg.wParam));
           Break;
         end;
    end;
    DispatchMessage(Msg);
  end;
end;

procedure RemoveMessages(const AMin, AMax: Integer);
{ Removes any messages with the specified ID from the queue }
var
  Msg: TMsg;
begin
  while PeekMessage(Msg, 0, AMin, AMax, PM_REMOVE) do begin
    if Msg.message = WM_QUIT then begin
      { Repost WM_QUIT messages }
      PostQuitMessage(ClipToLongint(Msg.wParam));
      Break;
    end;
  end;
end;

procedure SelectNCUpdateRgn(Wnd: HWND; DC: HDC; Rgn: HRGN);
var
  R: TRect;
  NewClipRgn: HRGN;
begin
  if (Rgn <> 0) and (Rgn <> 1) then begin
    GetWindowRect(Wnd, R);
    if SelectClipRgn(DC, Rgn) = ERROR then begin
      NewClipRgn := CreateRectRgnIndirect(R);
      SelectClipRgn(DC, NewClipRgn);
      DeleteObject(NewClipRgn);
    end;
    OffsetClipRgn(DC, -R.Left, -R.Top);
  end;
end;

function AddToList(var List: TList; Item: TObject): Boolean;
{ Returns True if Item didn't already exist in the list }
begin
  if List = nil then
    List := TList.Create;
  Result := List.IndexOf(Item) = -1;
  if Result then
    List.Add(Item);
end;

function AddToFrontOfList(var List: TList; Item: TObject): Boolean;
{ Returns True if Item didn't already exist in the list }
begin
  if List = nil then
    List := TList.Create;
  Result := List.IndexOf(Item) = -1;
  if Result then
    List.Insert(0, Item);
end;

procedure RemoveFromList(var List: TList; Item: TObject);
begin
  if Assigned(List) then begin
    List.Remove(Item);
    if List.Count = 0 then begin
      List.Free;
      List := nil;
    end;
  end;
end;

const
  DefaultMenuShowDelay = 400;
{$IFNDEF CLR}
var
  RegMenuShowDelay: Integer;
  RegMenuShowDelayInited: BOOL = False;
function GetMenuShowDelay: Integer;
  function ReadMenuShowDelayFromRegistry: Integer;
  var
    K: HKEY;
    Typ, DataSize: DWORD;
    Data: array[0..31] of Char;
    Res: Longint;
    E: Integer;
  begin
    Result := DefaultMenuShowDelay;
    if RegOpenKeyEx(HKEY_CURRENT_USER, 'Control Panel\Desktop', 0,
       KEY_QUERY_VALUE, K) = ERROR_SUCCESS then begin
      DataSize := SizeOf(Data);
      Res := RegQueryValueEx(K, 'MenuShowDelay', nil, @Typ, @Data, @DataSize);
      RegCloseKey(K);
      if Res <> ERROR_FILE_NOT_FOUND then begin
        if (Res <> ERROR_SUCCESS) or (Typ <> REG_SZ) then
          Result := 0
        else begin
          Val(Data, Result, E);
          if E <> 0 then Result := 0;
        end;
      end;
    end;
  end;
begin
  if Lo(GetVersion) >= 4 then begin
    if not SystemParametersInfo(106{SPI_GETMENUSHOWDELAY}, 0, @Result, 0) then begin
      { SPI_GETMENUSHOWDELAY is only supported by Windows NT 4.0 and Windows 98.
        On Windows 95, it must use the registry to retrieve this setting. }
      if not RegMenuShowDelayInited then begin
        RegMenuShowDelay := ReadMenuShowDelayFromRegistry;
        InterlockedExchange(Integer(RegMenuShowDelayInited), Ord(True));
      end;
      Result := RegMenuShowDelay;
    end;
    if Result < 0 then Result := 0;
  end
  else
    Result := DefaultMenuShowDelay;
end;
{$ELSE}
function GetMenuShowDelay: Integer;
begin
  { Since .NET requires Windows 98 or later, we can assume that
    SPI_GETMENUSHOWDELAY is available }
  if not SystemParametersInfo(SPI_GETMENUSHOWDELAY, 0, Result, 0) then
    Result := DefaultMenuShowDelay;
end;
{$ENDIF}

function AreFlatMenusEnabled: Boolean;
{ Returns True if "flat menus" are enabled. Always returns False on pre-XP
  Windows versions. }
const
  SPI_GETFLATMENU = $1022;
begin
  { Interestingly, on Windows 2000, SystemParametersInfo(SPI_GETFLATMENU, ...)
    succeeds and can return True in pvParam^ if the proper bit is set in
    UserPreferencesMask. Since flat menus are not really used on Windows
    2000, call IsWindowsXP first to see if we're running at least XP. }
  Result := IsWindowsXP and GetSystemParametersInfoBool(SPI_GETFLATMENU, False);
end;

function AreKeyboardCuesEnabled: Boolean;
{ Returns True if "keyboard cues" are enabled. Always returns True on
  pre-2000 Windows versions. }
const
  SPI_GETKEYBOARDCUES = $100A;
begin
  Result := (Win32MajorVersion < 5) or
    GetSystemParametersInfoBool(SPI_GETKEYBOARDCUES, True);
end;

function CreateFrameRectRgn(const ARect: TRect; const ASize: TSize): HRGN;
var
  R: TRect;
  InsideRgn: HRGN;
begin
  if IsRectEmpty(ARect) then begin
    { The rectangle is empty, so simply return a normalized empty region }
    SetRectEmpty(R);
    Result := CreateRectRgnIndirect(R);
  end
  else begin
    Result := CreateRectRgnIndirect(ARect);
    if Result <> 0 then begin
      { Now hollow out the resulting region so that only a frame is left }
      R := ARect;
      InflateRect(R, -ASize.cx, -ASize.cy);
      { If ASize is greater than the size of ARect, then InflateRect will
        return a non-normalized rectangle larger than ARect. Test for this
        condition by calling IsRectEmpty. }
      if not IsRectEmpty(R) then begin
        InsideRgn := CreateRectRgnIndirect(R);
        if InsideRgn <> 0 then begin
          CombineRgn(Result, Result, InsideRgn, RGN_XOR);
          DeleteObject(InsideRgn);
        end;
      end;
    end;
  end;
end;

procedure DrawInvertRect(const DC: HDC; const NewRect, OldRect: TRect;
  const NewSize, OldSize: TSize; const Brush: HBRUSH);
{ Draws a dragging outline, hiding the old one if necessary. NewRect and/or
  OldRect may be empty. }
var
  SaveIndex: Integer;
  UpdateRgn, OldRgn: HRGN;
  R: TRect;
begin
  { Create region containing the new rectangle }
  UpdateRgn := CreateFrameRectRgn(NewRect, NewSize);
  if UpdateRgn <> 0 then begin
    { Combine that region with a region containing the old rectangle }
    OldRgn := CreateFrameRectRgn(OldRect, OldSize);
    if OldRgn <> 0 then begin
      CombineRgn(UpdateRgn, OldRgn, UpdateRgn, RGN_XOR);
      DeleteObject(OldRgn);
    end;

    { Save the DC state so that the clipping region can be restored }
    SaveIndex := SaveDC(DC);
    try
      { Draw the updated region }
      SelectClipRgn(DC, UpdateRgn);
      GetClipBox(DC, R);
      SelectObject(DC, Brush);
      PatBlt(DC, R.Left, R.Top, R.Right-R.Left, R.Bottom-R.Top, PATINVERT);
    finally
      RestoreDC(DC, SaveIndex);
    end;

    DeleteObject(UpdateRgn);
  end;
end;

function CreateMonoBitmap(const AWidth, AHeight: Integer;
  const ABits: array of Byte): HBITMAP;
begin
  {$IFNDEF CLR}
  Result := CreateBitmap(AWidth, AHeight, 1, 1, @ABits[0]);
  {$ELSE}
  { For some reason there isn't an overloaded version of CreateBitmap that
    takes a TBytes parameter, so we have to use two calls }
  Result := CreateBitmap(AWidth, AHeight, 1, 1, nil);
  SetBitmapBits(Result, Length(ABits), ABits);
  {$ENDIF}
end;

function CreateHalftoneBrush: HBRUSH;
const
  GrayPattern: array[0..15] of Byte = (
    $55, 0, $AA, 0, $55, 0, $AA, 0, $55, 0, $AA, 0, $55, 0, $AA, 0);
var
  GrayBitmap: HBITMAP;
begin
  GrayBitmap := CreateMonoBitmap(8, 8, GrayPattern);
  Result := CreatePatternBrush(GrayBitmap);
  DeleteObject(GrayBitmap);
end;

procedure DrawHalftoneInvertRect(const DC: HDC; const NewRect, OldRect: TRect;
  const NewSize, OldSize: TSize);
var
  Brush: HBRUSH;
begin
  Brush := CreateHalftoneBrush;
  try
    DrawInvertRect(DC, NewRect, OldRect, NewSize, OldSize, Brush);
  finally
    DeleteObject(Brush);
  end;
end;

var
  GradientFillAvailable: Boolean;
{$IFNDEF CLR}
type
  { Note: TTriVertex is unusable on Delphi 7 and earlier (COLOR16 is
    misdeclared as a Shortint instead of a Word). }
  TNewTriVertex = record
    x: Longint;
    y: Longint;
    Red: Word;
    Green: Word;
    Blue: Word;
    Alpha: Word;
  end;
var
  GradientFillFunc: function(DC: HDC; var Vertex: TNewTriVertex;
    NumVertex: ULONG; Mesh: Pointer; NumMesh, Mode: ULONG): BOOL; stdcall;
{$ENDIF}

procedure InitGradientFillFunc;
{$IFNDEF CLR}
var
  M: HMODULE;
{$ENDIF}
begin
  if (Win32MajorVersion >= 5) or
     ((Win32MajorVersion = 4) and (Win32MinorVersion >= 10)) then begin
    {$IFNDEF CLR}
    M := {$IFDEF JR_D5} SafeLoadLibrary {$ELSE} LoadLibrary {$ENDIF} ('msimg32.dll');
    if M <> 0 then begin
      GradientFillFunc := GetProcAddress(M, 'GradientFill');
      if Assigned(GradientFillFunc) then
        GradientFillAvailable := True;
    end;
    {$ELSE}
    GradientFillAvailable := True;
    {$ENDIF}
  end;
end;

function IsFillRectWithGradientAvailable: Boolean;
begin
  Result := GradientFillAvailable;
end;

procedure FillRectWithGradient(const DC: HDC; const R: TRect;
  const StartColor, EndColor: TColorRef; const HorizontalDirection: Boolean);
var
  Vertexes: array[0..1] of {$IFNDEF CLR} TNewTriVertex {$ELSE} TTriVertex {$ENDIF};
  GradientRect: TGradientRect;
  Mode: ULONG;
begin
  if not GradientFillAvailable then
    Exit;
  Vertexes[0].x := R.Left;
  Vertexes[0].y := R.Top;
  Vertexes[0].Red := GetRValue(StartColor) shl 8;
  Vertexes[0].Blue := GetBValue(StartColor) shl 8;
  Vertexes[0].Green := GetGValue(StartColor) shl 8;
  Vertexes[0].Alpha := 0;
  Vertexes[1].x := R.Right;
  Vertexes[1].y := R.Bottom;
  Vertexes[1].Red := GetRValue(EndColor) shl 8;
  Vertexes[1].Blue := GetBValue(EndColor) shl 8;
  Vertexes[1].Green := GetGValue(EndColor) shl 8;
  Vertexes[1].Alpha := 0;
  GradientRect.UpperLeft := 0;
  GradientRect.LowerRight := 1;
  if HorizontalDirection then
    Mode := GRADIENT_FILL_RECT_H
  else
    Mode := GRADIENT_FILL_RECT_V;
  {$IFNDEF CLR}
  GradientFillFunc(DC, Vertexes[0], 2, @GradientRect, 1, Mode);
  {$ELSE}
  GradientFill(DC, Vertexes, 2, GradientRect, 1, Mode);
  {$ENDIF}
end;

procedure DrawSmallWindowCaption(const Wnd: HWND; const DC: HDC;
  const ARect: TRect; const AText: String; const AActive: Boolean);
{ Draws a (non-themed) small window caption bar.
  On Windows Vista, a custom routine is used to work around an ugly bug in
  DrawCaption that causes the text to be painted at the wrong coordinates.
  Note: The value of the AText parameter may be ignored depending on which
  routine is chosen. }

  procedure FillBackground;
  const
    CaptionBkColors: array[Boolean, Boolean] of Integer =
      ((COLOR_INACTIVECAPTION, COLOR_ACTIVECAPTION),
       (COLOR_GRADIENTINACTIVECAPTION, COLOR_GRADIENTACTIVECAPTION));
  var
    LeftColor, RightColor: TColorRef;
  begin
    if GetSystemParametersInfoBool(SPI_GETGRADIENTCAPTIONS, False) and
       IsFillRectWithGradientAvailable then begin
      LeftColor := GetSysColor(CaptionBkColors[False, AActive]);
      RightColor := GetSysColor(CaptionBkColors[True, AActive]);
      if LeftColor <> RightColor then begin
        FillRectWithGradient(DC, ARect, LeftColor, RightColor, True);
        Exit;
      end;
    end;
    FillRect(DC, ARect, GetSysColorBrush(CaptionBkColors[False, AActive]));
  end;

const
  CaptionTextColors: array[Boolean] of Integer =
    (COLOR_INACTIVECAPTIONTEXT, COLOR_CAPTIONTEXT);
var
  Flags: UINT;
  TextRect: TRect;
  NonClientMetrics: TNonClientMetrics;
  CaptionFont, SaveFont: HFONT;
  SaveBkMode: Integer;
  SaveTextColor: TColorRef;
begin
  if ARect.Right <= ARect.Left then
    Exit;

  { Prior to Windows Vista, continue to use DrawCaption. Don't want to risk
    introducing new bugs on old OSes, plus on Windows 98, it's several times
    faster than our custom routine. }
  if Win32MajorVersion < 6 then begin
    Flags := DC_TEXT or DC_SMALLCAP;
    if AActive then
      Flags := Flags or DC_ACTIVE;
    if GetSystemParametersInfoBool(SPI_GETGRADIENTCAPTIONS, False) then
      Flags := Flags or DC_GRADIENT;
    DrawCaption(Wnd, DC, ARect, Flags);
  end
  else begin
    FillBackground;
    TextRect := ARect;
    Inc(TextRect.Left, GetSystemMetrics(SM_CXEDGE));
    if (TextRect.Right > TextRect.Left) and
       GetSystemNonClientMetrics(NonClientMetrics) then begin
      CaptionFont := CreateFontIndirect(NonClientMetrics.lfSmCaptionFont);
      if CaptionFont <> 0 then begin
        SaveFont := SelectObject(DC, CaptionFont);
        SaveBkMode := SetBkMode(DC, TRANSPARENT);
        SaveTextColor := SetTextColor(DC, GetSysColor(CaptionTextColors[AActive]));
        try
          DrawTextStr(DC, AText, TextRect, DT_SINGLELINE or DT_NOPREFIX or
            DT_VCENTER or DT_END_ELLIPSIS);
        finally
          SetTextColor(DC, SaveTextColor);
          SetBkMode(DC, SaveBkMode);
          SelectObject(DC, SaveFont);
          DeleteObject(CaptionFont);
        end;
      end;
    end;
  end;
end;

procedure DoubleBufferedRepaint(const Wnd: HWND);
var
  ClientRect, ClipRect, R: TRect;
  WndDC, BmpDC: HDC;
  Bmp: HBITMAP;
  SaveIndex: Integer;
begin
  if IsWindowVisible(Wnd) and GetClientRect(Wnd, ClientRect) and
     not IsRectEmpty(ClientRect) then begin
    ValidateRect(Wnd, nil);
    BmpDC := 0;
    Bmp := 0;
    WndDC := GetDC(Wnd);
    if WndDC <> 0 then begin
      try
        { Only repaint the area that intersects the clipping rectangle }
        if (GetClipBox(WndDC, ClipRect) <> Windows.ERROR) and
           IntersectRect(R, ClientRect, ClipRect) then begin
          Bmp := CreateCompatibleBitmap(WndDC, R.Right - R.Left, R.Bottom - R.Top);
          if Bmp <> 0 then begin
            BmpDC := CreateCompatibleDC(WndDC);
            if BmpDC <> 0 then begin
              SelectObject(BmpDC, Bmp);
              SaveIndex := SaveDC(BmpDC);
              SetWindowOrgEx(BmpDC, R.Left, R.Top, nil);
              SendMessage(Wnd, WM_ERASEBKGND, WPARAM(BmpDC), 0);
              SendMessage(Wnd, WM_PAINT, WPARAM(BmpDC), 0);
              RestoreDC(BmpDC, SaveIndex);
              BitBlt(WndDC, R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top,
                BmpDC, 0, 0, SRCCOPY);
              Exit;
            end;
          end;
        end;
      finally
        if BmpDC <> 0 then DeleteDC(BmpDC);
        if Bmp <> 0 then DeleteObject(Bmp);
        ReleaseDC(Wnd, WndDC);
      end;
    end;
  end;
  { Fall back to invalidating if we didn't or couldn't double-buffer }
  InvalidateRect(Wnd, nil, True);
end;

{$IFNDEF CLR}
function MethodsEqual(const M1, M2: TMethod): Boolean;
begin
  Result := (M1.Code = M2.Code) and (M1.Data = M2.Data);
end;
{$ENDIF}

function GetRectOfPrimaryMonitor(const WorkArea: Boolean): TRect;
begin
  if not WorkArea or not SystemParametersInfo(SPI_GETWORKAREA, 0,
     {$IFNDEF CLR}@{$ENDIF} Result, 0) then
    Result := Rect(0, 0, Screen.Width, Screen.Height);
end;

{$IFNDEF CLR}
{ On Delphi for Win32, we don't use the MultiMon unit because its stubs for
  MonitorFromRect and MonitorFromPoint are seriously bugged on Delphi 4. }
type
  HMONITOR = type THandle;
  TMonitorInfo = record
    cbSize: DWORD;
    rcMonitor: TRect;
    rcWork: TRect;
    dwFlags: DWORD;
  end;
const
  MONITOR_DEFAULTTONEAREST = $2;
var
  MultiMonApis: record
    MonitorFromRect: function(const lprcScreenCoords: TRect; dwFlags: DWORD): HMONITOR; stdcall;
    MonitorFromPoint: function(ptScreenCoords: TPoint; dwFlags: DWORD): HMONITOR; stdcall;
    MonitorFromWindow: function(hWnd: HWND; dwFlags: DWORD): HMONITOR; stdcall;
    GetMonitorInfo: function(hMonitor: HMONITOR; var lpMonitorInfo: TMonitorInfo): BOOL; stdcall;
  end;
  MultiMonApisAvailable: Boolean;

procedure InitMultiMonApis;
var
  User32Handle: THandle;
begin
  User32Handle := GetModuleHandle(user32);
  MultiMonApis.MonitorFromRect := GetProcAddress(User32Handle, 'MonitorFromRect');
  MultiMonApis.MonitorFromPoint := GetProcAddress(User32Handle, 'MonitorFromPoint');
  MultiMonApis.MonitorFromWindow := GetProcAddress(User32Handle, 'MonitorFromWindow');
  MultiMonApis.GetMonitorInfo := GetProcAddress(User32Handle, 'GetMonitorInfoA');
  MultiMonApisAvailable := Assigned(MultiMonApis.MonitorFromRect) and
    Assigned(MultiMonApis.MonitorFromPoint) and
    Assigned(MultiMonApis.MonitorFromWindow) and
    Assigned(MultiMonApis.GetMonitorInfo);
end;
{$ENDIF}

function UsingMultipleMonitors: Boolean;
{ Returns True if the system has more than one display monitor configured. }
const
  SM_CMONITORS = 80;
begin
  { Note: On a single monitor Windows 95 or NT 4 system, GetSystemMetrics will
    return 0 since those OSes do not support multiple monitors. On later
    versions it returns 1. }
  Result := {$IFNDEF CLR} MultiMonApisAvailable and {$ENDIF}
    (GetSystemMetrics(SM_CMONITORS) > 1);
end;

function GetRectOfMonitor(const M: HMONITOR; const WorkArea: Boolean;
  var R: TRect): Boolean;
var
  MonitorInfo: TMonitorInfo;
begin
  {$IFNDEF CLR}
  MonitorInfo.cbSize := SizeOf(MonitorInfo);
  {$ELSE}
  MonitorInfo.cbSize := Marshal.SizeOf(TypeOf(TMonitorInfo));
  {$ENDIF}
  Result := {$IFNDEF CLR}MultiMonApis.{$ENDIF} GetMonitorInfo(M, MonitorInfo);
  if Result then begin
    if not WorkArea then
      R := MonitorInfo.rcMonitor
    else
      R := MonitorInfo.rcWork;
  end;
end;

function GetRectOfMonitorContainingRect(const R: TRect;
  const WorkArea: Boolean): TRect;
{ Returns the work area of the monitor which the rectangle R intersects with
  the most, or the monitor nearest R if no monitors intersect. }
var
  M: HMONITOR;
begin
  if UsingMultipleMonitors then begin
    M := {$IFNDEF CLR}MultiMonApis.{$ENDIF} MonitorFromRect(R, MONITOR_DEFAULTTONEAREST);
    if GetRectOfMonitor(M, WorkArea, Result) then
      Exit;
  end;
  Result := GetRectOfPrimaryMonitor(WorkArea);
end;

function GetRectOfMonitorContainingPoint(const P: TPoint;
  const WorkArea: Boolean): TRect;
{ Returns the screen area of the monitor containing the point P, or the monitor
  nearest P if P isn't in any monitor's work area. }
var
  M: HMONITOR;
begin
  if UsingMultipleMonitors then begin
    M := {$IFNDEF CLR}MultiMonApis.{$ENDIF} MonitorFromPoint(P, MONITOR_DEFAULTTONEAREST);
    if GetRectOfMonitor(M, WorkArea, Result) then
      Exit;
  end;
  Result := GetRectOfPrimaryMonitor(WorkArea);
end;

function GetRectOfMonitorContainingWindow(const W: HWND;
  const WorkArea: Boolean): TRect;
var
  M: HMONITOR;
begin
  if UsingMultipleMonitors then begin
    M := {$IFNDEF CLR}MultiMonApis.{$ENDIF} MonitorFromWindow(W, MONITOR_DEFAULTTONEAREST);
    if GetRectOfMonitor(M, WorkArea, Result) then
      Exit;
  end;
  Result := GetRectOfPrimaryMonitor(WorkArea);
end;

{$IFNDEF CLR}
var
  TrackMouseEventInited: BOOL;
  TrackMouseEventFunc: function(var EventTrack: TTrackMouseEvent): BOOL; stdcall;

procedure InitTrackMouseEvent;
var
  TrackMouseEventComCtlModule: THandle;
begin
  { First look for TrackMouseEvent which is available on Windows 98 & NT 4 only.
    If it doesn't exist, look for _TrackMouseEvent which is available on
    Windows 95 if IE 3.0 or later is installed. }
  if not TrackMouseEventInited then begin
    TrackMouseEventFunc := GetProcAddress(GetModuleHandle(user32),
      'TrackMouseEvent');
    if @TrackMouseEventFunc = nil then begin
      TrackMouseEventComCtlModule :=
        {$IFDEF JR_D5} SafeLoadLibrary {$ELSE} LoadLibrary {$ENDIF} (comctl32);
      if TrackMouseEventComCtlModule <> 0 then
        TrackMouseEventFunc := GetProcAddress(TrackMouseEventComCtlModule,
          '_TrackMouseEvent');
    end;
    InterlockedExchange(Integer(TrackMouseEventInited), Ord(True));
  end;
end;
{$ELSE}
procedure InitTrackMouseEvent;
begin
end;
{$ENDIF}

function CallTrackMouseEvent(const Wnd: HWND; const Flags: DWORD): Boolean;
var
  Track: TTrackMouseEvent;
begin
  {$IFNDEF CLR}
  Result := False;
  if Assigned(TrackMouseEventFunc) then begin
    Track.cbSize := SizeOf(Track);
    Track.dwFlags := Flags;
    Track.hwndTrack := Wnd;
    Track.dwHoverTime := 0;
    Result := TrackMouseEventFunc(Track);
  end;
  {$ELSE}
  { .NET doesn't run on 95, so we can assume TrackMouseEvent is available }
  Track.cbSize := Marshal.SizeOf(TypeOf(TTrackMouseEvent));
  Track.dwFlags := Flags;
  Track.hwndTrack := Wnd;
  Track.dwHoverTime := 0;
  Result := TrackMouseEvent(Track);
  {$ENDIF}
end;

{$IFNDEF CLR}
var
  LockSetForegroundWindowFunc: function(uLockCode: UINT): BOOL; stdcall;
{$ELSE}
[SuppressUnmanagedCodeSecurity, DllImport(user32, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'LockSetForegroundWindow')]
function LockSetForegroundWindowFunc(uLockCode: UINT): BOOL; external;
{$ENDIF}

procedure CallLockSetForegroundWindow(const ALock: Boolean);
const
  LSFW_LOCK = 1;
  LSFW_UNLOCK = 2;
begin
  {$IFNDEF CLR}
  if Assigned(LockSetForegroundWindowFunc) then begin
  {$ELSE}
  if (Win32MajorVersion >= 5) or
     ((Win32MajorVersion = 4) and (Win32MinorVersion >= 90)) then begin
  {$ENDIF}
    if ALock then
      LockSetForegroundWindowFunc(LSFW_LOCK)
    else
      LockSetForegroundWindowFunc(LSFW_UNLOCK);
  end;
end;

{$IFNDEF JR_D5}
procedure FreeAndNil(var Obj);
var
  P: TObject;
begin
  P := TObject(Obj);
  TObject(Obj) := nil;
  P.Free;
end;
{$ENDIF}

{$IFNDEF JR_D6}
procedure RaiseLastOSError;
begin
  RaiseLastWin32Error;
end;
{$ENDIF}

{$IFDEF CLR}
{ On .NET, when calling DrawText, GetTextExtentPoint32, or TextOut we can't
  rely on the marshaller's automatic A/W function selection because they take
  a character count. If we passed the result of Length(), as the VCL
  incorrectly does in many places, the behavior would be incorrect on DBCS
  Windows 9x/Me systems because when a Unicode string is downconverted to ANSI
  the character count can increase (i.e. one Unicode character can become two
  ANSI characters).
  Below we define our own "A" function prototypes that take byte array
  parameters, allowing us to pass the result of AnsiEncoding.GetBytes straight
  to the functions without any conversion. (Borland's "A" prototypes use
  "string" type parameters.) }
[SuppressUnmanagedCodeSecurity, DllImport(user32, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'DrawTextA')]
function _DrawTextA(hDC: HDC; [in] lpString: TBytes; nCount: Integer;
  var lpRect: TRect; uFormat: UINT): Integer; external;
[SuppressUnmanagedCodeSecurity, DllImport(gdi32, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'GetTextExtentPoint32A')]
function _GetTextExtentPoint32A(DC: HDC; [in] Str: TBytes; Count: Integer;
  out Size: TSize): BOOL; external;
[SuppressUnmanagedCodeSecurity, DllImport(gdi32, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'TextOutA')]
function _TextOutA(DC: HDC; X, Y: Integer; [in] Str: TBytes;
  Count: Integer): BOOL; external;
{$ENDIF}

function DrawTextStr(const DC: HDC; const AText: String; var ARect: TRect;
  const AFormat: UINT): Integer;
{$IFNDEF CLR}
begin
  Result := DrawText(DC, PChar(AText), Length(AText), ARect, AFormat);
end;
{$ELSE}
var
  AnsiStr: TBytes;
begin
  if Marshal.SystemDefaultCharSize = 1 then begin
    AnsiStr := AnsiEncoding.GetBytes(AText);
    Result := _DrawTextA(DC, AnsiStr, Length(AnsiStr), ARect, AFormat);
  end
  else
    Result := DrawTextW(DC, AText, Length(AText), ARect, AFormat);
end;
{$ENDIF}

function GetTextExtentPoint32Str(const DC: HDC; const AText: String;
  out ASize: TSize): BOOL;
{$IFNDEF CLR}
begin
  Result := GetTextExtentPoint32(DC, PChar(AText), Length(AText), ASize);
end;
{$ELSE}
var
  AnsiStr: TBytes;
begin
  if Marshal.SystemDefaultCharSize = 1 then begin
    AnsiStr := AnsiEncoding.GetBytes(AText);
    Result := _GetTextExtentPoint32A(DC, AnsiStr, Length(AnsiStr), ASize);
  end
  else
    Result := GetTextExtentPoint32W(DC, AText, Length(AText), ASize);
end;
{$ENDIF}

function TextOutStr(const DC: HDC; const X, Y: Integer;
  const AText: String): BOOL;
{$IFNDEF CLR}
begin
  Result := TextOut(DC, X, Y, PChar(AText), Length(AText));
end;
{$ELSE}
var
  AnsiStr: TBytes;
begin
  if Marshal.SystemDefaultCharSize = 1 then begin
    AnsiStr := AnsiEncoding.GetBytes(AText);
    Result := _TextOutA(DC, X, Y, AnsiStr, Length(AnsiStr));
  end
  else
    Result := TextOutW(DC, X, Y, AText, Length(AText));
end;
{$ENDIF}

threadvar
  FontExistsResult: Boolean;

{$IFNDEF CLR}
function FontExistsCallback(const lplf: TLogFont; const lptm: TTextMetric;
  dwType: DWORD; lpData: LPARAM): Integer; stdcall;
{$ELSE}
function FontExistsCallback([in] var lplf: TLogFont; [in] var lptm: TTextMetric;
  dwType: DWORD; lpData: LPARAM): Integer;
{$ENDIF}
begin
  FontExistsResult := True;
  Result := 0;
end;

function FontExists(const DC: HDC; const FaceName: String): Boolean;
begin
  FontExistsResult := False;
  EnumFonts(DC, {$IFNDEF CLR}PChar{$ENDIF}(FaceName), @FontExistsCallback,
    {$IFNDEF CLR} nil {$ELSE} 0 {$ENDIF});
  Result := FontExistsResult;
end;

function CreateRotatedFont(DC: HDC): HFONT;
{ Creates a font based on the DC's current font, but rotated 270 degrees }
var
  LogFont: TLogFont;
  TM: TTextMetric;
  VerticalFontName: String;
begin
  if GetObject(GetCurrentObject(DC, OBJ_FONT),
     {$IFNDEF CLR}
     SizeOf(LogFont), @LogFont
     {$ELSE}
     Marshal.SizeOf(TypeOf(TLogFont)), LogFont
     {$ENDIF}
     ) = 0 then begin
    { just in case... }
    Result := 0;
    Exit;
  end;
  LogFont.lfEscapement := 2700;
  LogFont.lfOrientation := 2700;
  LogFont.lfOutPrecision := OUT_TT_ONLY_PRECIS;  { needed for Win9x }

  { Don't let a random TrueType font be substituted when MS Sans Serif or
    Microsoft Sans Serif are used. On Windows 2000 and later, hard-code Tahoma
    because Arial can't display Japanese or Thai Unicode characters (on Windows
    2000 at least). On earlier versions, hard-code Arial since NT 4.0 doesn't
    ship with Tahoma, and 9x doesn't do Unicode. }
  {$IFNDEF CLR}
  if (StrIComp(LogFont.lfFaceName, 'MS Sans Serif') = 0) or
     (StrIComp(LogFont.lfFaceName, 'Microsoft Sans Serif') = 0) then begin
    if Win32MajorVersion >= 5 then
      StrPCopy(LogFont.lfFaceName, 'Tahoma')
    else
      StrPCopy(LogFont.lfFaceName, 'Arial');
  {$ELSE}
  if SameText(LogFont.lfFaceName, 'MS Sans Serif', loInvariantLocale) or
     SameText(LogFont.lfFaceName, 'Microsoft Sans Serif', loInvariantLocale) then begin
    if Win32MajorVersion >= 5 then
      LogFont.lfFaceName := 'Tahoma'
    else
      LogFont.lfFaceName := 'Arial';
  {$ENDIF}
    { Set lfHeight to the actual height of the current font. This is needed
      to work around a Windows 98 issue: on a clean install of the OS,
      SPI_GETNONCLIENTMETRICS returns -5 for lfSmCaptionFont.lfHeight. This is
      wrong; it should return -11 for an 8 pt font. With normal, unrotated text
      this actually displays correctly, since MS Sans Serif doesn't support
      sizes below 8 pt. However, when we change to a TrueType font like Arial,
      this becomes a problem because it'll actually create a font that small. }
    if GetTextMetrics(DC, TM) then begin
      { If the original height was negative, keep it negative }
      if LogFont.lfHeight <= 0 then
        LogFont.lfHeight := -(TM.tmHeight - TM.tmInternalLeading)
      else
        LogFont.lfHeight := TM.tmHeight;
    end;
  end;

  { Use a vertical font if available so that Asian characters aren't drawn
    sideways }
  VerticalFontName := String('@') + LogFont.lfFaceName;
  if FontExists(DC, VerticalFontName) then begin
    {$IFNDEF CLR}
    StrPLCopy(LogFont.lfFaceName, VerticalFontName,
      (SizeOf(LogFont.lfFaceName) div SizeOf(LogFont.lfFaceName[0])) - 1);
    {$ELSE}
    LogFont.lfFaceName := VerticalFontName;
    {$ENDIF}
  end;

  Result := CreateFontIndirect(LogFont);
end;

procedure DrawRotatedText(const DC: HDC; AText: String; const ARect: TRect;
  const AFormat: Cardinal);
{ Like DrawText, but draws the text at a 270 degree angle.
  The only format flag this function respects is DT_HIDEPREFIX. Text is always
  drawn centered. }
var
  RotatedFont, SaveFont: HFONT;
  TextMetrics: TTextMetric;
  X, Y, P, I, SU, FU: Integer;
  SaveAlign: UINT;
  SavePen, Pen: HPEN;
begin
  RotatedFont := CreateRotatedFont(DC);
  SaveFont := SelectObject(DC, RotatedFont);

  GetTextMetrics(DC, TextMetrics);
  X := ARect.Left + ((ARect.Right - ARect.Left) - TextMetrics.tmHeight) div 2;
  Y := ARect.Top + ((ARect.Bottom - ARect.Top) - GetTextWidth(DC, AText, True)) div 2;

  { Find the index of the character that should be underlined. Delete '&'
    characters from the string. Like DrawText, only the last prefixed character
    will be underlined. }
  P := 0;
  I := 1;
  while I <= Length(AText) do begin
    {$IFNDEF JR_WIDESTR}
    if AText[I] in LeadBytes then
      Inc(I)
    else
    {$ENDIF}
    if AText[I] = '&' then begin
      Delete(AText, I, 1);
      { If the '&' was the last character, don't underline anything }
      if I > Length(AText) then
        P := 0
      else if AText[I] <> '&' then
        P := I;
    end;
    Inc(I);
  end;

  SaveAlign := SetTextAlign(DC, TA_BOTTOM);
  TextOutStr(DC, X, Y, AText);
  SetTextAlign(DC, SaveAlign);
  { Underline }
  if (P > 0) and (AFormat and DT_HIDEPREFIX = 0) then begin
    SU := GetTextWidth(DC, Copy(AText, 1, P-1), False);
    FU := SU + GetTextWidth(DC, AText[P], False);
    Inc(X, TextMetrics.tmDescent - 2);
    Pen := CreatePen(PS_SOLID, 1, GetTextColor(DC));
    SavePen := SelectObject(DC, Pen);
    MoveToEx(DC, X, Y + SU, nil);
    LineTo(DC, X, Y + FU);
    SelectObject(DC, SavePen);
    DeleteObject(Pen);
  end;

  SelectObject(DC, SaveFont);
  DeleteObject(RotatedFont);
end;

function NeedToPlaySound(const Alias: String): Boolean;
{ This function checks the registry to see if the specified sound event alias
  is assigned to a file.
  The purpose of having this function is so it can avoid calls to PlaySound if
  possible, because on Windows 2000 there is an annoying 1/3 second delay on
  the first call to PlaySound.
  Windows Explorer actually uses this same technique when playing sounds for
  the Start menu. }
var
  KeyName: String;
  K: HKEY;
  {$IFNDEF CLR}
  Data: array[0..3] of WideChar;
  {$ELSE}
  Data: TBytes;
  DataType: DWORD;
  {$ENDIF}
  DataSize: DWORD;
  ErrorCode: Longint;
begin
  if (Win32MajorVersion < 5) or (Win32Platform <> VER_PLATFORM_WIN32_NT) then begin
    { No need to check pre-Windows 2000 versions since their PlaySound
      functions don't have the delay; always return True. }
    Result := True;
    Exit;
  end;
  Result := False;
  KeyName := 'AppEvents\Schemes\Apps\.Default\' + Alias + '\.Current';
  if RegOpenKeyEx(HKEY_CURRENT_USER, {$IFNDEF CLR}PChar{$ENDIF}(KeyName),
     0, KEY_QUERY_VALUE, K) = ERROR_SUCCESS then begin
    try
      {$IFNDEF CLR}
      DataSize := SizeOf(Data);
      { Note: Use the 'W' version of RegQueryValueEx for more speed }
      ErrorCode := RegQueryValueExW(K, nil, nil, nil, @Data, @DataSize);
      if ((ErrorCode = ERROR_SUCCESS) and (Data[0] <> #0)) or
         (ErrorCode = ERROR_MORE_DATA) then
        Result := True;
      {$ELSE}
      DataSize := 4 * SizeOf(WideChar);
      SetLength(Data, DataSize);
      ErrorCode := RegQueryValueExW(K, nil, nil, DataType, Data, DataSize);
      if ((ErrorCode = ERROR_SUCCESS) and (Data[0] or Data[1] <> 0)) or
         (ErrorCode = ERROR_MORE_DATA) then
        Result := True;
      {$ENDIF}
    finally
      RegCloseKey(K);
    end;
  end;
end;

procedure PlaySystemSound(const Alias: String);
const
  SND_SYSTEM = $00200000;
var
  Flags: DWORD;
begin
  Flags := SND_ALIAS or SND_ASYNC or SND_NODEFAULT;
  if Win32Platform <> VER_PLATFORM_WIN32_NT then
    Flags := Flags or SND_NOSTOP;  { On 9x, native menus' sounds are NOSTOP } 
  if Win32MajorVersion >= 6 then
    Flags := Flags or SND_SYSTEM;
  PlaySound({$IFNDEF CLR}PChar{$ENDIF}(Alias), 0, Flags);
end;

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

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

function FindAccelChar(const S: String): Char;
{ Finds the last accelerator key in S. Returns #0 if no accelerator key was
  found. '&&' is ignored. }
{$IFNDEF CLR}
var
  P: PChar;
begin
  P := PChar(S);
  Result := #0;
  while True do begin
    P := AnsiStrScan(P, '&');
    if P = nil then Break;
    Inc(P);
    if P^ <> '&' then begin
      if P^ = #0 then Break;
      Result := P^;
    end;
    Inc(P);
  end;
end;
{$ELSE}
var
  Len, I: Integer;
begin
  Result := #0;
  Len := Length(S);
  if Len > 0 then begin  { ensures S isn't nil }
    I := 1;
    while True do begin
      I := System.String(S).IndexOf('&', I - 1) + 1;
      if (I = 0) or (I >= Len) then
        Break;
      Inc(I);
      if S[I] <> '&' then
        Result := S[I];
      Inc(I);
    end;
  end;
end;
{$ENDIF}

function IsWindowsXP: Boolean;
begin
  Result := (Win32Platform = VER_PLATFORM_WIN32_NT) and
    ((Win32MajorVersion > 5) or
     ((Win32MajorVersion = 5) and (Win32MinorVersion >= 1)));
end;

function GetInputLocaleCodePage: UINT;
{ Returns the code page identifier of the active input locale, or CP_ACP if
  for some unknown reason it couldn't be determined. }
var
  {$IFNDEF CLR}
  Buf: array[0..15] of Char;
  {$ELSE}
  Buf: StringBuilder;
  {$ENDIF}
  ErrorCode: Integer;
begin
  {$IFNDEF CLR}
  if GetLocaleInfo(GetKeyboardLayout(0) and $FFFF, LOCALE_IDEFAULTANSICODEPAGE,
     Buf, SizeOf(Buf) div SizeOf(Buf[0])) > 0 then begin
    Buf[High(Buf)] := #0;  { ensure null termination, just in case... }
    Val(Buf, Result, ErrorCode);
  {$ELSE}
  Buf := StringBuilder.Create(16);
  if GetLocaleInfo(GetKeyboardLayout(0) and $FFFF, LOCALE_IDEFAULTANSICODEPAGE,
     Buf, Buf.Capacity) > 0 then begin
    Val(Buf.ToString, Result, ErrorCode);
  {$ENDIF}
    { Just to be *completely* safe, verify that the code page returned by
      GetLocaleInfo actually exists. The result of this function may be fed
      into WideCharToMultiByte, and we don't want WideCharToMultiByte to fail
      entirely because of a bad code page. }
    if (ErrorCode <> 0) or not IsValidCodePage(Result) then
      Result := CP_ACP;
  end
  else
    Result := CP_ACP;
end;

function GetMessagePosAsPoint: TPoint;
var
  Pos: DWORD;
begin
  Pos := GetMessagePos;
  Result.X := Smallint(Pos and $FFFF);
  Result.Y := Smallint(Pos shr 16);
end;

function GetSystemNonClientMetrics(var Metrics: TNonClientMetrics): Boolean;
{$IFNDEF CLR}
begin
  Metrics.cbSize := SizeOf(Metrics);
  Result := SystemParametersInfo(SPI_GETNONCLIENTMETRICS, SizeOf(Metrics),
    @Metrics, 0);
end;
{$ELSE}
begin
  {$IFDEF JR_D11}
  { On Delphi.NET 2007, Forms.GetNonClientMetrics is marked deprecated }
  Metrics.cbSize := Marshal.SizeOf(TypeOf(TNonClientMetrics));
  Result := SystemParametersInfo(SPI_GETNONCLIENTMETRICS, Metrics.cbSize,
    Metrics, 0);
  {$ELSE}
  Result := Forms.GetNonClientMetrics(Metrics);
  {$ENDIF}
end;
{$ENDIF}

function GetSystemParametersInfoBool(const Param: UINT; const Default: BOOL): BOOL;
{ Returns the value of the specified BOOL-type system parameter, or Default
  if the function fails }
begin
  if not SystemParametersInfo(Param, 0, {$IFNDEF CLR}@{$ENDIF} Result, 0) then
    Result := Default;
end;

{$IFDEF CLR}
{ Use our own declaration for CharLowerBuffA that takes a byte array directly
  instead of StringBuilder }
[SuppressUnmanagedCodeSecurity, DllImport(user32, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'CharLowerBuffA')]
function _CharLowerBuffA([in, out] lpsz: TBytes; cchLength: DWORD): DWORD; external;
{$ENDIF}

function CharToLower(const C: Char): Char;
{ Converts a single character to lowercase using the current code page }
{$IFNDEF CLR}
begin
  Result := Char(CharLower(Pointer(Word(C))));
end;
{$ELSE}
var
  AnsiBytes: TBytes;
begin
  { Note: On .NET we can't use LowerCase()/String.ToLower() because it uses
    linguistic casing rules -- on a Turkish locale "I" is NOT mapped to "i".
    This would break accelerator keys when running English apps. With
    CharLower, "I" is always mapped to "i". }
  if Marshal.SystemDefaultCharSize = 1 then begin
    { On Windows 9x/Me we have to use CharLowerBuff since the character may be
      two bytes when downconverted to ANSI. And we have to handle the
      Unicode->ANSI conversion ourself so that we know the correct length to
      pass to the function. }
    AnsiBytes := AnsiEncoding.GetBytes(C);
    _CharLowerBuffA(AnsiBytes, Length(AnsiBytes));
    Result := AnsiEncoding.GetChars(AnsiBytes)[0];
  end
  else
    Result := Char(Word(CharLowerW(IntPtr(Word(C)))));
end;
{$ENDIF}

{$IFNDEF JR_D6}
function InvalidPoint(const At: TPoint): Boolean;
begin
  Result := (At.X = -1) and (At.Y = -1);
end;
{$ENDIF}

{$IFDEF CLR}
function ClipToLongint(const I: Int64): Longint; inline;
{ On Delphi.NET 2007, casting a LPARAM (THandle) directly into a Longint can
  raise an overflow exception (possibly a bug?). By passing the LPARAM to
  this function, which acts like a Longint(Int64()) cast, the exception can
  be avoided. }
begin
  Result := Longint(I);
end;
{$ENDIF}

initialization
  InitGradientFillFunc;
  {$IFNDEF CLR}
  InitMultiMonApis;
  LockSetForegroundWindowFunc := GetProcAddress(GetModuleHandle(user32),
    'LockSetForegroundWindow');
  {$ENDIF}
end.