paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-12-05 14:37:11 +01:00
Code Issues Packages Projects Releases Wiki Activity

Start of the set of custom drawn components

Browse Source 
git-svn-id: trunk@26755 -
This commit is contained in:
sekelsenmat 2010-07-20 22:13:35 +00:00
parent 7143cf99a8
commit 29c1791a5a
3 changed files with 228 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -608,6 +608,8 @@ components/compilers/javascript/examples/ReadJSClassesXML.lpi svneol=native#text
components/compilers/javascript/examples/ReadJSClassesXML.lpr svneol=native#text/plain
components/compilers/javascript/examples/jsclassxmlread.pas svneol=native#text/plain
components/custom/README.txt svneol=native#text/plain
components/customdrawn/customdrawn.lpk svneol=native#text/plain
components/customdrawn/customdrawncontrols.pas svneol=native#text/plain
components/customform/custforms.pp svneol=native#text/plain
components/customform/demo/appform.pas svneol=native#text/plain
components/customform/demo/appforms.lpk svneol=native#text/plain

46
components/customdrawn/customdrawn.lpk Normal file
View File

@ -0,0 +1,46 @@
<?xml version="1.0"?>
<CONFIG>
<Package Version="3">
<PathDelim Value="\"/>
<Name Value="customdrawn"/>
<CompilerOptions>
<Version Value="8"/>
<PathDelim Value="\"/>
<SearchPaths>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)\"/>
</SearchPaths>
<Parsing>
<SyntaxOptions>
<UseAnsiStrings Value="True"/>
</SyntaxOptions>
</Parsing>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Files Count="1">
<Item1>
<Filename Value="customdrawncontrols.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="customdrawncontrols"/>
</Item1>
</Files>
<Type Value="RunAndDesignTime"/>
<RequiredPkgs Count="2">
<Item1>
<PackageName Value="LCL"/>
</Item1>
<Item2>
<PackageName Value="FCL"/>
<MinVersion Major="1" Valid="True"/>
</Item2>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
<IgnoreBinaries Value="False"/>
</PublishOptions>
</Package>
</CONFIG>

180
components/customdrawn/customdrawncontrols.pas Normal file
View File

@ -0,0 +1,180 @@
{
Copyright (C) 2010 Felipe Monteiro de Carvalho
License: The same modifying LGPL with static linking exception as the LCL
This unit should be a repository for various custom drawn components,
such as a custom drawn version of TButton, of TEdit, of TPageControl, etc,
eventually forming a full set of custom drawn components.
}
unit customdrawncontrols;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Graphics, Controls, LCLType, LCLIntf;
type
TBitmappedButtonOption = (bboCheckable, bboUseImageForSelection,
bboUseImageForMouseOver);
TBitmappedButtonOptions = set of TBitmappedButtonOption;
TBitmappedButtonState = (bbsNormal, bbsDown, bbsMouseOver,
bbsSelected, bbsChecked, bbsCheckedSelected, bbsCheckedDown { is going to be unchecked });
{ TCustomBitmappedButton }
TCustomBitmappedButton = class(TCustomControl)
private
FOnChange: TNotifyEvent;
protected
FImageBtn: TBitmap;
FImageBtnDown: TBitmap;
FImageBtnMouseOver: TBitmap;
FImageBtnSelected: TBitmap;
FImageBtnChecked: TBitmap;
FOptions: TBitmappedButtonOptions;
FState: TBitmappedButtonState;
// keyboard
// procedure DoEnter; override;
// procedure DoExit; override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure KeyUp(var Key: Word; Shift: TShiftState); override;
// mouse
procedure Click; override;
procedure DblClick; override;
procedure MouseDown(Button: TMouseButton; Shift:TShiftState; X,Y:Integer); override;
procedure MouseUp(Button: TMouseButton; Shift:TShiftState; X,Y:Integer); override;
procedure MouseEnter; override;
procedure MouseLeave; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure EraseBackground(DC: HDC); override;
procedure Paint; override;
function GetStateBitmap(): TBitmap;
// Properties
property ImageBtn: TBitmap read FImageBtn;
property ImageBtnDown: TBitmap read FImageBtnDown;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end;
TBitmappedButton = class(TCustomBitmappedButton)
published
property ImageBtn: TBitmap;
property ImageBtnDown: TBitmap;
{ FImageBtnMouseOver: TBitmap;
FImageBtnSelected: TBitmap;
FImageBtnChecked: TBitmap;
FOptions: TBitmappedButtonOptions;}
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Common Controls', [TBitmappedButton]);
end;
{ TCustomBitmappedButton }
procedure TCustomBitmappedButton.KeyDown(var Key: Word; Shift: TShiftState);
begin
inherited KeyDown(Key, Shift);
end;
procedure TCustomBitmappedButton.KeyUp(var Key: Word; Shift: TShiftState);
begin
inherited KeyUp(Key, Shift);
end;
procedure TCustomBitmappedButton.Click;
begin
inherited Click;
end;
procedure TCustomBitmappedButton.DblClick;
begin
inherited DblClick;
end;
procedure TCustomBitmappedButton.MouseDown(Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
NewState: TBitmappedButtonState;
begin
case FState of
bbsNormal, bbsSelected: NewState := bbsDown;
bbsChecked, bbsCheckedSelected: NewState := bbsCheckedDown;
end;
if NewState <> FState then
begin
FState := NewState;
Invalidate;
end;
inherited MouseDown(Button, Shift, X, Y);
end;
procedure TCustomBitmappedButton.MouseUp(Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
inherited MouseUp(Button, Shift, X, Y);
end;
procedure TCustomBitmappedButton.MouseEnter;
begin
inherited MouseEnter;
end;
procedure TCustomBitmappedButton.MouseLeave;
begin
inherited MouseLeave;
end;
constructor TCustomBitmappedButton.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
end;
destructor TCustomBitmappedButton.Destroy;
begin
if Assigned(FImageBtn) then FImageBtn.Free;
if Assigned(FImageBtnDown) then FImageBtnDown.Free;
if Assigned(FImageBtnMouseOver) then FImageBtnMouseOver.Free;
if Assigned(FImageBtnSelected) then FImageBtnSelected.Free;
if Assigned(FImageBtnChecked) then FImageBtnChecked.Free;
inherited Destroy;
end;
procedure TCustomBitmappedButton.EraseBackground(DC: HDC);
begin
// The correct implementation is doing nothing
end;
procedure TCustomBitmappedButton.Paint;
begin
Canvas.Draw(0, 0, GetStateBitmap());
end;
function TCustomBitmappedButton.GetStateBitmap(): TBitmap;
begin
case FState of
bbsNormal: Result := FImageBtn;
bbsDown: Result := FImageBtnDown;
bbsMouseOver: Result := FImageBtnMouseOver;
bbsSelected: Result := FImageBtnSelected;
bbsChecked: Result := FImageBtnChecked;
end;
end;
end.