Menu
▾
▴
[JVCL-Checkins] CVS: dev/JVCL3/run JvClxUtils.pas,NONE,1.1 QWinCursors.pas,NONE,1.1
|
From: Andreas H. <ah...@us...> - 2003-10-25 00:30:01
|
Update of /cvsroot/jvcl/dev/JVCL3/run
In directory sc8-pr-cvs1:/tmp/cvs-serv5909/run
Added Files:
JvClxUtils.pas QWinCursors.pas
Log Message:
CLX support functions
--- NEW FILE: JvClxUtils.pas ---
{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.
The Original Code is: JvClxUtils.pas released on 2003-10-25.
The Initial Developer of the Original Code is Marcel Bestebroer
Portions created by Andreas Hausladen are Copyright (C) 2003 Andreas Hausladen,
[And...@gm...] and André Snepvangers
All Rights Reserved.
Contributor(s):
Last Modified: 2003-10-25
You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.sourceforge.net
Known Issues:
-----------------------------------------------------------------------------}
{$I JVCL.INC}
unit JvClxUtils;
interface
uses
{$IFDEF MSWINDOWS}
Windows,
{$ENDIF}
{$IFDEF INUX}
Libc,
{$ENDIF}
{$IFDEF COMPLIB_VCL}
Graphics,
{$ENDIF}
{$IFDEF COMPLIB_CLX}
Qt, QTypes, Types, QGraphics, QForms,
{$ENDIF}
SysUtils, Classes,
JvTypes;
{$IFDEF COMPLIB_CLX}
function GetSysColor(Color: Integer): TColorRef;
procedure SetWindowPlacement(Handle: QWidgetH; W: PWindowPlacement);
procedure GetWindowPlacement(Handle: QWidgetH; W: PWindowPlacement);
function IsWindowVisible(Handle: QWidgetH): Boolean;
function IsWindowEnabled(Handle: QWidgetH): Boolean;
procedure EnableWindow(Handle: QWidgetH; Value: Boolean);
procedure SwitchToThisWindow(Handle: QWidgetH; Restore: Boolean);
procedure SetFocus(Handle: QWidgetH);
type
TColorRef = Integer;
function RGB(Red, Green, Blue: Integer): TColorRef;
function GetBValue(Col: TColorRef): Integer;
function GetGValue(Col: TColorRef): Integer;
function GetRValue(Col: TColorRef): Integer;
procedure MessageBeep(Value: Integer);
{$IFDEF LINUX}
function GetTickCount: Cardinal;
function MakeIntResource(Value: Integer): PChar;
{$ENDIF}
type
TSysMetrics = (
SM_CXSCREEN, SM_CYSCREEN,
SM_CXVSCROLL, SM_CYVSCROLL,
SM_CXSMICON, SM_CXICON,
SM_CXBORDER, SM_CYBORDER,
SM_CXFRAME, SM_CYFRAME
);
// limited implementation of
function GetSystemMetrics(PropItem: TSysMetrics): Integer;
function TruncatePath(const FilePath: string; Canvas: TCanvas; MaxLen: Integer): string;
function TruncateName(const Name: String; Canvas: TCanvas; MaxLen: Integer): string;
const
// constants for Canvas.TextRect
AlignLeft = 1 { $1 };
AlignRight = 2 { $2 };
AlignHCenter = 4 { $4 };
AlignTop = 8 { $8 };
AlignBottom = 16 { $10 };
AlignVCenter = 32 { $20 };
AlignCenter = 36 { $24 };
SingleLine = 64 { $40 };
DontClip = 128 { $80 };
ExpandTabs = 256 { $100 };
ShowPrefix = 512 { $200 };
WordBreak = 1024 { $400 };
ModifyString = 2048 { $800 };
DontPrint = 4096 { $1000 };
ClipPath = 8192 { $2000 };
ClipName = 16382 { $4000 };
CalcRect = 32764 { $8000 } ;
pf24bit = pf32bit;
{$ENDIF COMPLIB_CLX}
const
DT_ELLIPSIS = DT_END_ELLIPSIS;
{$IFDEF LINUX}
const
{ ClxDrawText() Format Flags }
DT_TOP = 0; // default
DT_LEFT = 0; // default
DT_CENTER = 1;
DT_RIGHT = 2;
DT_VCENTER = 4;
DT_BOTTOM = 8;
DT_WORDBREAK = $10;
DT_SINGLELINE = $20;
DT_EXPANDTABS = $40;
// DT_TABSTOP = $80;
DT_NOCLIP = $100;
// DT_EXTERNALLEADING = $200;
DT_CALCRECT = $400;
DT_NOPREFIX = $800;
// DT_INTERNAL = $1000;
// DT_HIDEPREFIX = $00100000;
// DT_PREFIXONLY = $00200000;
// DT_EDITCONTROL = $2000;
DT_PATH_ELLIPSIS = $4000;
DT_END_ELLIPSIS = $8000;
DT_ELLIPSIS = DT_END_ELLIPSIS;
DT_MODIFYSTRING = $10000;
// DT_RTLREADING = $20000;
// DT_WORD_ELLIPSIS = $40000;
{ ClxExtTextOut() Format Flags }
ETO_OPAQUE = 2;
ETO_CLIPPED = 4;
// ETO_GLYPH_INDEX = $10;
ETO_RTLREADING = $80; // ignored
// ETO_NUMERICSLOCAL = $400;
// ETO_NUMERICSLATIN = $800;
// ETO_IGNORELANGUAGE = $1000;
// ETO_PDY = $2000;
{ ShowWindow() Commands }
SW_HIDE = 0;
SW_SHOWNORMAL = 1;
SW_NORMAL = 1;
SW_SHOWMINIMIZED = 2;
SW_SHOWMAXIMIZED = 3;
SW_MAXIMIZE = 3;
SW_SHOWNOACTIVATE = 4;
SW_SHOW = 5;
SW_MINIMIZE = 6;
SW_SHOWMINNOACTIVE = 7;
SW_SHOWNA = 8;
SW_RESTORE = 9;
SW_SHOWDEFAULT = 10;
SW_MAX = 10;
{$ENDIF LINUX}
function ClxDrawText(Canvas: TCanvas; var Caption: string; var R: TRect;
Flags: Integer): Integer;
function ClxDrawTextW(Canvas: TCanvas; var Caption: WideString; var R: TRect;
Flags: Integer): Integer;
function ClxExtTextOut(Canvas: TCanvas; X, Y: Integer; Flags: Integer; Rect: PRect;
const Text: String; lpDx: Pointer): Boolean;
function ClxExtTextOutW(Canvas: TCanvas; X, Y: Integer; Flags: Integer;
Rect: PRect; const Text: WideString; lpDx: Pointer): Boolean;
implementation
{$IFDEF COMPLIB_CLX}
function GetSysColor(Color: Integer): TColorRef;
begin
Result := TColorRef(Application.Palette.GetColor(Color));
end;
procedure EnableWindow(Handle: QWidgetH; Value: Boolean);
begin
QWidget_setEnabled(Handle, Value);
end;
procedure SetWindowPlacement(Handle: QWidgetH; W: PWindowPlacement);
begin
with W.rcNormalPosition do
QWidget_setGeometry(Handle, Left, Top, Right - Left, Bottom - Top);
case W.ShowCmd of
SW_MINIMIZE, SW_SHOWMINIMIZED, SW_SHOWMINNOACTIVE:
QWidget_showMinimized(Handle);
SW_MAXIMIZE:
QWidget_showMaximized(Handle);
SW_HIDE:
QWidget_hide(Handle);
else
QWidget_showNormal(Handle);
end;
end;
procedure GetWindowPlacement(Handle: QWidgetH; W: PWindowPlacement);
var
R : TRect;
begin
QWidget_geometry(Handle, @R);
W.rcNormalPosition.Left := R.Left;
W.rcNormalPosition.Top := R.Top;
W.rcNormalPosition.Right := R.Right;
W.rcNormalPosition.Bottom := R.Left;
if QWidget_isMinimized(Handle) then
W.showCmd := SW_SHOWMINIMIZED
else if QWidget_isMaximized(Handle) then
W.showCmd := SW_SHOWMAXIMIZED
else if not QWidget_isVisible(Handle) then
W.showCmd := SW_HIDE
else
W.showCmd := SW_SHOWNORMAL;
end;
function IsWindowVisible(Handle: QWidgetH): Boolean;
begin
Result := QWidget_isVisible(Handle);
end;
function IsWindowEnabled(Handle: QWidgetH): Boolean;
begin
Result := QWidget_isEnabled(Handle);
end;
procedure SetFocus(Handle: QWidgetH);
begin
QWidget_setFocus(Handle);
end;
procedure SetForegroundWindow(Handle: QWidgetH);
begin
QWidget_raise(Handle);
end;
procedure SwitchToThisWindow(Handle: QWidgetH; Restore: Boolean);
begin
if Restore then
QWidget_Show(Handle);
QWidget_setActiveWindow(Handle);
end;
// limited implementation of
function GetSystemMetrics(PropItem: TSysMetrics): Integer;
var
size: TSize;
begin
case PropItem of
SM_CXVSCROLL:
begin
QStyle_scrollBarExtent(Application.Style.Handle, @size);
Result := size.cx;
end;
SM_CYVSCROLL:
begin
QStyle_scrollBarExtent(Application.Style.Handle, @size);
Result := size.cy;
end;
SM_CXSMICON:
Result := 16;
SM_CXICON:
Result := 32;
SM_CXSCREEN:
Result := Screen.Width;
SM_CYSCREEN:
Result := Screen.Height;
SM_CXBORDER, SM_CYBORDER:
Result := Application.Style.DefaultFrameWidth; // (probably) wrong ?
SM_CXFRAME, SM_CYFRAME:
Result := Application.Style.DefaultFrameWidth; // or this one
else
Result := 0;
end;
end;
function RGB(Red, Green, Blue: Integer): TColorRef;
begin
Result := (Blue shl 16) or (Green shl 8) or Red;
end;
function GetBValue(Col: TColorRef): Integer;
begin
Result := (Col shr 16) and $FF;
end;
function GetGValue(Col: TColorRef): Integer;
begin
Result := (Col shr 8) and $FF;
end;
function GetRValue(Col: TColorRef): Integer;
begin
Result := Col and $FF;
end;
procedure MessageBeep(Value: Integer);
begin
Beep;
end;
{$IFDEF LINUX}
function GetTickCount: Cardinal;
var
Info: TSysInfo;
TimeVal: TTimeVal;
begin
sysinfo(Info);
gettimeofday(TimeVal, nil);
Result := Cardinal((Int64(Info.uptime) * 1000) + Round(TimeVal.tv_usec / 1000));
end;
function MakeIntResource(Value: Integer): PChar;
begin
Result := PChar(Value and $0000ffff);
end;
{$ENDIF LINUX}
function TruncatePath(const FilePath: string; Canvas: TCanvas; MaxLen: Integer): string;
const
Ellipses = '...';
var
Paths: TStrings;
k, i, start: Integer;
CurPath: string;
begin
if Canvas.TextWidth(FilePath) <= MaxLen then
Result := FilePath
else
begin // FilePath too long
Paths := TStringList.Create;
try
Paths.Delimiter := PathDelim;
Paths.DelimitedText := FilePath ; // splits the filepath
if Length(paths[0]) = 0 then
start := 1
else
start := 0;
for k := start to Paths.Count - 2 do
begin
CurPath := Paths[k] ;
if Length(CurPath) > 2 then // this excludes ~ ..
begin
Paths[k] := Ellipses ; // replace with ellipses
I := 1;
while Canvas.TextWidth(Paths.DelimitedText) <= MaxLen do
begin
Paths[k] := Copy(CurPath, I, MaxInt) + Ellipses; // add a character
Inc(I);
end;
if I <> 1 then
begin
// remove last added character
Paths[k] := Copy(Paths[k], 2, MaxInt);
Result := Paths.DelimitedText ; // something /.../P../bin/file.tst
Exit; // ready
end;
end
end;
// not succeeded.
// replace /.../.../.../<filename> with .../<filename>
// before starting to minimize filename
for k := Paths.count - 2 downto 1 do
Paths.Delete(k);
Paths[0] := Ellipses;
if Canvas.TextWidth(Paths.DelimitedText) > MaxLen then
begin
CurPath := Paths[1];
Paths[1] := Ellipses; // replace with ellipses
I := 1 ;
while Canvas.TextWidth(Paths.DelimitedText) <= MaxLen do
begin
Paths[1] := Copy(CurPath, I, MaxInt) + Ellipses;
Inc(I);
end;
if I <> 1 then
Paths[1] := Copy(Paths[1], 2, MaxInt);
end;
Result := Paths.DelimitedText; // will be something .../Progr...
finally
Paths.Free;
end;
end;
end;
function TruncateName(const Name: String; Canvas: TCanvas; MaxLen: Integer): string;
const
Ellipses = '...';
var
I: Integer;
begin
if Canvas.TextWidth(Name) <= MaxLen then
Result := Name
else
begin
Result := Ellipses ; // replace with ellipses
I := 1;
while Canvas.TextWidth(Result) <= MaxLen do
begin
Result := Copy(Name, I, MaxInt) + Ellipses; // add a character
Inc(I);
end;
if I <> 1 then
// remove last added character
Delete(Result, 1, 1);
end;
end;
{$ENDIF COMPLIB_CLX}
function ClxDrawText(Canvas: TCanvas; var Caption: string; var R: TRect;
Flags: Integer): Integer;
{$IFNDEF COMPLIB_VCL}
var W: WideString;
{$ENDIF}
begin
{$IFDEF COMPLIB_VCL}
Result := DrawText(Canvas.Handle, PChar(Caption), Length(Caption), R, Flags);
{$ELSE}
W := Caption;
Result := ClxDrawTextW(Canvas, W, R, Flags);
if Flags and DT_MODIFYSTRING <> 0 then
Caption := W;
{$ENDIF}
end;
function ClxDrawTextW(Canvas: TCanvas; var Caption: WideString; var R: TRect;
Flags: Integer): Integer;
{$IFDEF COMPLIB_CLX}
var
Flgs: Word;
Text: string;
{$ENDIF}
begin
{$IFDEF COMPLIB_VCL}
Result := DrawTextW(Canvas.Handle, PWideChar(Caption), Length(Caption), R, Flags);
{$ENDIF}
{$IFDEF COMPLIB_CLX}
Text := Caption;
with Canvas do
begin
Flgs := 0;
if Flags and DT_SINGLELINE <> 0 then
Flgs := SingleLine;
if Flags and DT_WORDBREAK <> 0 then
Flgs := Flgs or WordBreak;
if Flags and DT_EXPANDTABS <> 0 then
Flgs := Flgs or ExpandTabs;
if Flags and DT_NOPREFIX = 0 then
Flgs := Flgs or ShowPrefix;
if Flags and DT_RIGHT <> 0 then
Flgs := Flgs or AlignRight
else if Flags and DT_CENTER <> 0 then
Flgs := Flgs or AlignHCenter
else
Flgs := Flgs or AlignLeft ; // default
// vertical alignment
if Flags and DT_BOTTOM <> 0 then
Flgs := Flgs or AlignTop
else if Flags and DT_VCENTER <> 0 then
Flgs := Flgs or AlignVCenter
else
Flgs := Flgs or AlignTop; // default
if Flags and DT_ELLIPSIS <> 0 then
Text := TruncateName(Text, Canvas, R.Right - R.Left)
else if Flags and DT_PATH_ELLIPSIS <> 0 then
Text := TruncatePath(Text, Canvas, R.Right - R.Left)
else if Flags and DT_CALCRECT <> 0 then
begin
TextExtent(Caption, R, flgs);
Result := 1 ; //????
Exit;
end;
Canvas.TextRect(R, R.Left, R.Top, Text, Flgs);
if Flags and DT_MODIFYSTRING <> 0 then
Caption := Text;
end;
Result := 1;
{$ENDIF COMPLIB_CLX}
end;
function ClxExtTextOut(Canvas: TCanvas; X, Y: Integer; Flags: Integer; Rect: PRect;
const Text: String; lpDx: Pointer): Boolean;
begin
{$IFDEF COMPLIB_VCL}
Result := ExtTextOut(Canvas.Handle, X, Y, Flags, Rect, PChar(Text),
Length(Text), lpDx);
{$ELSE}
Result := ClxExtTextOutW(Canvas, X, Y, Flags, Rect, WideString(Text), lpDx);
{$ENDIF}
end;
function ClxExtTextOutW(Canvas: TCanvas; X, Y: Integer; Flags: Integer;
Rect: PRect; const Text: WideString; lpDx: Pointer): Boolean;
{$IFDEF COMPLIB_CLX}
{ missing feature: horizontal text alignment }
var
RecallBrush: TBrush;
RecallPenPos: TPoint;
Ch: WideChar;
Index, Width: Integer;
Dx: PInteger;
R, CellRect: TRect;
TextLen: Integer;
{$ENDIF}
begin
{$IFDEF COMPLIB_VCL}
Result := ExtTextOutW(Canvas.Handle, X, Y, Flags, Rect, PWideChar(Text),
Length(Text), lpDx);
{$ENDIF COMPLIB_VCL}
{$IFDEF COMPLIB_CLX}
with Canvas do
begin
Result := False;
if (Text = '') then
Exit;
if (Flags and ETO_CLIPPED <> 0) and (Rect = nil) then
Flags := Flags and not ETO_CLIPPED;
RecallPenPos := PenPos;
Result := True;
RecallBrush := nil;
try
if Flags and ETO_OPAQUE <> 0 then
begin
if Brush.Style <> bsSolid then
begin
RecallBrush := TBrush.Create;
RecallBrush.Assign(Brush);
Brush.Style := bsSolid;
end;
if Rect <> nil then
FillRect(Rect^);
end
else
if (Brush.Style = bsSolid) then
begin
RecallBrush := TBrush.Create;
RecallBrush.Assign(Brush);
Brush.Style := bsClear;
end;
if lpDx = nil then
begin
if (Flags and ETO_CLIPPED <> 0) then
TextRect(Rect^, X, Y, Text)
else
TextOut(X, Y, Text);
end
else
begin
// put each char in it's cell
TextLen := Length(Text);
if (Flags and ETO_OPAQUE <> 0) and (Rect = nil) then
begin
Dx := lpDx;
Width := 0;
for Index := 1 to TextLen do
begin
Inc(Width, Dx^);
Inc(Dx);
end;
R.Left := X;
R.Right := X + Width;
R.Top := Y;
R.Bottom := Y + TextHeight(Text);
FillRect(R);
end;
Dx := lpDx;
for Index := 1 to TextLen do
begin
if (Rect <> nil) and (X >= Rect^.Right) then
Break;
Ch := Text[Index];
if Flags and ETO_CLIPPED <> 0 then
begin
CellRect.Left := X;
CellRect.Right := X + Dx^;
CellRect.Top := Rect^.Top;
CellRect.Bottom := Rect^.Bottom;
if CellRect.Right > Rect^.Right then
CellRect.Right := Rect^.Right;
TextRect(R, X, Y, Ch);
end
else
TextOut(X, Y, Ch);
if Index = TextLen then
Break;
Inc(X, Dx^);
Inc(Dx);
end;
end;
finally
if Assigned(RecallBrush) then
begin
Brush.Assign(RecallBrush);
RecallBrush.Free;
end;
end;
PenPos := RecallPenPos;
end;
{$ENDIF COMPLIB_CLX}
end;
end.
--- NEW FILE: QWinCursors.pas ---
{-------------------------------------------------------------------------------------------------}
{ TWinCursor }
{ }
{ Copyright (c) 2002, Matthias Thoma (ma....@gm...) }
{ All rights reserved. }
{ }
{ Version 0.6 }
{ Supported: - Traditional cursors }
{ Not supported: - Multicolor cursors (as soon as QT3 is supported) }
{ - Animated cursors (maybe in feature) }
{ }
{ Thanks to Christoph Federer for Beta testing. }
{ }
{ Permission is hereby granted, free of charge, to any person obtaining a copy of this software }
{ and associated documentation files(the "Software"), to deal in the Software without restriction,}
{ including without limitation the rights to use, copy, modify, merge, publish, distribute, }
{ sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is }
{ furnished to do so, subject to the following conditions: }
{ }
{ The above copyright notice and this permission notice shall be included in all copies or }
{ substantial portions of the Software. }
{ }
{ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING }
{ BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND }
{ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, }
{ DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, }
{ OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. }
{-------------------------------------------------------------------------------------------------}
unit QWinCursors;
{$R-}
interface
uses
Classes, SysUtils, Types,
Qt, QGraphics, QTypes;
type
TCurInvMode=(invBlack, invWhite, invTransparent);
type
TWinCursor = class(TGraphic)
private
FHandle: QCursorH;
FWidth: Integer;
FHeight: Integer;
FBytesPerRow: Word;
FOwnsHandle: Boolean;
FInvMode: TCurInvMode;
FHotspot: TPoint;
FCustomCursor: record
Bits: array of Byte;
Mask: array of Byte;
end;
protected
procedure ConvertDIB(Stream: TStream);
procedure CreateCursor;
procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
procedure FreeCursor;
function GetHotSpot: TPoint;
function GetEmpty: Boolean; override;
function GetHeight: Integer; override;
function GetWidth: Integer; override;
procedure HandleNeeded;
procedure SetHeight(Value: Integer); override;
procedure SetHotspot(const Value: TPoint); virtual;
procedure SetWidth(Value: Integer); override;
public
property Handle: QCursorH read FHandle;
property Height: Integer read FHeight;
property Hotspot: TPoint read GetHotspot write SetHotspot;
property InvMode: TCurInvMode read FInvMode write FInvMode;
property Width: Integer read FWidth;
constructor Create; reintroduce; overload;
constructor Create(AHandle: QCursorH); reintroduce; overload;
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
procedure LoadFromStream(Stream: TStream); override;
procedure LoadFromMimeSource(MimeSource: TMimeSource); override;
procedure LoadFromResourceName(Instance: Cardinal; ResourceName: string);
procedure OwnHandle;
procedure SaveToMimeSource(MimeSource: TClxMimeSource); override;
procedure SaveToStream(Stream: TStream); override;
function ReleaseHandle: QCursorH;
end;
function LoadCursor(Instance: Cardinal; CursorName: string): QCursorH;
function LoadCursorFromFile(CursorFileName: string): QCursorH;
type
EWinCursor = class(Exception);
implementation
resourcestring
RsUnsupported = 'Unsupported or illegal format.';
RsInvalidOperation = 'Invalid operation.';
type
_CURSORDIRENTRY = packed record
bWidth: Byte;
bHeight: Byte;
bColorCount: Byte;
bReserved: Byte;
wXHotspot: Word;
wYHotspot: Word;
lBytesInRes: DWORD;
dwImageOffset: DWORD;
end;
TCURSORDIRENTRY = _CURSORDIRENTRY;
PCURSORDIRENTRY = ^_CURSORDIRENTRY;
_CURSORDIR = packed record
cdReserved: WORD;
cdType: WORD;
cdCount: WORD;
end;
TCURSORDIR = _CURSORDIR;
PCURSORDIR = ^_CURSORDIR;
TResCursorDir = packed record
Width: Word;
Height: Word;
Planes: Word;
BitCount: Word;
BytesInRes: DWORD;
IconCursorId: Word;
end;
type
TCustomCursor = record
Bits: array of Byte;
Mask: array of Byte;
end;
type
tagLocalHeader = packed record
XHotSpot: Word;
YHotSpot: Word;
Reserved: Int64;
end;
{ TWinCursor }
constructor TWinCursor.Create;
begin
inherited Create;
FHandle := nil;
FWidth := 0;
FHeight := 0;
FBytesPerRow := 0;
FOwnsHandle := False;
FInvMode := InvTransparent;
end;
//------------------------------------------------------------------------------
constructor TWinCursor.Create(AHandle: QCursorH);
begin
inherited Create;
FHandle := AHandle;
FOwnsHandle := False;
end;
//------------------------------------------------------------------------------
destructor TWinCursor.Destroy;
begin
if FOwnsHandle then
FreeCursor;
inherited Destroy;
end;
//------------------------------------------------------------------------------
procedure TWinCursor.LoadFromResourceName(Instance: Cardinal; ResourceName: String);
var
ResourceStream: TResourceStream;
CURSORDIR: TCURSORDIR;
ResDir: TResCursorDir;
BmpInfo: TBITMAPINFOHEADER;
localHeader: tagLocalHeader;
begin
ResourceStream := TResourceStream.Create(Instance, ResourceName, PChar(12));
try
ResourceStream.ReadBuffer(CursorDir, sizeof(TCursorDir));
if (CursorDir.cdReserved <> 0) or (CursorDir.cdType <> 2) or (CursorDir.cdCount <> 1) then
raise EWinCursor.Create(RsUnsupported);
ResourceStream.ReadBuffer(ResDir, sizeof(TResCursorDir));
FWidth := ResDir.Width;
FHeight := ResDir.Height div 2;
finally
ResourceStream.Free;
end;
ResourceStream := TResourceStream.CreateFromID(HInstance, ResDir.IconCursorId, PChar(1));
try
ResourceStream.Position := 0;
ResourceStream.Read(LocalHeader, sizeof(tagLocalHeader));
FBytesPerRow := FWidth div 8;
if (FWidth mod 8) <> 0 then
Inc(FBytesPerRow);
ResourceStream.Read(BmpInfo, sizeof(BmpInfo)); // Ingore BmpInfo
SetLength(FCustomCursor.Bits, FBytesPerRow * FHeight);
SetLength(FCustomCursor.Mask, FBytesPerRow * FHeight);
ConvertDIB(ResourceStream);
CreateCursor;
finally
ResourceStream.Free;
SetLength(FCustomCursor.Bits, 0);
SetLength(FCustomCursor.Mask, 0);
end;
end;
//--------------------------------------------------------------------------------------------------
procedure TWinCursor.LoadFromStream(Stream: TStream);
var
CURSORDIR: TCURSORDIR;
Entry: TCURSORDIRENTRY;
BitmapInfo: TBITMAPINFOHEADER;
begin
Stream.ReadBuffer(CursorDir, sizeof(TCursorDir));
if (CursorDir.cdReserved <> 0) or (CursorDir.cdType <> 2) or (CursorDir.cdCount <> 1) then
raise EWinCursor.Create(RsUnsupported);
Stream.Read(Entry, sizeof(TCURSORDIRENTRY));
Stream.Seek(Entry.dwImageOffset, soFromBeginning);
Stream.Read(BitmapInfo, sizeof(TBITMAPINFOHEADER));
with Entry do
begin
FWidth := bWidth;
FHeight := bHeight;
FHotspot.X := wXHotspot;
FHotspot.Y := wYHotspot
end;
Stream.Seek(8, soFromCurrent);
FBytesPerRow := FWidth div 8;
if (FWidth mod 8) <> 0 then
Inc(FBytesPerRow);
SetLength(FCustomCursor.Bits, FBytesPerRow * FHeight);
SetLength(FCustomCursor.Mask, FBytesPerRow * FHeight);
ConvertDib(Stream);
CreateCursor;
end;
{------------------------------------------------------------------------------}
{ }
{ Convert Table }
{ }
{ And Xor Bitmap Mask }
{ Black 0 0 1 1 }
{ White 0 1 => 0 1 }
{ Transparent 1 0 0 0 }
{ }
{ Inverse 1 1 0 0 Transparent }
{ Inverse 1 1 1 1 Black }
{ Inverse 1 1 0 1 White }
{ }
{ Inv > Transparent: => Bitmap := not("AND" or "XOR") }
{ => Mask := not "AND" }
{ }
{ Inv > Black: => Bitmap := not("AND" xor "XOR") }
{ => Mask := not "AND" or "XOR" }
{ }
{ Inv > White: => Bitmap := not("AND" or "XOR") }
{ => Mask := not(("XOR" xor "AND") and "AND") }
{ }
{------------------------------------------------------------------------------}
procedure TWinCursor.ConvertDIB(Stream: TStream);
var
TempCursor: TCustomCursor;
AndByte, XOrByte: Byte;
i: Integer;
t: Integer;
begin
SetLength(TempCursor.Bits, FBytesPerRow * FHeight);
SetLength(TempCursor.Mask, FBytesPerRow * FHeight);
Stream.ReadBuffer(TempCursor.Mask[0], FHeight*FBytesPerRow);
Stream.ReadBuffer(TempCursor.Bits[0], FHeight*FBytesPerRow);
for i := 0 to FHeight - 1 do
begin
for t := 0 to FBytesPerRow - 1 do
begin
AndByte := TempCursor.Bits[i*FBytesPerRow+t];
XorByte := TempCursor.Mask[i*FBytesPerRow+t];
case FInvMode of
invBlack: begin
FCustomCursor.Bits[(FHeight-1-i) * FBytesPerRow + t] := not(XorByte xor AndByte);
FCustomCursor.Mask[(FHeight-1-i) * FBytesPerRow + t] := not AndByte or XorByte;
end;
invWhite: begin
FCustomCursor.Bits[(FHeight-1-i) * FBytesPerRow + t] := not(XorByte or AndByte);
FCustomCursor.Mask[(FHeight-1-i) * FBytesPerRow + t] := not((XorByte xor AndByte) and AndByte);
end;
invTransparent: begin
FCustomCursor.Bits[(FHeight-1-i) * FBytesPerRow + t] := not(XorByte or AndByte);
FCustomCursor.Mask[(FHeight-1-i) * FBytesPerRow + t] := not(AndByte);
end;
end;
end;
end;
end;
//--------------------------------------------------------------------------------------------------
procedure TWinCursor.CreateCursor;
var
Bitmap: QBitmapH;
Mask: QBitmapH;
begin
if Assigned(FHandle) and FOwnsHandle then
QCursor_destroy(FHandle);
Bitmap := QBitmap_create(FBytesPerRow*8,FHeight, @FCustomCursor.Bits[0], False);
Mask := QBitmap_create(FBytesPerRow*8,FHeight, @FCustomCursor.Mask[0], False);
if (FWidth mod 8) <> 0 then
begin
QPixmap_resize(Bitmap, FWidth, FHeight);
QPixmap_resize(Mask, FWidth, FHeight);
end;
FHandle := QCursor_create(Bitmap, Mask, FHotspot.X, FHotspot.Y);
QBitmap_Destroy(Bitmap);
QBitmap_Destroy(Mask);
Changed(self);
end;
//--------------------------------------------------------------------------------------------------
procedure TWinCursor.OwnHandle;
begin
FOwnsHandle := True;
end;
//--------------------------------------------------------------------------------------------------
function TWinCursor.ReleaseHandle: QCursorH;
begin
Result := FHandle;
FHandle := nil;
Changed(Self);
end;
//--------------------------------------------------------------------------------------------------
procedure TWinCursor.HandleNeeded;
begin
if FHandle = nil then
begin
FHandle := QCursor_create;
OwnHandle;
end;
end;
//--------------------------------------------------------------------------------------------------
function TWinCursor.GetHotSpot: TPoint;
begin
Result := Point(0,0);
if Assigned(FHandle) then
QCursor_hotSpot(FHandle, @Result);
end;
//--------------------------------------------------------------------------------------------------
procedure TWinCursor.SetHotspot(const Value: TPoint);
var
TempHandle: QCursorH;
begin
if Assigned(FHandle) then
begin
TempHandle := QCursor_create(QCursor_bitmap(FHandle), QCursor_bitmap(FHandle), Value.X, Value.Y);
if FOwnsHandle then
QCursor_destroy(FHandle);
FHandle := TempHandle;
OwnHandle;
end;
end;
//--------------------------------------------------------------------------------------------------
procedure TWinCursor.FreeCursor;
begin
if Assigned(FHandle) then
begin
QCursor_destroy(FHandle);
FHandle := nil;
FWidth := 0;
FHeight := 0;
FBytesPerRow := 0;
SetLength(FCustomCursor.Bits, 0);
SetLength(FCustomCursor.Mask, 0);
end;
end;
//--------------------------------------------------------------------------------------------------
procedure TWinCursor.Assign(Source: TPersistent);
begin
if FOwnsHandle then
FreeCursor;
if Source is TWinCursor then
begin
FHandle := QCursor_create((Source as TWinCursor).Handle);
OwnHandle;
end
else
inherited Assign(Source);
end;
//--------------------------------------------------------------------------------------------------
procedure TWinCursor.LoadFromMimeSource(MimeSource: TMimeSource);
begin
raise EInvalidGraphicOperation.Create(RsInvalidOperation);
end;
//--------------------------------------------------------------------------------------------------
procedure TWinCursor.SaveToMimeSource(MimeSource: TClxMimeSource);
begin
raise EInvalidGraphicOperation.Create(RsInvalidOperation);
end;
//--------------------------------------------------------------------------------------------------
procedure TWinCursor.SaveToStream(Stream: TStream);
begin
raise EInvalidGraphicOperation.Create(RsInvalidOperation);
end;
//--------------------------------------------------------------------------------------------------
function TWinCursor.GetEmpty: Boolean;
begin
Result := not Assigned(FHandle);
end;
//--------------------------------------------------------------------------------------------------
function TWinCursor.GetHeight: Integer;
begin
Result := FHeight;
end;
//--------------------------------------------------------------------------------------------------
function TWinCursor.GetWidth: Integer;
begin
Result := FWidth;
end;
//--------------------------------------------------------------------------------------------------
procedure TWinCursor.SetHeight(Value: Integer);
begin
raise EInvalidGraphicOperation.Create(RsInvalidOperation);
end;
//--------------------------------------------------------------------------------------------------
procedure TWinCursor.SetWidth(Value: Integer);
begin
raise EInvalidGraphicOperation.Create(RsInvalidOperation);
end;
//--------------------------------------------------------------------------------------------------
type
TCrackBitmap = class(TBitmap);
procedure TWinCursor.Draw(ACanvas: TCanvas; const Rect: TRect);
var
Bitmap: TCrackBitmap;
Pixmap: QPixmapH;
begin
if not Empty then
begin
Bitmap := TCrackBitmap.Create;
try
Bitmap.Width := FWidth;
Bitmap.Height := FHeight;
Pixmap := QPixmap_create(QCursor_bitmap(FHandle));
QPixmap_setMask(Pixmap,QCursor_mask(FHandle));
Bitmap.Handle := Pixmap;
Bitmap.Draw(ACanvas, Rect);
finally
Bitmap.Free;
end;
end;
end;
//------------------------------------------------------------------------------
// Helper functions
//------------------------------------------------------------------------------
{ LoadCursor Helper function }
{ ========================== }
{ }
{ If you are using this function with D6/CLX please be aware that it might }
{ collidate with the Windows LoadCursor function. In such cases reference it }
{ directly using QWinCursors.LoadCursor }
function LoadCursor(Instance: Cardinal; CursorName: string): QCursorH;
var
WinCursor: TWinCursor;
begin
WinCursor := TWinCursor.Create;
try
WinCursor.LoadFromResourceName(Instance, CursorName);
Result := WinCursor.ReleaseHandle;
finally
WinCursor.Free;
end;
end;
function LoadCursorFromFile(CursorFileName: string): QCursorH;
var
WinCursor: TWinCursor;
begin
WinCursor := TWinCursor.Create;
try
WinCursor.LoadFromFile(CursorFileName);
Result := WinCursor.ReleaseHandle;
finally
WinCursor.Free;
end;
end;
end.
|