paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-28 09:01:33 +02:00
Code Issues Packages Projects Releases Wiki Activity

GridExamples: Add demo for embedding images into a grid

Browse Source 
git-svn-id: trunk@54978 -
This commit is contained in:
wp 2017-05-18 20:53:49 +00:00
parent 7f78bf4c33
commit ec9f1ff081
5 changed files with 640 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.gitattributes vendored
View File

@ -5670,6 +5670,10 @@ examples/gridexamples/columneditors/main.pas svneol=native#text/plain
examples/gridexamples/columneditors/readme.txt svneol=native#text/plain examples/gridexamples/columneditors/readme.txt svneol=native#text/plain
examples/gridexamples/columneditors/stringgrideditor.lpi svneol=native#text/plain examples/gridexamples/columneditors/stringgrideditor.lpi svneol=native#text/plain
examples/gridexamples/columneditors/stringgrideditor.lpr svneol=native#text/plain examples/gridexamples/columneditors/stringgrideditor.lpr svneol=native#text/plain
examples/gridexamples/embedded_images/images.lpi svneol=native#text/plain
examples/gridexamples/embedded_images/images.lpr svneol=native#text/plain
examples/gridexamples/embedded_images/imgmain.lfm svneol=native#text/plain
examples/gridexamples/embedded_images/imgmain.pas svneol=native#text/plain
examples/gridexamples/grid_semaphor/TSemaphorDBGrid.xpm -text svneol=native#image/x-xpixmap examples/gridexamples/grid_semaphor/TSemaphorDBGrid.xpm -text svneol=native#image/x-xpixmap
examples/gridexamples/grid_semaphor/example/project1.lpi svneol=native#text/plain examples/gridexamples/grid_semaphor/example/project1.lpi svneol=native#text/plain
examples/gridexamples/grid_semaphor/example/project1.lpr svneol=native#text/pascal examples/gridexamples/grid_semaphor/example/project1.lpr svneol=native#text/pascal

78
examples/gridexamples/embedded_images/images.lpi Normal file
View File

@ -0,0 +1,78 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="10"/>
<PathDelim Value="\"/>
<General>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="images"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
</General>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
</local>
</RunParams>
<RequiredPackages Count="1">
<Item1>
<PackageName Value="LCL"/>
</Item1>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="images.lpr"/>
<IsPartOfProject Value="True"/>
</Unit0>
<Unit1>
<Filename Value="imgmain.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="Form1"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="imgMain"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="images"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Debugging>
<UseExternalDbgSyms Value="True"/>
</Debugging>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

21
examples/gridexamples/embedded_images/images.lpr Normal file
View File

@ -0,0 +1,21 @@
program images;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms, imgMain
{ you can add units after this };
{$R *.res}
begin
RequireDerivedFormResource := True;
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

117
examples/gridexamples/embedded_images/imgmain.lfm Normal file
View File

@ -0,0 +1,117 @@
object Form1: TForm1
Left = 280
Height = 569
Top = 130
Width = 861
Caption = 'Form1'
ClientHeight = 569
ClientWidth = 861
OnCreate = FormCreate
LCLVersion = '1.9.0.0'
object Panel1: TPanel
Left = 0
Height = 36
Top = 510
Width = 861
Align = alBottom
ClientHeight = 36
ClientWidth = 861
TabOrder = 0
object Button1: TButton
Left = 9
Height = 25
Top = 4
Width = 246
AutoSize = True
Caption = 'Load new image && anchor at selected cell'
OnClick = Button1Click
TabOrder = 0
end
object SpinEdit1: TSpinEdit
AnchorSideLeft.Control = Label2
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = Button1
AnchorSideTop.Side = asrCenter
Left = 490
Height = 23
Top = 5
Width = 74
Alignment = taRightJustify
BorderSpacing.Left = 8
MinValue = -100
TabOrder = 1
end
object SpinEdit2: TSpinEdit
AnchorSideLeft.Control = Label3
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = Button1
AnchorSideTop.Side = asrCenter
Left = 594
Height = 23
Top = 5
Width = 80
Alignment = taRightJustify
BorderSpacing.Left = 8
MinValue = -100
TabOrder = 2
end
object Label1: TLabel
AnchorSideLeft.Control = Button1
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = Button1
AnchorSideTop.Side = asrCenter
Left = 271
Height = 15
Top = 9
Width = 190
BorderSpacing.Left = 16
Caption = 'Image offset with respect to anchor:'
ParentColor = False
end
object Label2: TLabel
AnchorSideLeft.Control = Label1
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = Label1
Left = 477
Height = 15
Top = 9
Width = 5
BorderSpacing.Left = 16
Caption = 'x'
ParentColor = False
end
object Label3: TLabel
AnchorSideLeft.Control = SpinEdit1
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = Button1
AnchorSideTop.Side = asrCenter
Left = 580
Height = 15
Top = 9
Width = 6
BorderSpacing.Left = 16
Caption = 'y'
ParentColor = False
end
end
object StatusBar1: TStatusBar
Left = 0
Height = 23
Top = 546
Width = 861
Panels = <>
end
object Panel2: TPanel
Left = 0
Height = 26
Top = 0
Width = 861
Align = alTop
Caption = 'Hold CTRL down and drag the images with the left mouse button to a new location'
TabOrder = 2
end
object OpenDialog1: TOpenDialog
left = 137
top = 93
end
end

420
examples/gridexamples/embedded_images/imgmain.pas Normal file
View File

@ -0,0 +1,420 @@
unit imgMain;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, Grids,
ExtCtrls, StdCtrls, LMessages, Spin, ComCtrls;
type
{ TImageData is stored in the list FImageList of the modified string grid and
contains the image bitmap as well information on the position of the image. }
TImageData = class
Bitmap: TBitmap; // Bitmap to be overlayed
Col, Row: Integer; // Anchor of the bitmap in the grid
dx, dy: Integer; // Offset with respect to anchor, in pixels
destructor Destroy; override;
end;
{ Events for image clicking and moving }
TImageClickEvent = procedure(Sender: TObject; AShift: TShiftState;
AImageIndex, X, Y: Integer) of object;
TImageMoveEvent = procedure(Sender: TObject; AShift: TShiftState;
AImageIndex, dx, dy: Integer) of object;
{ Modified StringGrid with support of embedded images }
TStringGridEx = class(TStringGrid)
private
FImageList: TFPlist;
FMouseImgIndex: Integer;
FMouseDownPt: TPoint;
FOnImageClick: TImageCLickEvent;
FOnImageMove: TImageMoveEvent;
protected
procedure DoImageClick(Shift: TShiftState; X, Y: Integer); virtual;
procedure DoImageMove(Shift: TShiftState; dx, dy: Integer); virtual;
procedure DrawAllRows; override;
procedure MouseDown(Button: TMouseButton; Shift:TShiftState; X,Y:Integer); override;
procedure MouseMove(Shift: TShiftState; X,Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift:TShiftState; X,Y:Integer); override;
procedure WMHScroll(var message : TLMHScroll); message LM_HSCROLL;
procedure WMVScroll(var message : TLMVScroll); message LM_VSCROLL;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure AddImage(APicture: TPicture; ACol, ARow: Integer; dx, dy: Integer;
AWidth: Integer = 0);
function GetImageRect(AImageIndex: Integer): TRect;
procedure MoveImageBy(AImageIndex, dx, dy: Integer);
function PointInImage(APoint: TPoint): Integer;
procedure UpdateImageAnchor(AImageIndex: Integer);
published
property OnImageClick: TImageClickEvent read FOnImageClick write FOnImageClick;
property OnImageMove: TImageMoveEvent read FOnImageMove write FOnImageMove;
end;
type
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
OpenDialog1: TOpenDialog;
Panel1: TPanel;
Panel2: TPanel;
SpinEdit1: TSpinEdit;
SpinEdit2: TSpinEdit;
StatusBar1: TStatusBar;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
Grid: TStringGridEx;
procedure AddImageFromFile(AFileName: String; ACol, ARow: Integer;
dx, dy: Integer; AScaledSize: Integer = 0);
procedure ImageClickHandler(Sender: TObject; Shift: TShiftState;
AImageIndex, X, Y: Integer);
procedure ImageMoveHandler(Sender: TObject; Shift: TShiftState;
AImageIndex, dX, dY: Integer);
public
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
uses
Types, LCLIntf;
const
JPEG_FILE = '../../../images/splash_source/cheetah.jpg';
PNG_FILE1 = '../../../images/codetoolsdefines/da_block.png';
PNG_FILE2 = '../../../images/icons/lazarus256x256.png';
{ TForm1 }
procedure TForm1.AddImageFromFile(AFileName: String; ACol, ARow, dx, dy: Integer;
AScaledSize: Integer = 0);
// AScaledSize = 0 means: no size scaling
var
pic: TPicture;
begin
pic := TPicture.Create;
try
pic.LoadFromFile(AFileName);
Grid.AddImage(pic, ACol, ARow, dx, dy, AScaledSize);
finally
pic.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
AddImageFromFile(OpenDialog1.FileName, Grid.Col, Grid.Row, SpinEdit1.Value, SpinEdit2.Value);
end;
procedure TForm1.FormCreate(Sender: TObject);
var
i: Integer;
begin
Grid := TStringGridEx.Create(self);
Grid.Parent := self;
Grid.Align := alClient;
Grid.RowCount := 13; //100;
Grid.ColCount := 10; //30;
Grid.Options := Grid.Options + [goThumbTracking, goColSizing, goRowSizing, goEditing];
Grid.MouseWheelOption := mwGrid;
Grid.Col := 3;
Grid.Row := 16;
Grid.OnImageClick := @ImageClickHandler;
Grid.OnImageMove := @ImageMoveHandler;
for i:=1 to Grid.ColCount-1 do
Grid.Cells[i, 0] := 'column ' + IntToStr(i);
for i:=1 to Grid.RowCount-1 do
Grid.Cells[0, i] := 'row ' + IntToStr(i);
ActiveControl := Grid;
// col row dx dy width
AddImageFromFile(JPEG_FILE, 1, 1, 5, 5, 300); // Offset by 5 pixels, scaled to width 300
AddImageFromFile(PNG_FILE1, 2, 12, 0, 0);
AddImageFromFile(PNG_FILE2, 5, 2, 0, 0);
end;
procedure TForm1.ImageClickHandler(Sender: TObject; Shift: TShiftState;
AImageIndex, X, Y: Integer);
begin
Statusbar1.SimpleText := Format('Image #%d clicked at x = %d, y = %d', [AImageIndex, X, Y]);
end;
procedure TForm1.ImageMoveHandler(Sender: TObject; Shift: TShiftState;
AImageIndex, dX, dY: Integer);
begin
if [ssLeft, ssCtrl] * Shift = [ssLeft, ssCtrl] then begin
// Moves the image by dx, dy pixels
Grid.MoveImageBy(AImageIndex, dx, dy);
// Resets the image anchor such that the top-left image corner is contained
// in the anchor cell.
Grid.UpdateImageAnchor(AImageIndex);
end;
end;
{ TImageData }
destructor TImageData.Destroy;
begin
Bitmap.Free;
inherited;
end;
{ Modified TStringGrid }
constructor TStringGridEx.Create(AOwner: TComponent);
begin
inherited;
FImageList := TFPList.Create;
end;
destructor TStringGridEx.Destroy;
var
j: Integer;
begin
for j:=0 to FImageList.Count-1 do
TImageData(FImageList[j]).Free;
FImageList.Free;
inherited;
end;
{ Adds a new image to the image list. ACol and ARow indicate the column and
row index of the anchor cell to which the image is attached. If the left or
top edge of the anchor cell is moved then the image follows. The image can
be shifted by dx and dy pixels from the top left corner of the anchor cell.
AWidth defines the width of the image in pixels; the image is automatically
rescaled. If AWidth is missing (or 0) the original size of the image is used.}
procedure TStringGridEx.AddImage(APicture: TPicture; ACol, ARow: Integer;
dx, dy: Integer; AWidth: Integer = 0);
var
bmp: TBitmap;
imgdata: TImageData;
begin
bmp := TBitmap.Create;
if AWidth <= 0 then begin
// Keep original image size
bmp.Width := APicture.Width;
bmp.Height := APicture.Height;
end else begin
// Scale image
bmp.Width := AWidth;
bmp.Height := round(bmp.Width / APicture.Width * APicture.Height);
end;
bmp.PixelFormat := pf32Bit;
bmp.Canvas.Brush.Color := clWhite;
bmp.Canvas.FillRect(0, 0, bmp.Width, bmp.Height);
bmp.Canvas.StretchDraw(Rect(0, 0, bmp.Width, bmp.Height), APicture.Graphic);
imgData := TImageData.Create;
imgData.Bitmap := bmp;
imgData.Col := ACol;
imgData.Row := ARow;
imgData.dx := dx;
imgData.dy := dy;
FImageList.Add(imgData);
Invalidate;
end;
procedure TStringGridEx.DoImageClick(Shift: TShiftState; X, Y: Integer);
begin
if Assigned(FOnImageClick) then
FOnImageClick(self, Shift, FMouseImgIndex, X, Y);
end;
procedure TStringGridEx.DoImageMove(Shift: TShiftState; dx, dy: Integer);
begin
if Assigned(FOnImageMove) then
FOnImageMove(self, Shift, FMouseImgIndex, dx, dy);
end;
procedure TStringGridEx.DrawAllRows;
var
imgdata: TImagedata;
i: Integer;
clipArea: TRect;
ImgRect: TRect;
R: TRect;
tmp: Integer;
begin
inherited;
// Calculate the clip area, i.e. the rectangle enclosing the non-fixed cells...
clipArea := Canvas.ClipRect;
ColRowToOffset(true, false, FixedCols, clipArea.Left, tmp);
ColRowToOffset(false, false, FixedRows, clipArea.Top, tmp);
Canvas.SaveHandleState;
try
// ... and use it for clipping
IntersectClipRect(Canvas.Handle, clipArea.Left, clipArea.Top, clipArea.Right, clipArea.Bottom);
for i := 0 to FImageList.Count-1 do begin
// Get bounding rectangle of the image
imgRect := GetImageRect(i);
// Calculate the intersection of the image rectangle with the clip rectangle
// Nothing to do if the image rectangle does not intersect the clip rectangle
if not IntersectRect(R, clipArea, imgRect) then
continue;
imgdata := TImageData(FImageList[i]);
Canvas.Draw(imgRect.Left, imgRect.Top, imgData.Bitmap);
end;
finally
Canvas.RestoreHandlestate;
end;
end;
{ Extracts, in pixels, the bounding rectangle of the image with the
specified index }
function TStringGridEx.GetImageRect(AImageIndex: Integer): TRect;
var
imgdata: TImageData;
begin
if (AImageIndex >= 0) and (AImageIndex < FImageList.Count) then
begin
// Extract image data from image list
imgdata := TImageData(FImageList[AImageIndex]);
// Find coordinates of cell anchor
Result := CellRect(imgdata.Col, imgdata.Row);
// Fix size of the image rectangle
Result.Right := Result.Left + imgData.Bitmap.Width;
Result.Bottom := Result.Top + imgData.Bitmap.Height;
// Shift image to final position
OffsetRect(Result, imgdata.dx, imgdata.dy);
end else
Result := Rect(0, 0, 0, 0);
end;
procedure TStringGridEx.MouseDown(Button: TMouseButton; Shift:TShiftState;
X,Y:Integer);
var
idx: Integer;
begin
idx := PointInImage(Point(X, Y));
if idx > -1 then begin
FMouseDownPt := Point(X, Y);
FMouseImgIndex := idx;
DoImageClick(Shift, X, Y);
Abort;
end else
inherited;
end;
procedure TStringGridEx.MouseMove(Shift: TShiftState; X,Y: Integer);
begin
if (FMouseImgIndex > -1) then begin
DoImageMove(Shift, X - FMouseDownPt.X, Y - FMouseDownPt.Y);
FMouseDownPt := Point(X, Y);
end
else
inherited;
end;
procedure TStringGridEx.MouseUp(Button: TMouseButton; Shift:TShiftState;
X,Y:Integer);
begin
FMouseImgIndex := -1;
inherited;
end;
{ Moves the image by dx pixels horizontally and dy pixels vertically.
It is recommended to call UpdateImageAnchor afterwards. If this is not done
then it is not clear whether an image will move if column widths are changed. }
procedure TStringGridEx.MoveImageBy(AImageIndex, dx, dy: Integer);
var
imgData: TImageData;
begin
if (AImageIndex > -1) and (AImageIndex < FImageList.Count) then
begin
imgData := TImageData(FImageList[AImageIndex]);
inc(imgData.dx, dx);
inc(imgData.dy, dy);
Invalidate;
end;
end;
{ Finds the index of the image which contains the specified point. Images
are checked in reverse order, this means that in case of overlapping images
the "top" one is selected.
NOTE: Transparent areas of images are ignored, it is always the enclosing
rectangle of the entire image which is checked. }
function TStringGridEx.PointInImage(APoint: TPoint): Integer;
var
imgRect: TRect;
topleftPx: TPoint;
i: Integer;
begin
topleftPx := GetPxTopLeft;
APoint.X := APoint.X + topleftPx.X;
APoint.Y := APoint.Y + topleftPx.Y;
for i:=FImageList.Count-1 downto 0 do begin
imgRect := GetImageRect(i);
if PtInRect(imgRect, APoint) then
exit(i);
end;
Result := -1;
end;
{ Recalculates the anchor cell to which the image is attached. The anchor cell
is always the cell which contains the upper left corner of the image. It
may change when an image is dragged across the grid.
This method should be called after moving an image because otherwise it will
not be clear whether an image moves if column widths are changed. }
procedure TStringGridEx.UpdateImageAnchor(AImageIndex: Integer);
var
imgdata: TImageData;
cell: TPoint;
R: TRect;
P: TPoint;
begin
if (AImageIndex < 0) or (AImageIndex >= FImageList.Count) then
exit;
R := GetImageRect(AImageIndex); // Current pixel coordinates of image
cell := MouseToLogCell(R.TopLeft); // Col/row of cell with top left image corner
P := CellRect(cell.X, cell.Y).TopLeft; // Pixel coordinates of top left corner of anchor cell
imgdata := TImageData(FImageList[AImageIndex]);
imgData.Col := cell.X;
imgData.Row := cell.Y;
imgData.dx := R.Left - P.X;
imgData.dy := R.Top - P.Y;
end;
procedure TStringGridEx.WMHScroll(var message: TLMHScroll);
begin
inherited;
Invalidate;
end;
procedure TStringGridEx.WMVScroll(var message: TLMVScroll);
begin
inherited;
Invalidate;
end;
end.