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

MG: fixed GraphicClass.Create

Browse Source 
git-svn-id: trunk@2665 -
This commit is contained in:
lazarus 2002-08-18 04:56:32 +00:00
parent 1deaaea0e2
commit 9eea4a5c1d
4 changed files with 92 additions and 98 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
lcl/graphics.pp
View File

@ -320,7 +320,7 @@ type
procedure LoadFromLazarusResource(const ResName: String); virtual; abstract;
procedure LoadFromClipboardFormat(FormatID: TClipboardFormat); virtual; abstract;
procedure SaveToClipboardFormat(FormatID: TClipboardFormat); virtual; abstract;
constructor Create; // virtual;
constructor Create; virtual;
property Empty: Boolean read GetEmpty;
property Height: Integer read GetHeight write SetHeight;
property Modified: Boolean read FModified write SetModified;
@ -605,7 +605,7 @@ type
procedure WriteData(Stream: TStream); override;
procedure WriteStream(Stream: TStream; WriteSize: Boolean); virtual;
public
constructor Create; // override;
constructor Create; override;
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
procedure FreeImage;
@ -685,6 +685,9 @@ function ClearXLFDStyle(const LongFontName: string): string;
function XPMToPPChar(const XPM: string): PPChar;
function LazResourceXPMToPPChar(const ResourceName: string): PPChar;
function ReadXPMFromStream(Stream: TStream; Size: integer): PPChar;
function ReadXPMSize(XPM: PPChar; var Width, Height, ColorCount: integer
): boolean;
var
{ Stores information about the current screen }
@ -843,6 +846,9 @@ end.
{ =============================================================================
$Log$
Revision 1.40 2002/09/02 08:13:16 lazarus
MG: fixed GraphicClass.Create
Revision 1.39 2002/08/19 20:34:47 lazarus
MG: improved Clipping, TextOut, Polygon functions

6
lcl/include/bitmap.inc
View File

@ -290,7 +290,8 @@ end;
procedure TBitmap.SetHandle(Value: HBITMAP);
begin
// TODO: the properties from new bitmap
// TODO: get the properties from new bitmap (Width, Height)
// When this is done, then check TPixmap.ReadStream
with FImage do
if FHandle <> Value then
begin
@ -367,6 +368,9 @@ end;
{ =============================================================================
$Log$
Revision 1.15 2002/09/02 08:13:16 lazarus
MG: fixed GraphicClass.Create
Revision 1.14 2002/08/15 13:37:57 lazarus
MG: started menuitem icon, checked, radio and groupindex

7
lcl/include/picture.inc
View File

@ -376,21 +376,28 @@ begin
if GraphicClass = nil then
raise EInvalidGraphic.CreateFmt('Unknown picture extension', [Ext]);
writeln('TPicture.LoadFromFile A ',GraphicClass.ClassName);
NewGraphic := GraphicClass.Create;
writeln('TPicture.LoadFromFile B ',NewGraphic.ClassName);
ok:=false;
try
NewGraphic.OnProgress := @Progress;
writeln('TPicture.LoadFromFile C ');
NewGraphic.LoadFromFile(Filename);
writeln('TPicture.LoadFromFile D ');
ok:=true;
finally
// this try..finally construction will in case of an exception
// not alter the error backtrace output
if not ok then NewGraphic.Free;
end;
writeln('TPicture.LoadFromFile E ');
FGraphic.Free;
writeln('TPicture.LoadFromFile F ');
FGraphic := NewGraphic;
FGraphic.OnChange := @Changed;
Changed(Self);
writeln('TPicture.LoadFromFile END ');
end;
procedure TPicture.SaveToFile(const Filename: string);

167
lcl/include/pixmap.inc
View File

@ -134,6 +134,59 @@ begin
Result:=XPMToPPChar(XPMSource.Value);
end;
{-------------------------------------------------------------------------------
function ReadXPMFromStream(Stream: TStream; Size: integer): PPChar;
Converts the source of an XPM image file into an array of PChar.
See XPMToPPChar for more info.
-------------------------------------------------------------------------------}
function ReadXPMFromStream(Stream: TStream; Size: integer): PPChar;
var
s: string;
begin
Result:=nil;
if Size<=0 then exit;
SetLength(s,Size);
Stream.Read(s[1],Size);
Result:=XPMToPPChar(s);
end;
{-------------------------------------------------------------------------------
function ReadXPMSize(XPM: PPChar; var Width, Height, ColorCount: integer
): boolean;
Reads the first line of an XPM PChar array, whcih contains the width, height
and number of colors of the XPM.
-------------------------------------------------------------------------------}
function ReadXPMSize(XPM: PPChar; var Width, Height, ColorCount: integer
): boolean;
var
LinePos: PChar;
function ReadNumber(var i: integer): boolean;
begin
Result:=false;
// skip space
while (LinePos^ in [' ',#9]) do inc(LinePos);
// read number
i:=0;
while (LinePos^ in ['0'..'9']) do begin
i:=i*10+ord(LinePos^)-ord('0');
inc(LinePos);
Result:=true;
end;
end;
begin
Result:=false;
if (XPM=nil) or (XPM[0]=nil) then exit;
LinePos:=XPM[0];
if not ReadNumber(Width) then exit;
if not ReadNumber(Height) then exit;
if not ReadNumber(ColorCount) then exit;
Result:=true;
end;
{ TPixmap }
@ -164,105 +217,26 @@ begin
end;
procedure TPixmap.ReadStream(Stream: TStream; Size: Longint);
type
TCharArray = array[0..0] of PChar;
PCharArray = ^TCharArray;
var
Buf: PCharArray;
BufPtr: ^PChar;
i, j, LineCount, PixLen, Line3Start, LineStart, LineEnd: Integer;
s : String;
procedure ParseDataLine;
var a: integer;
begin
if s[LineStart]<>'"' then exit;
a:=LineStart+1;
while (a<LineEnd) and (s[a]<>'"') do inc(a);
if a>=LineEnd then exit;
s[LineEnd]:=#0;
BufPtr^ := @s[LineStart+1];
Inc(BufPtr);
end;
XPM: PPChar;
NewWidth, NewHeight, NewColorCount: integer;
begin
FreeContext;
XPM:=ReadXPMFromStream(Stream,Size);
if not ReadXPMSize(XPM,NewWidth,NewHeight,NewColorCount) then
raise Exception.Create('TPixmap.ReadStream: ERROR: reading xpm');
// Convert a XPM filedata format to a XPM memory format
// by filling an array of PChar with the contents between
// the ""'s in the file
// free old pixmap
// Create the pixmap
if FTransparentColor = clNone then
// create a transparent pixmap (with mask)
Handle := CreatePixmapIndirect(XPM, -1)
else
// create an opaque pixmap.
// Transparent pixels are filled with FTransparentColor
Handle := CreatePixmapIndirect(XPM, ColorToRGB(FTransparentColor));
// read stream into string
PixLen:=Stream.Size;
if PixLen=0 then exit;
SetLength(s,PixLen);
Stream.Read(s[1],PixLen);
// count line ends
Line3Start:=-1;
LineCount:=1;
i:=1;
while (i<=PixLen) do begin
if not (s[i] in [#10,#13]) then
inc(i)
else begin
inc(LineCount);
inc(i);
if (i<=PixLen) and (s[i] in [#10,#13]) and (s[i]<>s[i-1]) then
inc(i);
if (LineCount=3) and (i<PixLen) then Line3Start:=i;
end;
end;
if (s[PixLen] in [#10,#13]) then dec(LineCount);
// build PChar Array of Data-Line Starts ( " characters)
if (LineCount>2) and (Line3Start>=1) and (s[Line3Start]='"') then begin
Buf := GetMem((LineCount+1) * SizeOf(PCharArray));
try
BufPtr := Pointer(Buf);
LineStart:=1;
i:=1;
while (i<=PixLen) do begin
if not (s[i] in [#10,#13]) then
inc(i)
else begin
// found line end
LineEnd:=i;
ParseDataLine;
inc(i);
if (i<=PixLen) and (s[i] in [#10,#13]) and (s[i]<>s[i-1]) then
inc(i);
LineStart:=i;
end;
end;
if not (s[PixLen] in [#10,#13]) and (LineStart<=PixLen) then begin
LineEnd:=PixLen+1;
ParseDataLine;
end;
BufPtr^ := nil;
// Create the pixmap
if FTransparentColor = clNone then
// create a transparent pixmap (with mask)
Handle := CreatePixmapIndirect(Buf, -1)
else
// create an opaque pixmap.
// Transparent pixels are filled with FTransparentColor
Handle := CreatePixmapIndirect(Buf, ColorToRGB(FTransparentColor));
// set width and height
// the third line is of the form '"<width as decimal> <height as decimal> '
LineEnd:=Line3Start;
while (LineEnd<PixLen) and not (s[LineEnd] in [#13,#10]) do inc(LineEnd);
i:=Line3Start+1; // ignore initial "
j:=i;
while (j<LineEnd) and (s[j]<>' ') do inc(j);
FWidth := StrToIntDef(copy(s,i,j-i),1);
inc(j);
i:=j;
while (j<LineEnd) and (s[j]<>' ') do inc(j);
FHeight := StrToIntDef(copy(s,i,j-i),1);
finally
FreeMem(Buf);
end;
end;
FWidth:=NewWidth;
FHeight:=NewHeight;
end;
// included by graphics.pp
@ -270,6 +244,9 @@ end;
{ =============================================================================
$Log$
Revision 1.14 2002/09/02 08:13:17 lazarus
MG: fixed GraphicClass.Create
Revision 1.13 2002/06/08 17:16:02 lazarus
MG: added close buttons and images to TNoteBook and close buttons to source editor