implemented copying graphics from/to clipboard

git-svn-id: trunk@4598 -
This commit is contained in:
mattias 2003-09-10 19:15:16 +00:00
parent 670b0a5f64
commit e5570985e8
8 changed files with 304 additions and 83 deletions

View File

@ -165,10 +165,10 @@ type
FOnRequest: TClipboardRequestEvent;
FOpenRefCount: Integer; // reference count for Open and Close (not used yet)
procedure AssignGraphic(Source: TGraphic);
procedure AssignGraphic(Source: TGraphic; FormatID: TClipboardFormat);
procedure AssignPicture(Source: TPicture);
procedure AssignToBitmap(Dest: TBitmap);
procedure AssignToPixmap(Dest: TPixmap);
procedure AssignToIcon(Dest: TIcon);
function AssignToGraphic(Dest: TGraphic): boolean;
function AssignToGraphic(Dest: TGraphic; FormatID: TClipboardFormat): boolean;
//procedure AssignToMetafile(Dest: TMetafile);
procedure AssignToPicture(Dest: TPicture);
function GetAsText: string;
@ -182,18 +182,18 @@ type
procedure SetAsText(const Value: string);
procedure SetBuffer(FormatID: TClipboardFormat; var Buffer; Size: Integer);
procedure SetOnRequest(AnOnRequest: TClipboardRequestEvent);
protected
procedure AssignTo(Dest: TPersistent); override;
public
function AddFormat(FormatID: TClipboardFormat; Stream: TStream): Boolean;
function AddFormat(FormatID: TClipboardFormat; var Buffer; Size: Integer): Boolean;
procedure Assign(Source: TPersistent); override;
procedure AssignTo(Dest: TPersistent); override;
procedure Clear;
procedure Close; // dummy for delphi compatibility only
constructor Create;
constructor Create(AClipboardType: TClipboardType);
destructor Destroy; override;
function FindPictureFormatID: TClipboardFormat;
function FindFormatID(const FormatName: string): TClipboardFormat;
//function GetAsHandle(Format: integer): THandle;
function GetComponent(Owner, Parent: TComponent): TComponent;
function GetFormat(FormatID: TClipboardFormat; Stream: TStream): Boolean;
@ -202,6 +202,7 @@ type
var FormatList: PClipboardFormat);
function GetTextBuf(Buffer: PChar; BufSize: Integer): Integer;
function HasFormat(FormatID: TClipboardFormat): Boolean;
function HasFormatName(const FormatName: string): Boolean;
function HasPictureFormat: boolean;
procedure Open; // dummy for delphi compatibility only
//procedure SetAsHandle(Format: integer; Value: THandle);
@ -319,12 +320,27 @@ begin
FreeAndNil(FClipboards[AClipboardType]);
end;
procedure LoadGraphicFromClipboardFormat(Dest: TGraphic;
ClipboardType: TClipboardType; FormatID: TClipboardFormat);
begin
Clipboard(ClipboardType).AssignToGraphic(Dest,FormatID);
end;
procedure SaveGraphicToClipboardFormat(Src: TGraphic;
ClipboardType: TClipboardType; FormatID: TClipboardFormat);
begin
Clipboard(ClipboardType).AssignGraphic(Src,FormatID);
end;
//-----------------------------------------------------------------------------
procedure InternalInit;
var
AClipboardType: TClipboardType;
begin
OnLoadGraphicFromClipboardFormat:=@LoadGraphicFromClipboardFormat;
OnSaveGraphicToClipboardFormat:=@SaveGraphicToClipboardFormat;
for AClipboardType:=Low(TClipboardType) to High(TClipboardType) do
FClipboards[AClipboardType]:=nil;
end;
@ -344,6 +360,9 @@ end.
{
$Log$
Revision 1.13 2003/09/10 19:15:15 mattias
implemented copying graphics from/to clipboard
Revision 1.12 2003/09/10 16:29:13 mattias
added Kylix 3 specials

View File

@ -504,9 +504,16 @@ type
procedure SaveToFile(const Filename: string); virtual;
procedure LoadFromStream(Stream: TStream); virtual; abstract;
procedure SaveToStream(Stream: TStream); virtual; abstract;
procedure LoadFromMimeStream(Stream: TStream; const MimeType: string); virtual;
procedure LoadFromLazarusResource(const ResName: String); virtual; abstract;
procedure LoadFromClipboardFormat(FormatID: TClipboardFormat); virtual; abstract;
procedure SaveToClipboardFormat(FormatID: TClipboardFormat); virtual; abstract;
procedure LoadFromClipboardFormat(FormatID: TClipboardFormat); virtual;
procedure LoadFromClipboardFormatID(ClipboardType: TClipboardType;
FormatID: TClipboardFormat); virtual;
procedure SaveToClipboardFormat(FormatID: TClipboardFormat); virtual;
procedure SaveToClipboardFormatID(ClipboardType: TClipboardType;
FormatID: TClipboardFormat); virtual;
procedure GetSupportedSourceMimeTypes(List: TStrings); virtual;
function GetDefaultMimeType: string; virtual;
public
property Empty: Boolean read GetEmpty;
property Height: Integer read GetHeight write SetHeight;
@ -559,10 +566,11 @@ type
Graphic - The TGraphic object contained by the TPicture
Bitmap - Returns a bitmap. If the contents is not already a bitmap, the
contents are thrown away and a blank bitmap is returned.
Icon - Returns an icon. If the contents is not already an icon, the
contents are thrown away and a blank icon is returned.
Pixmap - Returns a pixmap. If the contents is not already a pixmap, the
contents are thrown away and a blank pixmap is returned.
PNG - Returns a png. If the contents is not already a png, the
contents are thrown away and a blank png (TPortableNetworkGraphic) is
returned.
}
TPicture = class(TPersistent)
@ -598,6 +606,8 @@ type
procedure LoadFromFile(const Filename: string);
procedure SaveToFile(const Filename: string);
procedure LoadFromClipboardFormat(FormatID: TClipboardFormat);
procedure LoadFromClipboardFormatID(ClipboardType: TClipboardType;
FormatID: TClipboardFormat);
procedure SaveToClipboardFormat(FormatID: TClipboardFormat);
class function SupportsClipboardFormat(FormatID: TClipboardFormat): Boolean;
procedure Assign(Source: TPersistent); override;
@ -903,13 +913,15 @@ type
procedure LoadFromLazarusResource(const ResName: String); override;
procedure LoadFromResourceName(Instance: THandle; const ResName: String); virtual;
procedure LoadFromResourceID(Instance: THandle; ResID: Integer); virtual;
procedure LoadFromClipboardFormat(FormatID: TClipboardFormat); override;
procedure SaveToClipboardFormat(FormatID: TClipboardFormat); override;
procedure LoadFromMimeStream(Stream: TStream; const MimeType: string); override;
procedure GetSupportedSourceMimeTypes(List: TStrings); override;
function GetDefaultMimeType: string; override;
Procedure LoadFromXPMFile(const Filename : String);
procedure Mask(ATransparentColor: TColor);
procedure SaveToStream(Stream: TStream); override;
Function ReleaseHandle: HBITMAP;
function ReleasePalette: HPALETTE;
public
property Canvas: TCanvas read GetCanvas write FCanvas;
property Handle: HBITMAP read GetHandle write SetHandle;
property HandleType: TBitmapHandleType read GetHandleType write SetHandleType;
@ -939,6 +951,7 @@ type
function LazarusResourceTypeValid(const ResourceType: string): boolean; override;
procedure ReadStream(Stream: TStream; Size: Longint); override;
procedure WriteStream(Stream: TStream; WriteSize: Boolean); override;
function GetDefaultMimeType: string; override;
end;
{ TIcon }
@ -956,13 +969,14 @@ type
end;
// Color / Identifier mapping
TGetColorStringProc = procedure(const s:ansistring) of object;
function GraphicFilter(GraphicClass: TGraphicClass): string;
function GraphicExtension(GraphicClass: TGraphicClass): string;
function GraphicFileMask(GraphicClass: TGraphicClass): string;
type
// Color / Identifier mapping
TGetColorStringProc = procedure(const s:ansistring) of object;
function ColorToIdent(Color: Longint; var Ident: String): Boolean;
function IdentToColor(const Ident: string; var Color: Longint): Boolean;
function ColorToRGB(Color: TColor): Longint;
@ -975,6 +989,7 @@ Function Green(rgb: TColor) : BYTE;
Function Red(rgb: TColor) : BYTE;
procedure RedGreenBlue(rgb: TColor; Red, Green, Blue: Byte);
// fonts
procedure GetCharsetValues(Proc: TGetStrProc);
function CharsetToIdent(Charset: Longint; var Ident: string): Boolean;
function IdentToCharset(const Ident: string; var Charset: Longint): Boolean;
@ -989,6 +1004,19 @@ function ClearXLFDHeight(const LongFontName: string): string;
function ClearXLFDPitch(const LongFontName: string): string;
function ClearXLFDStyle(const LongFontName: string): string;
// graphics
type
TOnLoadGraphicFromClipboardFormat =
procedure(Dest: TGraphic; ClipboardType: TClipboardType;
FormatID: TClipboardFormat);
TOnSaveGraphicToClipboardFormat =
procedure(Src: TGraphic; ClipboardType: TClipboardType;
FormatID: TClipboardFormat);
var
OnLoadGraphicFromClipboardFormat: TOnLoadGraphicFromClipboardFormat;
OnSaveGraphicToClipboardFormat: TOnSaveGraphicToClipboardFormat;
function TestStreamBitmapNativeType(Stream: TMemoryStream): TBitmapNativeType;
function TestStreamIsBMP(Stream: TMemoryStream): boolean;
function TestStreamIsXPM(Stream: TMemoryStream): boolean;
@ -1185,11 +1213,15 @@ end;
initialization
PicClipboardFormats:=nil;
PicFileFormats:=nil;
OnLoadGraphicFromClipboardFormat:=nil;
OnSaveGraphicToClipboardFormat:=nil;
RegisterIntegerConsts(TypeInfo(TColor), @IdentToColor, @ColorToIdent);
RegisterIntegerConsts(TypeInfo(TFontCharset), @IdentToCharset, @CharsetToIdent);
finalization
GraphicsFinalized:=true;
OnLoadGraphicFromClipboardFormat:=nil;
OnSaveGraphicToClipboardFormat:=nil;
FreeAndNil(PicClipboardFormats);
FreeAndNil(PicFileFormats);
@ -1199,6 +1231,9 @@ end.
{ =============================================================================
$Log$
Revision 1.90 2003/09/10 19:15:15 mattias
implemented copying graphics from/to clipboard
Revision 1.89 2003/09/08 13:07:17 mattias
TBitmap now uses fpImage for writing bitmaps

View File

@ -295,14 +295,30 @@ begin
writeln('ToDo: TBitMap.LoadFromResourceID');
end;
procedure TBitmap.LoadFromClipboardFormat(FormatID: TClipboardFormat);
procedure TBitmap.GetSupportedSourceMimeTypes(List: TStrings);
begin
writeln('ToDo: TBitMap.LoadFromClipboardFormat');
if (ClassType=TBitmap) or (ClassType=TPixmap) then begin
List.Clear;
List.Add(PredefinedClipboardMimeTypes[pcfBitmap]);
List.Add(PredefinedClipboardMimeTypes[pcfDelphiBitmap]);
List.Add(PredefinedClipboardMimeTypes[pcfPixmap]);
end else
inherited GetSupportedSourceMimeTypes(List);
end;
procedure TBitmap.SaveToClipboardFormat(FormatID: TClipboardFormat);
function TBitmap.GetDefaultMimeType: string;
begin
writeln('ToDo: TBitmap.SaveToClipboardFormat');
if (ClassType=TBitmap) or (ClassType=TPixmap) then begin
if FImage.SaveStream<>nil then begin
case FImage.SaveStreamType of
bnXPixmap: Result:=PredefinedClipboardMimeTypes[pcfPixmap];
else
Result:=PredefinedClipboardMimeTypes[pcfBitmap];
end;
end else
Result:=PredefinedClipboardMimeTypes[pcfBitmap];
end else
Result:=inherited GetDefaultMimeType;
end;
Procedure TBitmap.LoadFromXPMFile(const Filename : String);
@ -480,6 +496,20 @@ begin
end;
end;
procedure TBitmap.LoadFromMimeStream(Stream: TStream; const MimeType: string);
begin
if (ClassType=TBitmap) or (ClassType=TPixmap) then begin
if (AnsiCompareText(MimeType,PredefinedClipboardMimeTypes[pcfBitmap])=0)
or (AnsiCompareText(MimeType,PredefinedClipboardMimeTypes[pcfDelphiBitmap])=0)
or (AnsiCompareText(MimeType,PredefinedClipboardMimeTypes[pcfPixmap])=0) then
begin
LoadFromStream(Stream);
exit;
end;
end;
inherited LoadFromMimeStream(Stream, MimeType);
end;
procedure TBitmap.SetWidthHeight(NewWidth, NewHeight: integer);
begin
with FImage do
@ -888,6 +918,9 @@ end;
{ =============================================================================
$Log$
Revision 1.46 2003/09/10 19:15:15 mattias
implemented copying graphics from/to clipboard
Revision 1.45 2003/09/08 13:07:17 mattias
TBitmap now uses fpImage for writing bitmaps

View File

@ -403,45 +403,63 @@ begin
end;
function TClipboard.FindPictureFormatID: TClipboardFormat;
const
PicFormats: set of TPredefinedClipboardFormat = [
pcfBitmap,
pcfPixmap,
pcfIcon,
pcfPicture,
pcfDelphiBitmap,
pcfDelphiPicture,
//pcfDelphiMetaFilePict, (unsupported yet)
pcfKylixPicture,
pcfKylixBitmap
//pcfKylixDrawing (unsupported yet)
];
var
f: TPredefinedClipboardFormat;
List: PClipboardFormat;
cnt, i: integer;
begin
//writeln('[TClipboard.FindPictureFormatID]');
List:=nil;
Result:=0;
cnt:=0;
if not FAllocated then begin
if not ClipboardGetFormats(ClipboardType,cnt,List) then begin
Result:=0;
if not ClipboardGetFormats(ClipboardType,cnt,List) then
exit;
end;
end else begin
cnt:=0;
end;
try
for f:=Low(TPredefinedClipboardFormat) to High(TPredefinedClipboardFormat) do
begin
Result:=PredefinedClipboardFormat(f);
if (Result<>0) and (f in PicFormats) then begin
if not FAllocated then begin
for i:=0 to cnt-1 do
if (List[i]=Result) then exit;
end else begin
if IndexOfCachedFormatID(Result,false)>=0 then exit;
end;
if not FAllocated then begin
for i:=0 to cnt-1 do begin
Result:=List[i];
if TPicture.SupportsClipboardFormat(Result) then
exit;
end;
end else begin
for i:=FCount-1 downto 0 do begin
Result:=FData[i].FormatID;
if TPicture.SupportsClipboardFormat(Result) then
exit;
end;
end;
finally
if List<>nil then FreeMem(List);
end;
Result:=0;
end;
function TClipboard.FindFormatID(const FormatName: string): TClipboardFormat;
var
List: PClipboardFormat;
cnt, i: integer;
begin
//writeln('[TClipboard.FindPictureFormatID]');
List:=nil;
Result:=0;
cnt:=0;
if not FAllocated then begin
if not ClipboardGetFormats(ClipboardType,cnt,List) then
exit;
end;
try
if not FAllocated then begin
for i:=0 to cnt-1 do begin
Result:=List[i];
if AnsiCompareText(ClipboardFormatToMimeType(Result),FormatName)=0 then
exit;
end;
end else begin
for i:=FCount-1 downto 0 do begin
Result:=FData[i].FormatID;
if AnsiCompareText(ClipboardFormatToMimeType(Result),FormatName)=0 then
exit;
end;
end;
finally
@ -487,40 +505,90 @@ begin
//writeln('[TClipboard.HasFormat] END ',ClipboardTypeName[ClipboardType],' FormatID=',FormatID,' Result=',Result);
end;
function TClipboard.HasFormatName(const FormatName: string): Boolean;
begin
Result:=FindFormatID(FormatName)<>0;
end;
procedure TClipboard.AssignToPicture(Dest: TPicture);
var
FormatID: TClipboardFormat;
begin
// ToDo
raise Exception.Create('TClipboard.AssignToPicture not implemented yet');
end;
procedure TClipboard.AssignToBitmap(Dest: TBitmap);
begin
// ToDo
raise Exception.Create('TClipboard.AssignToBitmap not implemented yet');
end;
procedure TClipboard.AssignToPixmap(Dest: TPixmap);
begin
// ToDo
raise Exception.Create('TClipboard.AssignToPixmap not implemented yet');
end;
procedure TClipboard.AssignToIcon(Dest: TIcon);
begin
// ToDo
raise Exception.Create('TClipboard.AssignToIcon not implemented yet');
FormatID:=FindPictureFormatID;
if FormatID=0 then exit;
Dest.LoadFromClipboardFormatID(ClipboardType,FormatID);
end;
procedure TClipboard.AssignPicture(Source: TPicture);
begin
// ToDo
raise Exception.Create('TClipboard.AssignPicture not implemented yet');
AssignGraphic(Source.Graphic);
end;
function TClipboard.AssignToGraphic(Dest: TGraphic): boolean;
var
MimeTypes: TStringList;
i: Integer;
GraphicFormatID: TClipboardFormat;
begin
Result:=false;
MimeTypes:=TStringList.Create;
try
Dest.GetSupportedSourceMimeTypes(MimeTypes);
for i:=0 to MimeTypes.Count-1 do begin
GraphicFormatID:=FindFormatID(MimeTypes[i]);
if GraphicFormatID<>0 then begin
AssignToGraphic(Dest,GraphicFormatID);
Result:=true;
exit;
end;
end;
finally
MimeTypes.Free;
end;
end;
function TClipboard.AssignToGraphic(Dest: TGraphic; FormatID: TClipboardFormat
): boolean;
var
MemStream: TMemoryStream;
begin
Result:=false;
if FormatID=0 then exit;
MemStream:=TMemoryStream.Create;
try
if not GetFormat(FormatID,MemStream) then exit;
MemStream.Position:=0;
Dest.LoadFromMimeStream(MemStream,ClipboardFormatToMimeType(FormatID));
finally
MemStream.Free;
end;
Result:=true;
end;
procedure TClipboard.AssignGraphic(Source: TGraphic);
var
MimeType: String;
FormatID: TClipboardFormat;
begin
// ToDo
raise Exception.Create('TClipboard.AssignGraphic not implemented yet');
MimeType:=Source.GetDefaultMimeType;
FormatID:=ClipboardRegisterFormat(MimeType);
if FormatID<>0 then
AssignGraphic(Source,FormatID);
end;
procedure TClipboard.AssignGraphic(Source: TGraphic; FormatID: TClipboardFormat
);
var
MemStream: TMemoryStream;
begin
MemStream:=TMemoryStream.Create;
try
Source.SaveToStream(MemStream);
MemStream.Position:=0;
SetFormat(FormatID,MemStream);
finally
MemStream.Free;
end;
end;
procedure TClipboard.Assign(Source: TPersistent);
@ -537,10 +605,8 @@ procedure TClipboard.AssignTo(Dest: TPersistent);
begin
if Dest is TPicture then
AssignToPicture(TPicture(Dest))
else if Dest is TBitmap then
AssignToBitmap(TBitmap(Dest))
else if Dest is TPixmap then
AssignToPixmap(TPixmap(Dest))
else if Dest is TGraphic then
AssignToGraphic(TGraphic(Dest))
else
inherited AssignTo(Dest);
end;
@ -607,6 +673,9 @@ end;
{
$Log$
Revision 1.14 2003/09/10 19:15:16 mattias
implemented copying graphics from/to clipboard
Revision 1.13 2003/09/10 16:33:51 mattias
added clipboard checks

View File

@ -106,6 +106,56 @@ begin
end;
end;
procedure TGraphic.LoadFromMimeStream(Stream: TStream; const MimeType: string);
var
DefMimeType: String;
begin
DefMimeType:=GetDefaultMimeType;
if (DefMimeType<>'') and (MimeType=GetDefaultMimeType) then
LoadFromStream(Stream)
else
raise Exception.Create(ClassName+': Unsupported MimeType: '+MimeType);
end;
procedure TGraphic.LoadFromClipboardFormat(FormatID: TClipboardFormat);
begin
LoadFromClipboardFormatID(ctClipboard,FormatID);
end;
procedure TGraphic.LoadFromClipboardFormatID(ClipboardType: TClipboardType;
FormatID: TClipboardFormat);
begin
if Assigned(OnLoadGraphicFromClipboardFormat) then
OnLoadGraphicFromClipboardFormat(Self,ClipboardType,FormatID);
end;
procedure TGraphic.SaveToClipboardFormat(FormatID: TClipboardFormat);
begin
SaveToClipboardFormatID(ctClipboard,FormatID);
end;
procedure TGraphic.SaveToClipboardFormatID(ClipboardType: TClipboardType;
FormatID: TClipboardFormat);
begin
if Assigned(OnSaveGraphicToClipboardFormat) then
OnSaveGraphicToClipboardFormat(Self,ClipboardType,FormatID);
end;
procedure TGraphic.GetSupportedSourceMimeTypes(List: TStrings);
var
DefMimeType: String;
begin
List.Clear;
DefMimeType:=GetDefaultMimeType;
if DefMimeType<>'' then
List.Add(DefMimeType);
end;
function TGraphic.GetDefaultMimeType: string;
begin
Result:='';
end;
procedure TGraphic.LoadFromFile(const Filename: string);
var
Stream: TStream;

View File

@ -194,8 +194,10 @@ constructor TPicClipboardFormats.Create;
begin
inherited Create;
Add(PredefinedClipboardFormat(pcfBitmap), TBitmap);
Add(PredefinedClipboardFormat(pcfDelphiBitmap), TBitmap);
Add(PredefinedClipboardFormat(pcfPixmap), TPixmap);
Add(PredefinedClipboardFormat(pcfIcon), TIcon);
//Add(PredefinedClipboardFormat(pcfIcon), TIcon);
Add('image/png', TPortableNetworkGraphic);
end;
procedure TPicClipboardFormats.Clear;
@ -221,6 +223,7 @@ procedure TPicClipboardFormats.Add(AFormatID: TClipboardFormat;
AClass: TGraphicClass);
var NewFormat: PPicClipboardFormat;
begin
if AFormatID=0 then exit;
New(NewFormat);
with NewFormat^ do begin
GraphicClass:=AClass;
@ -238,7 +241,7 @@ begin
for I := Count-1 downto 0 do begin
P:=GetFormats(i);
if P^.FormatID=FormatID then begin
Result := P^.GraphicClass;
Result:=P^.GraphicClass;
Exit;
end;
end;
@ -427,7 +430,6 @@ begin
raise EInvalidGraphic.CreateFmt(rsUnknownPictureExtension, [Ext]);
NewGraphic := GraphicClass.Create;
ok:=false;
try
NewGraphic.OnProgress := @Progress;
@ -438,8 +440,7 @@ begin
// not alter the error backtrace output
if not ok then NewGraphic.Free;
end;
If FGraphic <> nil then
FGraphic.Free;
FGraphic.Free;
FGraphic := NewGraphic;
FGraphic.OnChange := @Changed;
Changed(Self);
@ -451,6 +452,12 @@ begin
end;
procedure TPicture.LoadFromClipboardFormat(FormatID: TClipboardFormat);
begin
LoadFromClipboardFormatID(ctClipboard,FormatID);
end;
procedure TPicture.LoadFromClipboardFormatID(ClipboardType: TClipboardType;
FormatID: TClipboardFormat);
var
NewGraphic: TGraphic;
GraphicClass: TGraphicClass;
@ -465,7 +472,7 @@ begin
ok:=false;
try
NewGraphic.OnProgress := @Progress;
NewGraphic.LoadFromClipboardFormat(FormatID);
NewGraphic.LoadFromClipboardFormatID(ClipboardType,FormatID);
ok:=true;
finally
if not ok then NewGraphic.Free;

View File

@ -45,6 +45,11 @@ begin
{$ENDIF}
end;
function TPortableNetworkGraphic.GetDefaultMimeType: string;
begin
Result:='image/png';
end;
// included by graphics.pp

View File

@ -1717,8 +1717,8 @@ type
const
PredefinedClipboardMimeTypes : array[TPredefinedClipboardFormat] of string = (
'text/plain',
'image/lcl.bitmap',
'image/lcl.pixmap',
'image/bmp',
'image/xpm',
'image/lcl.icon',
'image/lcl.picture',
'application/lcl.object',
@ -1813,6 +1813,9 @@ end.
{
$Log$
Revision 1.42 2003/09/10 19:15:15 mattias
implemented copying graphics from/to clipboard
Revision 1.41 2003/09/10 16:29:13 mattias
added Kylix 3 specials