babaev-an/lasarus_compotents
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
lasarus_compotents/ToolBar 2000/Source/TB2Common.pas

1574 lines
49 KiB
ObjectPascal
Raw Blame History

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.
Reference in New Issue View Git Blame Copy Permalink