a3d4d0d2fd
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@232 8e941d3f-bd1b-0410-a28a-d453659cc2b4
514 lines
13 KiB
ObjectPascal
514 lines
13 KiB
ObjectPascal
unit vclutils;
|
|
|
|
{$I rx.inc}
|
|
|
|
interface
|
|
|
|
uses
|
|
{$IFDEF WIN32}
|
|
Windows,
|
|
{$ENDIF}
|
|
Classes, SysUtils, Graphics, Controls, Forms
|
|
;
|
|
|
|
type
|
|
TTextOrientation = (toHorizontal, toVertical90, toHorizontal180, toVertical270, toHorizontal360);
|
|
|
|
function WidthOf(R: TRect): Integer;
|
|
function HeightOf(R: TRect): Integer;
|
|
|
|
procedure RxFrame3D(Canvas: TCanvas; var Rect: TRect; TopColor, BottomColor: TColor;
|
|
Width: Integer);
|
|
function DrawButtonFrame(Canvas: TCanvas; const Client: TRect;
|
|
IsDown, IsFlat: Boolean): TRect;
|
|
function DrawButtonFrameXP(Canvas: TCanvas; const Client: TRect;
|
|
IsDown, IsFlat: Boolean): TRect;
|
|
|
|
procedure OutTextXY90(Canvas:TCanvas; X,Y:integer; Text:string; Orientation:TTextOrientation);
|
|
|
|
function IsForegroundTask: Boolean;
|
|
function ValidParentForm(Control: TControl): TCustomForm;
|
|
{
|
|
function AllocMemo(Size: Longint): Pointer;
|
|
function ReallocMemo(fpBlock: Pointer; Size: Longint): Pointer;
|
|
procedure FreeMemo(var fpBlock: Pointer);
|
|
}
|
|
|
|
{$IFDEF WIN32}
|
|
type
|
|
PCursorOrIcon = ^TCursorOrIcon;
|
|
TCursorOrIcon = packed record
|
|
Reserved: Word;
|
|
wType: Word;
|
|
Count: Word;
|
|
end;
|
|
|
|
PIconRec = ^TIconRec;
|
|
TIconRec = packed record
|
|
Width: Byte;
|
|
Height: Byte;
|
|
Colors: Word;
|
|
Reserved1: Word;
|
|
Reserved2: Word;
|
|
DIBSize: Longint;
|
|
DIBOffset: Longint;
|
|
end;
|
|
|
|
procedure ReadIcon(Stream: TStream; var Icon: HICON; ImageCount: Integer;
|
|
StartOffset: Integer; const RequestedSize: TPoint; var IconSize: TPoint);
|
|
procedure OutOfResources;
|
|
{$ENDIF}
|
|
|
|
implementation
|
|
{$IFNDEF WIN32}
|
|
uses LCLProc, LCLIntf;
|
|
{$ENDIF}
|
|
|
|
function WidthOf(R: TRect): Integer;
|
|
begin
|
|
Result := R.Right - R.Left;
|
|
end;
|
|
|
|
function HeightOf(R: TRect): Integer;
|
|
begin
|
|
Result := R.Bottom - R.Top;
|
|
end;
|
|
|
|
procedure RxFrame3D(Canvas: TCanvas; var Rect: TRect; TopColor, BottomColor: TColor;
|
|
Width: Integer);
|
|
|
|
procedure DoRect;
|
|
var
|
|
TopRight, BottomLeft: TPoint;
|
|
begin
|
|
TopRight.X := Rect.Right;
|
|
TopRight.Y := Rect.Top;
|
|
BottomLeft.X := Rect.Left;
|
|
BottomLeft.Y := Rect.Bottom;
|
|
Canvas.Pen.Color := TopColor;
|
|
Canvas.PolyLine([BottomLeft, Rect.TopLeft, TopRight]);
|
|
Canvas.Pen.Color := BottomColor;
|
|
Dec(BottomLeft.X);
|
|
Canvas.PolyLine([TopRight, Rect.BottomRight, BottomLeft]);
|
|
end;
|
|
|
|
begin
|
|
Canvas.Pen.Width := 1;
|
|
Dec(Rect.Bottom); Dec(Rect.Right);
|
|
while Width > 0 do
|
|
begin
|
|
Dec(Width);
|
|
DoRect;
|
|
InflateRect(Rect, -1, -1);
|
|
end;
|
|
Inc(Rect.Bottom); Inc(Rect.Right);
|
|
end;
|
|
|
|
function DrawButtonFrame(Canvas: TCanvas; const Client: TRect;
|
|
IsDown, IsFlat: Boolean): TRect;
|
|
begin
|
|
Result := Client;
|
|
if IsDown then
|
|
begin
|
|
RxFrame3D(Canvas, Result, clWindowFrame, clBtnHighlight, 1);
|
|
if not IsFlat then
|
|
RxFrame3D(Canvas, Result, clBtnShadow, clBtnFace, 1);
|
|
end
|
|
else
|
|
begin
|
|
if IsFlat then
|
|
RxFrame3D(Canvas, Result, clBtnHighlight, clBtnShadow, 1)
|
|
else
|
|
begin
|
|
RxFrame3D(Canvas, Result, clBtnHighlight, clWindowFrame, 1);
|
|
RxFrame3D(Canvas, Result, clBtnFace, clBtnShadow, 1);
|
|
end;
|
|
end;
|
|
InflateRect(Result, -1, -1);
|
|
end;
|
|
|
|
function DrawButtonFrameXP(Canvas: TCanvas; const Client: TRect; IsDown,
|
|
IsFlat: Boolean): TRect;
|
|
begin
|
|
Result := Client;
|
|
Canvas.Brush.Color := $00EFD3C6;
|
|
Canvas.FillRect(Client);
|
|
RxFrame3D(Canvas, Result, $00C66931, $00C66931, 1);
|
|
end;
|
|
|
|
{$IFDEF WIN32}
|
|
type
|
|
PCheckTaskInfo = ^TCheckTaskInfo;
|
|
TCheckTaskInfo = record
|
|
FocusWnd: HWnd;
|
|
Found: Boolean;
|
|
end;
|
|
//function CheckTaskWindow(Window: HWnd; Data: Longint): WordBool; stdcall;
|
|
function CheckTaskWindow(Window:HWND; Data:LPARAM):WINBOOL;stdcall;
|
|
begin
|
|
Result := True;
|
|
if PCheckTaskInfo(Data)^.FocusWnd = Window then begin
|
|
Result := False;
|
|
PCheckTaskInfo(Data)^.Found := True;
|
|
end;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
function IsForegroundTask: Boolean;
|
|
{$IFDEF WIN32}
|
|
var
|
|
Info: TCheckTaskInfo;
|
|
{$ENDIF}
|
|
begin
|
|
{$IFDEF WIN32}
|
|
Info.FocusWnd := GetActiveWindow;
|
|
Info.Found := False;
|
|
EnumThreadWindows(GetCurrentThreadID, @CheckTaskWindow, Longint(@Info));
|
|
Result := Info.Found;
|
|
{$ELSE}
|
|
Result:=true;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function ValidParentForm(Control: TControl): TCustomForm;
|
|
begin
|
|
Result := GetParentForm(Control);
|
|
if Result = nil then
|
|
raise EInvalidOperation.CreateFmt('ParentRequired %s', [Control.Name]);
|
|
end;
|
|
|
|
procedure OutTextXY90(Canvas:TCanvas; X,Y:integer; Text:string; Orientation:TTextOrientation);
|
|
var
|
|
W,H, i,j:integer;
|
|
Bmp:TBitmap;
|
|
begin
|
|
if Orientation = toHorizontal then
|
|
Canvas.TextOut(X, Y, Text)
|
|
else
|
|
begin
|
|
W:=Canvas.TextWidth(Text);
|
|
H:=Canvas.TextHeight(Text);
|
|
Bmp:=TBitMap.Create;
|
|
try
|
|
Bmp.Width:=W;
|
|
Bmp.Height:=H;
|
|
Bmp.Canvas.Brush.Style:=bsSolid;
|
|
Bmp.Canvas.Brush.Color:=clWhite;
|
|
Bmp.Canvas.FillRect(Rect(0,0,W,H));
|
|
Bmp.Canvas.Font:=Canvas.Font;
|
|
Bmp.Canvas.TextOut(0, 0, Text);
|
|
if Orientation = toVertical90 then
|
|
begin
|
|
for i:=0 to W-1 do
|
|
for j:=0 to H-1 do
|
|
if Bmp.Canvas.Pixels[i,j]<>clWhite then
|
|
Canvas.Pixels[(H-j)+X,i+Y]:=Bmp.Canvas.Pixels[i,j];
|
|
end
|
|
else
|
|
if Orientation = toVertical270 then
|
|
begin
|
|
for i:=0 to W-1 do
|
|
for j:=0 to H-1 do
|
|
if Bmp.Canvas.Pixels[i,j]<>clWhite then
|
|
Canvas.Pixels[j+X,(W-i)+Y]:=Bmp.Canvas.Pixels[i,j];
|
|
end
|
|
else
|
|
if Orientation = toHorizontal180 then
|
|
begin
|
|
for i:=0 to W-1 do
|
|
for j:=0 to H-1 do
|
|
if Bmp.Canvas.Pixels[i,j]<>clWhite then
|
|
Canvas.Pixels[i+X,(H-j)+Y]:=Bmp.Canvas.Pixels[i,j];
|
|
end
|
|
else
|
|
if Orientation = toHorizontal360 then
|
|
begin
|
|
for i:=0 to W-1 do
|
|
for j:=0 to H-1 do
|
|
if Bmp.Canvas.Pixels[i,j]<>clWhite then
|
|
Canvas.Pixels[(W-i)+X,j+Y]:=Bmp.Canvas.Pixels[i,j];
|
|
end;
|
|
finally
|
|
Bmp.Free;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{
|
|
function AllocMemo(Size: Longint): Pointer;
|
|
begin
|
|
if Size > 0 then
|
|
Result := GlobalAllocPtr(HeapAllocFlags or GMEM_ZEROINIT, Size)
|
|
else Result := nil;
|
|
end;
|
|
|
|
function ReallocMemo(fpBlock: Pointer; Size: Longint): Pointer;
|
|
begin
|
|
Result := GlobalReallocPtr(fpBlock, Size,
|
|
HeapAllocFlags or GMEM_ZEROINIT);
|
|
end;
|
|
|
|
procedure FreeMemo(var fpBlock: Pointer);
|
|
begin
|
|
if fpBlock <> nil then begin
|
|
GlobalFreePtr(fpBlock);
|
|
fpBlock := nil;
|
|
end;
|
|
end;
|
|
}
|
|
{$IFDEF WIN32}
|
|
function CreateIcon(hInstance: HINST; nWidth, nHeight: Integer;
|
|
cPlanes, cBitsPixel: Byte; lpbANDbits, lpbXORbits: Pointer): HICON; stdcall; external user32 name 'CreateIcon';
|
|
|
|
procedure GDIError;
|
|
var
|
|
ErrorCode: Integer;
|
|
Buf: array [Byte] of Char;
|
|
begin
|
|
ErrorCode := GetLastError;
|
|
if (ErrorCode <> 0) and (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil,
|
|
ErrorCode, LOCALE_USER_DEFAULT, Buf, sizeof(Buf), nil) <> 0) then
|
|
raise EOutOfResources.Create(Buf)
|
|
else
|
|
OutOfResources;
|
|
end;
|
|
|
|
function DupBits(Src: HBITMAP; Size: TPoint; Mono: Boolean): HBITMAP;
|
|
var
|
|
DC, Mem1, Mem2: HDC;
|
|
Old1, Old2: HBITMAP;
|
|
Bitmap: Windows.TBitmap;
|
|
begin
|
|
Mem1 := CreateCompatibleDC(0);
|
|
Mem2 := CreateCompatibleDC(0);
|
|
|
|
try
|
|
GetObject(Src, SizeOf(Bitmap), @Bitmap);
|
|
if Mono then
|
|
Result := CreateBitmap(Size.X, Size.Y, 1, 1, nil)
|
|
else
|
|
begin
|
|
DC := GetDC(0);
|
|
if DC = 0 then GDIError;
|
|
try
|
|
Result := CreateCompatibleBitmap(DC, Size.X, Size.Y);
|
|
if Result = 0 then GDIError;
|
|
finally
|
|
ReleaseDC(0, DC);
|
|
end;
|
|
end;
|
|
|
|
if Result <> 0 then
|
|
begin
|
|
Old1 := SelectObject(Mem1, Src);
|
|
Old2 := SelectObject(Mem2, Result);
|
|
|
|
StretchBlt(Mem2, 0, 0, Size.X, Size.Y, Mem1, 0, 0, Bitmap.bmWidth,
|
|
Bitmap.bmHeight, SrcCopy);
|
|
if Old1 <> 0 then SelectObject(Mem1, Old1);
|
|
if Old2 <> 0 then SelectObject(Mem2, Old2);
|
|
end;
|
|
finally
|
|
DeleteDC(Mem1);
|
|
DeleteDC(Mem2);
|
|
end;
|
|
end;
|
|
|
|
function GDICheck(Value: Integer): Integer;
|
|
begin
|
|
if Value = 0 then GDIError;
|
|
Result := Value;
|
|
end;
|
|
|
|
function GetDInColors(BitCount: Word): Integer;
|
|
begin
|
|
case BitCount of
|
|
1, 4, 8: Result := 1 shl BitCount;
|
|
else
|
|
Result := 0;
|
|
end;
|
|
end;
|
|
|
|
function BytesPerScanline(PixelsPerScanline, BitsPerPixel, Alignment: Longint): Longint;
|
|
begin
|
|
Dec(Alignment);
|
|
Result := ((PixelsPerScanline * BitsPerPixel) + Alignment) and not Alignment;
|
|
Result := Result div 8;
|
|
end;
|
|
|
|
procedure TwoBitsFromDIB(var BI: TBitmapInfoHeader; var XorBits, AndBits: HBITMAP;
|
|
const IconSize: TPoint);
|
|
type
|
|
PLongArray = ^TLongArray;
|
|
TLongArray = array[0..1] of Longint;
|
|
var
|
|
Temp: HBITMAP;
|
|
NumColors: Integer;
|
|
DC: HDC;
|
|
Bits: Pointer;
|
|
Colors: PLongArray;
|
|
begin
|
|
with BI do
|
|
begin
|
|
biHeight := biHeight shr 1; { Size in record is doubled }
|
|
biSizeImage := BytesPerScanline(biWidth, biBitCount, 32) * biHeight;
|
|
NumColors := GetDInColors(biBitCount);
|
|
end;
|
|
DC := GetDC(0);
|
|
if DC = 0 then OutOfResources;
|
|
try
|
|
Bits := Pointer(Longint(@BI) + SizeOf(BI) + NumColors * SizeOf(TRGBQuad));
|
|
Temp := GDICheck(CreateDIBitmap(DC, BI, CBM_INIT, Bits, PBitmapInfo(@BI)^, DIB_RGB_COLORS));
|
|
try
|
|
XorBits := DupBits(Temp, IconSize, False);
|
|
finally
|
|
DeleteObject(Temp);
|
|
end;
|
|
with BI do
|
|
begin
|
|
Inc(Longint(Bits), biSizeImage);
|
|
biBitCount := 1;
|
|
biSizeImage := BytesPerScanline(biWidth, biBitCount, 32) * biHeight;
|
|
biClrUsed := 2;
|
|
biClrImportant := 2;
|
|
end;
|
|
Colors := Pointer(Longint(@BI) + SizeOf(BI));
|
|
Colors^[0] := 0;
|
|
Colors^[1] := $FFFFFF;
|
|
Temp := GDICheck(CreateDIBitmap(DC, BI, CBM_INIT, Bits, PBitmapInfo(@BI)^, DIB_RGB_COLORS));
|
|
try
|
|
AndBits := DupBits(Temp, IconSize, True);
|
|
finally
|
|
DeleteObject(Temp);
|
|
end;
|
|
finally
|
|
ReleaseDC(0, DC);
|
|
end;
|
|
end;
|
|
|
|
procedure ReadIcon(Stream: TStream; var Icon: HICON; ImageCount: Integer;
|
|
StartOffset: Integer; const RequestedSize: TPoint; var IconSize: TPoint);
|
|
type
|
|
PIconRecArray = ^TIconRecArray;
|
|
TIconRecArray = array[0..300] of TIconRec;
|
|
var
|
|
List: PIconRecArray;
|
|
HeaderLen, Length: Integer;
|
|
BitsPerPixel: Word;
|
|
Colors, BestColor, C1, N, Index: Integer;
|
|
DC: HDC;
|
|
BI: PBitmapInfoHeader;
|
|
ResData: Pointer;
|
|
XorBits, AndBits: HBITMAP;
|
|
XorInfo, AndInfo: Windows.TBitmap;
|
|
XorMem, AndMem: Pointer;
|
|
XorLen, AndLen: Integer;
|
|
|
|
function AdjustColor(I: Integer): Integer;
|
|
begin
|
|
if I = 0 then
|
|
Result := MaxInt
|
|
else
|
|
Result := I;
|
|
end;
|
|
|
|
function BetterSize(const Old, New: TIconRec): Boolean;
|
|
var
|
|
NewX, NewY, OldX, OldY: Integer;
|
|
begin
|
|
NewX := New.Width - IconSize.X;
|
|
NewY := New.Height - IconSize.Y;
|
|
OldX := Old.Width - IconSize.X;
|
|
OldY := Old.Height - IconSize.Y;
|
|
Result := (Abs(NewX) <= Abs(OldX)) and ((NewX <= 0) or (NewX <= OldX)) and
|
|
(Abs(NewY) <= Abs(OldY)) and ((NewY <= 0) or (NewY <= OldY));
|
|
end;
|
|
|
|
begin
|
|
HeaderLen := SizeOf(TIconRec) * ImageCount;
|
|
List := AllocMem(HeaderLen);
|
|
try
|
|
Stream.Read(List^, HeaderLen);
|
|
if (RequestedSize.X or RequestedSize.Y) = 0 then
|
|
begin
|
|
IconSize.X := GetSystemMetrics(SM_CXICON);
|
|
IconSize.Y := GetSystemMetrics(SM_CYICON);
|
|
end
|
|
else
|
|
IconSize := RequestedSize;
|
|
DC := GetDC(0);
|
|
if DC = 0 then OutOfResources;
|
|
try
|
|
BitsPerPixel := GetDeviceCaps(DC, PLANES) * GetDeviceCaps(DC, BITSPIXEL);
|
|
if BitsPerPixel > 8 then
|
|
Colors := MaxInt
|
|
else
|
|
Colors := 1 shl BitsPerPixel;
|
|
finally
|
|
ReleaseDC(0, DC);
|
|
end;
|
|
|
|
{ Find the image that most closely matches (<=) the current screen color
|
|
depth and the requested image size. }
|
|
Index := 0;
|
|
BestColor := AdjustColor(List^[0].Colors);
|
|
for N := 1 to ImageCount-1 do
|
|
begin
|
|
C1 := AdjustColor(List^[N].Colors);
|
|
if (C1 <= Colors) and (C1 >= BestColor) and
|
|
BetterSize(List^[Index], List^[N]) then
|
|
begin
|
|
Index := N;
|
|
BestColor := C1;
|
|
end;
|
|
end;
|
|
|
|
with List^[Index] do
|
|
begin
|
|
IconSize.X := Width;
|
|
IconSize.Y := Height;
|
|
BI := AllocMem(DIBSize);
|
|
try
|
|
Stream.Seek(DIBOffset - (HeaderLen + StartOffset), 1);
|
|
Stream.Read(BI^, DIBSize);
|
|
TwoBitsFromDIB(BI^, XorBits, AndBits, IconSize);
|
|
GetObject(AndBits, SizeOf(Windows.TBitmap), @AndInfo);
|
|
GetObject(XorBits, SizeOf(Windows.TBitmap), @XorInfo);
|
|
with AndInfo do
|
|
AndLen := bmWidthBytes * bmHeight * bmPlanes;
|
|
with XorInfo do
|
|
XorLen := bmWidthBytes * bmHeight * bmPlanes;
|
|
Length := AndLen + XorLen;
|
|
ResData := AllocMem(Length);
|
|
try
|
|
AndMem := ResData;
|
|
with AndInfo do
|
|
XorMem := Pointer(Longint(ResData) + AndLen);
|
|
GetBitmapBits(AndBits, AndLen, AndMem);
|
|
GetBitmapBits(XorBits, XorLen, XorMem);
|
|
DeleteObject(XorBits);
|
|
DeleteObject(AndBits);
|
|
Icon := CreateIcon(HInstance, IconSize.X, IconSize.Y,
|
|
XorInfo.bmPlanes, XorInfo.bmBitsPixel, AndMem, XorMem);
|
|
if Icon = 0 then GDIError;
|
|
finally
|
|
FreeMem(ResData, Length);
|
|
end;
|
|
finally
|
|
FreeMem(BI, DIBSize);
|
|
end;
|
|
end;
|
|
finally
|
|
FreeMem(List, HeaderLen);
|
|
end;
|
|
end;
|
|
|
|
procedure OutOfResources;
|
|
begin
|
|
raise Exception.Create('SOutOfResources');
|
|
end;
|
|
{$ENDIF}
|
|
end.
|
|
|
|
|