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

LCL: implements dbimage clipboard support from Aleksey Lagunov (with changes), issue #33602

Browse Source 
git-svn-id: trunk@58697 -
This commit is contained in:
jesus 2018-08-12 18:58:58 +00:00
parent 9c5d04d5dc
commit 8a2aeb9fd9
2 changed files with 79 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
lcl/dbctrls.pp
View File

@ -1135,8 +1135,8 @@ Type
procedure DataChange(Sender: TObject);
procedure UpdateData(Sender: TObject); virtual;
procedure PictureChanged(Sender: TObject); override;
procedure LoadPicture; virtual;
class procedure WSRegisterClass; override;
procedure DoCopyToClipboard;
public
constructor Create(TheOwner: TComponent); override;
destructor Destroy; override;
@ -1144,6 +1144,12 @@ Type
function UpdateAction(AAction: TBasicAction): Boolean; override;
property Field: TField read GetField;
procedure Change; virtual;
procedure LoadPicture; virtual;
procedure CopyToClipboard;
procedure CutToClipboard;
procedure PasteFromClipboard;
property PictureLoaded : boolean read FPictureLoaded;
published
property Align;
property Anchors;
@ -1469,7 +1475,7 @@ implementation
{$R lcl_dbnav_images.res}
uses
InterfaceBase;
InterfaceBase, Clipbrd;
var
FieldClasses: TFpList;

79
lcl/include/dbimage.inc
View File

@ -164,7 +164,7 @@ var s : Tstream;
begin
if not FPictureLoaded then
begin
begin
FUpdatingRecord := True;
if not assigned(FDatalink.Field) then Picture.Assign(FDatalink.Field)
else
@ -192,7 +192,7 @@ begin
AGraphic := nil;
GraphExt := '';
if assigned(FOnDBImageRead) then
begin
begin
// External method to identify graphic type
// returns file extension for graphic type (e.g. jpg)
// If user implements OnDBImageRead, the control assumes that
@ -211,21 +211,24 @@ begin
// a image header will not work.
OnDBImageRead(self,s,GraphExt);
GraphExtToClass;
end
end
else
ReadImageHeader;
if gc<>nil then
begin
begin
AGraphic := gc.Create;
AGraphic.LoadFromStream(s);
Picture.Assign(AGraphic);
end
FPictureLoaded:=true;
end
else
begin
if not LoadImageFromStream then
begin
if LoadImageFromStream then
FPictureLoaded:=true
else
Picture.Clear;
end;
end;
finally
AGraphic.Free;
@ -241,6 +244,32 @@ begin
end;
end;
procedure TDBImage.CopyToClipboard;
begin
if Assigned(Picture.Graphic) then
DoCopyToClipboard;
end;
procedure TDBImage.CutToClipboard;
begin
if Assigned(Picture.Graphic) then
begin
if FDataLink.Edit then
begin
DoCopyToClipboard;
Picture.Clear;
end;
end;
end;
procedure TDBImage.PasteFromClipboard;
begin
if Clipboard.HasPictureFormat then
if FDataLink.Edit then
// TODO: add some option to convert image to an user preferred format?
Clipboard.AssignTo(Picture);
end;
class procedure TDBImage.WSRegisterClass;
const
Done: Boolean = False;
@ -252,6 +281,40 @@ begin
Done := True;
end;
procedure TDBImage.DoCopyToClipboard;
procedure AddGraphicFormat(fmt: TClipboardFormat; aClass: TGraphicClass);
var
st: TMemoryStream;
gp: TGraphic;
begin
if not (Picture.Graphic is aClass) then
begin
st := TMemoryStream.Create;
gp := aClass.Create;
try
gp.assign(Picture.Graphic);
gp.SaveToStream(st);
st.Position := 0;
Clipboard.Open;
Clipboard.AddFormat(fmt, st);
Clipboard.Close;
finally
st.free;
gp.free;
end;
end;
end;
begin
Clipboard.Assign(Picture);
{$IFDEF MSWINDOWS}
AddGraphicFormat(CF_BITMAP, TBitmap);
{$ELSE}
// TODO: check: under linux most apps seems to understand png clipboard format
// under osx it will probably be tiff
AddGraphicFormat(ClipboardRegisterFormat('image/png'), TPortableNetworkGraphic);
{$ENDIF}
end;
constructor TDBImage.Create(TheOwner: TComponent);
begin
inherited Create(TheOwner);