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

implemented saving alpha bmp and using transparency for IDE glyph editor

Browse Source 
git-svn-id: trunk@7264 -
This commit is contained in:
mattias 2005-06-22 09:45:59 +00:00
parent 0c73a31caa
commit 666e058403
15 changed files with 130 additions and 382 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
components/codetools/codetoolsstructs.pas
View File

@ -56,7 +56,7 @@ type
TCodeXYPositions = class
private
FItems: TList; // list of PCodeXYPosition, can be nil
FItems: TFPList; // list of PCodeXYPosition, can be nil
function GetCaretsXY(Index: integer): TPoint;
function GetCodes(Index: integer): TCodeBuffer;
function GetItems(Index: integer): PCodeXYPosition;
@ -172,7 +172,7 @@ var
begin
New(NewItem);
NewItem^:=Position;
if FItems=nil then FItems:=TList.Create;
if FItems=nil then FItems:=TFPList.Create;
Result:=FItems.Add(NewItem);
end;

4
components/codetools/definetemplates.pas
View File

@ -384,7 +384,7 @@ type
TDefinePool = class
private
FEnglishErrorMsgFilename: string;
FItems: TList; // list of TDefineTemplate;
FItems: TFPList; // list of TDefineTemplate;
function GetItems(Index: integer): TDefineTemplate;
procedure SetEnglishErrorMsgFilename(const AValue: string);
public
@ -2578,7 +2578,7 @@ end;
constructor TDefinePool.Create;
begin
inherited Create;
FItems:=TList.Create;
FItems:=TFPList.Create;
end;
destructor TDefinePool.Destroy;

4
components/codetools/finddeclarationcache.pas
View File

@ -245,7 +245,7 @@ type
TCodeTreeNodeStack = record
Fixedtems: array[0..9] of TCodeTreeNodeStackEntry;
DynItems: TList; // list of TCodeTreeNodeStackEntry
DynItems: TFPList; // list of TCodeTreeNodeStackEntry
StackPtr: integer;
end;
PCodeTreeNodeStack = ^TCodeTreeNodeStack;
@ -1028,7 +1028,7 @@ begin
NodeStack^.Fixedtems[NodeStack^.StackPtr]:=NewNode;
end else begin
if NodeStack^.DynItems=nil then begin
NodeStack^.DynItems:=TList.Create;
NodeStack^.DynItems:=TFPList.Create;
end;
NodeStack^.DynItems.Add(NewNode);
end;

8
components/codetools/identcompletiontool.pas
View File

@ -135,8 +135,8 @@ type
FStartAtomInFront: TAtomPosition;
FStartBracketLvl: integer;
FStartContextPos: TCodeXYPosition;
FCreatedIdentifiers: TList; // list of PChar
FFilteredList: TList; // list of TIdentifierListItem
FCreatedIdentifiers: TFPList; // list of PChar
FFilteredList: TFPList; // list of TIdentifierListItem
FFlags: TIdentifierListFlags;
FHistory: TIdentifierHistoryList;
FItems: TAVLTree; // tree of TIdentifierListItem (completely sorted)
@ -416,7 +416,7 @@ var
CurItem: TIdentifierListItem;
begin
if not (ilfFilteredListNeedsUpdate in FFlags) then exit;
if FFilteredList=nil then FFilteredList:=TList.Create;
if FFilteredList=nil then FFilteredList:=TFPList.Create;
FFilteredList.Count:=0;
FFilteredList.Capacity:=FItems.Count;
{ $IFDEF CTDEBUG}
@ -469,7 +469,7 @@ begin
FIdentView:=TAVLTree.Create(@CompareIdentListItemsForIdents);
FIdentSearchItem:=TIdentifierListItem.Create(icompUnknown,
false,0,nil,0,nil,nil,ctnNone);
FCreatedIdentifiers:=TList.Create;
FCreatedIdentifiers:=TFPList.Create;
end;
destructor TIdentifierList.Destroy;

4
components/codetools/keywordfunclists.pas
View File

@ -616,7 +616,7 @@ end;
//-----------------------------------------------------------------------------
var KeyWordLists: TList;
var KeyWordLists: TFPList;
procedure InternalInit;
var
@ -635,7 +635,7 @@ begin
for w:=Low(word) to High(word) do
UpWords[w]:=ord(UpChars[chr(w and $ff)])+(ord(UpChars[chr(w shr 8)]) shl 8);
KeyWordLists:=TList.Create;
KeyWordLists:=TFPList.Create;
IsKeyWordMethodSpecifier:=TKeyWordFunctionList.Create;
KeyWordLists.Add(IsKeyWordMethodSpecifier);

5
components/codetools/laz_dom.pas
View File

@ -300,7 +300,7 @@ type
// NamedNodeMap
// -------------------------------------------------------
TDOMNamedNodeMap = class(TList)
TDOMNamedNodeMap = class(TFPList)
protected
OwnerDocument: TDOMDocument;
function GetItem(index: LongWord): TDOMNode;
@ -1674,6 +1674,9 @@ end.
{
$Log$
Revision 1.12 2005/06/22 09:45:59 mattias
implemented saving alpha bmp and using transparency for IDE glyph editor
Revision 1.11 2005/01/29 17:37:56 mattias
reduced mem need for xml stuff

33
components/codetools/linkscanner.pas
View File

@ -169,7 +169,7 @@ type
FIgnoreErrorAfterCursorPos: integer;
FInitValues: TExpressionEvaluator;
FInitValuesChangeStep: integer;
FSourceChangeSteps: TList; // list of PSourceChangeStep sorted with Code
FSourceChangeSteps: TFPList; // list of PSourceChangeStep sorted with Code
FChangeStep: integer;
FMainSourceFilename: string;
FMainCode: pointer;
@ -228,7 +228,7 @@ type
FSkipDirectiveFuncList: TKeyWordFunctionList;
FMacrosOn: boolean;
FMissingIncludeFiles: TMissingIncludeFiles;
FIncludeStack: TList; // list of TSourceLink
FIncludeStack: TFPList; // list of TSourceLink
FSkippingTillEndif: boolean;
FSkipIfLevel: integer;
FCompilerMode: TCompilerMode;
@ -464,7 +464,9 @@ var
procedure AddCodeToUniqueList(ACode: Pointer; UniqueSortedCodeList: TList);
function IndexOfCodeInUniqueList(ACode: Pointer;
UniqueSortedCodeList: TList): integer;
UniqueSortedCodeList: TList): integer;
function IndexOfCodeInUniqueList(ACode: Pointer;
UniqueSortedCodeList: TFPList): integer;
implementation
@ -493,6 +495,27 @@ begin
Result:=-1;
end;
function IndexOfCodeInUniqueList(ACode: Pointer;
UniqueSortedCodeList: TFPList): integer;
var l,m,r: integer;
begin
l:=0;
r:=UniqueSortedCodeList.Count-1;
m:=0;
while r>=l do begin
m:=(l+r) shr 1;
if ACode<UniqueSortedCodeList[m] then
r:=m-1
else if ACode>UniqueSortedCodeList[m] then
l:=m+1
else begin
Result:=m;
exit;
end;
end;
Result:=-1;
end;
procedure AddCodeToUniqueList(ACode: Pointer; UniqueSortedCodeList: TList);
var l,m,r: integer;
begin
@ -604,11 +627,11 @@ begin
FInitValues:=TExpressionEvaluator.Create;
Values:=TExpressionEvaluator.Create;
FChangeStep:=0;
FSourceChangeSteps:=TList.Create;
FSourceChangeSteps:=TFPList.Create;
FMainCode:=nil;
FMainSourceFilename:='';
BuildDirectiveFuncList;
FIncludeStack:=TList.Create;
FIncludeStack:=TFPList.Create;
FNestedComments:=false;
end;

4
components/codetools/multikeywordlisttool.pas
View File

@ -41,7 +41,7 @@ uses
type
TMultiKeyWordListCodeTool = class(TCustomCodeTool)
private
FKeyWordLists: TList; // list of TKeyWordFunctionList
FKeyWordLists: TFPList; // list of TKeyWordFunctionList
FCurKeyWordListID: integer;
procedure SetCurKeyWordFuncList(AKeyWordFuncList: TKeyWordFunctionList);
protected
@ -66,7 +66,7 @@ implementation
constructor TMultiKeyWordListCodeTool.Create;
begin
inherited Create;
FKeyWordLists:=TList.Create; // list of TKeyWordFunctionList
FKeyWordLists:=TFPList.Create; // list of TKeyWordFunctionList
AddKeyWordFuncList(KeyWordFuncList);
FCurKeyWordListID:=0;
DefaultKeyWordFuncList:=KeyWordFuncList;

8
components/codetools/sourcelog.pas
View File

@ -86,8 +86,8 @@ type
FLineRanges: {$ifdef fpc}^{$else}array of {$endif}TLineRange;
// array of TLineRange
FSrcLen: integer;
FLog: TList; // list of TSourceLogEntry
FMarkers: TList; // list of TSourceLogMarker;
FLog: TFPList; // list of TSourceLogEntry
FMarkers: TFPList; // list of TSourceLogMarker;
FModified: boolean;
FOnInsert: TOnSourceLogInsert;
FOnDelete: TOnSourceLogDelete;
@ -241,8 +241,8 @@ begin
FModified:=false;
FSource:=ASource;
FSrcLen:=length(FSource);
FLog:=TList.Create;
FMarkers:=TList.Create;
FLog:=TFPList.Create;
FMarkers:=TFPList.Create;
FLineRanges:=nil;
FLineCount:=-1;
FChangeStep:=0;

12
ideintf/graphpropedits.pas
View File

@ -353,6 +353,7 @@ var
ABitmap: TBitmap;
Ext : String;
begin
//debugln('TGraphicPropertyEditor.Edit');
ABitmap := TBitmap(GetObjectValue(TBitmap));
TheDialog := TGraphicPropertyEditorForm.Create(nil);
try
@ -459,28 +460,31 @@ var
ABitmap.LoadFromFile(TheDialog.FileName);
end
else begin
ABitmap.Width := TheDialog.Preview.Picture.Graphic.Width;
ABitmap.Assign(TheDialog.Preview.Picture.Graphic);
{ABitmap.Width := TheDialog.Preview.Picture.Graphic.Width;
ABitmap.Height := TheDialog.Preview.Picture.Graphic.Height;
With ABitmap.Canvas do begin
Brush.Color := clWhite;
FillRect(Rect(0, 0, ABitmap.Width, ABitmap.Height));
Draw(0, 0, TheDialog.Preview.Picture.Graphic);
end;
end;}
end;
end;
begin
debugln('TButtonGlyphPropEditor.Edit');
ABitmap := TBitmap(GetObjectValue(TBitmap));
TheDialog := TGraphicPropertyEditorForm.Create(nil);
try
If not ABitmap.Empty then begin
With TheDialog.Preview.Picture.Bitmap do begin
TheDialog.Preview.Picture.Assign(ABitmap);
{With TheDialog.Preview.Picture.Bitmap do begin
Width := ABitmap.Width;
Height := ABitmap.Height;
Canvas.Brush.Color := clWhite;
Canvas.FillRect(Rect(0, 0, ABitmap.Width, ABitmap.Height));
Canvas.Draw(0, 0, ABitmap);
end;
end;}
end;
if (TheDialog.ShowModal = mrOK) then begin
If TheDialog.Preview.Picture.Graphic <> nil then begin

44
lcl/graphics.pp
View File

@ -1121,7 +1121,7 @@ type
same TBitmapImage }
TBitmapNativeType = (
bnNone,
bnNone, // not a TBitmap native type
bnWinBitmap,
bnXPixmap,
bnIcon
@ -1130,6 +1130,8 @@ type
TBitmapHandleType = (bmDIB, bmDDB);
{ TBitmapImage }
TBitmapImage = class(TSharedImage)
private
FHandle: HBITMAP; // output device dependent handle
@ -1137,6 +1139,7 @@ type
FPalette: HPALETTE;
FDIBHandle: HBITMAP;// output device independent handle
FSaveStream: TMemoryStream;
FSaveStreamClass: TFPCustomImageWriterClass;
FSaveStreamType: TBitmapNativeType;
protected
procedure FreeHandle; override;
@ -1151,6 +1154,7 @@ type
function GetHandleType: TBitmapHandleType;
property SaveStream: TMemoryStream read FSaveStream write FSaveStream;
property SaveStreamType: TBitmapNativeType read FSaveStreamType write FSaveStreamType;
property SaveStreamClass: TFPCustomImageWriterClass read FSaveStreamClass write FSaveStreamClass;
end;
@ -1170,6 +1174,8 @@ type
);
TBitmapInternalState = set of TBitmapInternalStateFlag;
{ TBitmap }
TBitmap = class(TGraphic)
private
FCanvas: TCanvas;
@ -1179,11 +1185,7 @@ type
FTransparentColor: TColor;
FTransparentMode: TTransparentMode;
FInternalState: TBitmapInternalState;
{$IFDEF DisableFPImage}
FWidth: integer;
FHeight: integer;
{$ENDIF}
Procedure FreeCanvasContext;
procedure FreeCanvasContext;
function GetCanvas: TCanvas;
procedure CreateCanvas;
function GetMonochrome: Boolean;
@ -1217,14 +1219,12 @@ type
procedure SetWidth(NewWidth: Integer); override;
procedure WriteData(Stream: TStream); override;
procedure StoreOriginalStream(Stream: TStream; Size: integer); virtual;
{$IFNDEF DisableFPImage}
procedure WriteStreamWithFPImage(Stream: TStream; WriteSize: boolean;
WriterClass: TFPCustomImageWriterClass); virtual;
procedure InitFPImageReader(ImgReader: TFPCustomImageReader); virtual;
procedure InitFPImageWriter(ImgWriter: TFPCustomImageWriter); virtual;
procedure FinalizeFPImageReader(ImgReader: TFPCustomImageReader); virtual;
procedure FinalizeFPImageWriter(ImgWriter: TFPCustomImageWriter); virtual;
{$ENDIF}
public
constructor Create; override;
destructor Destroy; override;
@ -1252,7 +1252,6 @@ type
procedure WriteStream(Stream: TStream; WriteSize: Boolean); virtual;
Function ReleaseHandle: HBITMAP;
function ReleasePalette: HPALETTE;
{$IFNDEF DisableFPImage}
class function GetFPReaderForFileExt(
const FileExtension: string): TFPCustomImageReaderClass; override;
class function GetFPWriterForFileExt(
@ -1265,7 +1264,7 @@ type
procedure WriteNativeStream(Stream: TStream; WriteSize: Boolean;
SaveStreamType: TBitmapNativeType); virtual;
function CreateIntfImage: TLazIntfImage;
{$ENDIF}
function CanReadGraphicStreams(AClass: TFPCustomImageWriterClass): boolean; virtual;
public
property Canvas: TCanvas read GetCanvas write FCanvas;
property Handle: HBITMAP read GetHandle write SetHandle;
@ -1287,10 +1286,8 @@ type
public
function LazarusResourceTypeValid(const ResourceType: string): boolean; override;
procedure WriteStream(Stream: TStream; WriteSize: Boolean); override;
{$IFNDEF DisableFPImage}
class function GetDefaultFPReader: TFPCustomImageReaderClass; override;
class function GetDefaultFPWriter: TFPCustomImageWriterClass; override;
{$ENDIF}
end;
@ -1302,14 +1299,12 @@ type
public
class function GetFileExtensions: string; override;
class function IsFileExtensionSupported(const FileExtension: string): boolean;
{$IFNDEF DisableFPImage}
class function GetFPReaderForFileExt(
const FileExtension: string): TFPCustomImageReaderClass; override;
class function GetFPWriterForFileExt(
const FileExtension: string): TFPCustomImageWriterClass; override;
class function GetDefaultFPReader: TFPCustomImageReaderClass; override;
class function GetDefaultFPWriter: TFPCustomImageWriterClass; override;
{$ENDIF}
function LazarusResourceTypeValid(const ResourceType: string): boolean; override;
procedure ReadStream(Stream: TStream; UseSize: boolean; Size: Longint); override;
procedure WriteStream(Stream: TStream; WriteSize: Boolean); override;
@ -1322,10 +1317,8 @@ type
TPortableNetworkGraphic = class(TFPImageBitmap)
public
class function GetFileExtensions: string; override;
{$IFNDEF DisableFPImage}
class function GetDefaultFPReader: TFPCustomImageReaderClass; override;
class function GetDefaultFPWriter: TFPCustomImageWriterClass; override;
{$ENDIF}
end;
@ -1339,7 +1332,6 @@ type
Writing is not (yet) implemented.
}
TIcon = class(TBitmap)
{$IFNDEF DisableFPImage}
private
FBitmaps: TObjectList;
protected
@ -1350,7 +1342,6 @@ type
property Bitmaps: TObjectList read FBitmaps;
destructor Destroy; override;
procedure AddBitmap(Bitmap: TBitmap); { Note that Ownership passes to TIcon }
{$ENDIF}
end;
@ -1359,12 +1350,10 @@ function GraphicFilter(GraphicClass: TGraphicClass): string;
function GraphicExtension(GraphicClass: TGraphicClass): string;
function GraphicFileMask(GraphicClass: TGraphicClass): string;
function GetGraphicClassForFileExtension(const FileExt: string): TGraphicClass;
{$IFNDEF DisableFPImage}
function GetFPImageReaderForFileExtension(const FileExt: string
): TFPCustomImageReaderClass;
function GetFPImageWriterForFileExtension(const FileExt: string
): TFPCustomImageWriterClass;
{$ENDIF}
type
// Color / Identifier mapping
@ -1382,10 +1371,8 @@ Function Blue(rgb: TColor): BYTE;
Function Green(rgb: TColor): BYTE;
Function Red(rgb: TColor): BYTE;
procedure RedGreenBlue(rgb: TColor; var Red, Green, Blue: Byte);
{$IFNDEF DisableFPImage}
function FPColorToTColor(const FPColor: TFPColor): TColor;
function TColorToFPColor(const c: TColor): TFPColor;
{$ENDIF}
// fonts
procedure GetCharsetValues(Proc: TGetStrProc);
@ -1786,7 +1773,6 @@ begin
end;
end;
{$IFNDEF DisableFPImage}
function TFPImageBitmap.GetFPReaderForFileExt(const FileExtension: string
): TFPCustomImageReaderClass;
begin
@ -1814,7 +1800,6 @@ function TFPImageBitmap.GetDefaultFPWriter: TFPCustomImageWriterClass;
begin
Result:=nil;
end;
{$ENDIF}
function TFPImageBitmap.LazarusResourceTypeValid(const ResourceType: string
): boolean;
@ -1825,20 +1810,12 @@ end;
procedure TFPImageBitmap.ReadStream(Stream: TStream; UseSize: boolean;
Size: Longint);
begin
{$IFNDEF DisableFPImage}
ReadStreamWithFPImage(Stream,UseSize,Size,GetDefaultFPReader);
{$ELSE}
RaiseGDBException('TFPImageBitmap.ReadStream needs FPImage');
{$ENDIF}
end;
procedure TFPImageBitmap.WriteStream(Stream: TStream; WriteSize: Boolean);
begin
{$IFNDEF DisableFPImage}
WriteStreamWithFPImage(Stream,WriteSize,GetDefaultFPWriter);
{$ELSE}
RaiseGDBException('TFPImageBitmap.WriteStream needs FPImage');
{$ENDIF}
end;
function TFPImageBitmap.GetDefaultMimeType: string;
@ -1951,6 +1928,9 @@ end.
{ =============================================================================
$Log$
Revision 1.175 2005/06/22 09:45:59 mattias
implemented saving alpha bmp and using transparency for IDE glyph editor
Revision 1.174 2005/03/04 13:50:08 mattias
fixed Arc and changed x,y to Left,Top to make meaning more clear

356
lcl/include/bitmap.inc
View File

@ -67,7 +67,7 @@ begin
FreeCanvasContext;
// release old FImage
FImage.Release;
// share FImage with assign graphic
// share FImage with assigned graphic
FImage:=SrcBitmap.FImage;
FImage.Reference;
//DebugLn('TBitMap.Assign B ',Width,',',Height,' ',HandleAllocated,' RefCount=',FImage.RefCount);
@ -457,9 +457,7 @@ procedure TBitmap.UnshareImage(CopyContent: boolean);
var
NewImage: TBitmapImage;
OldImage: TBitmapImage;
{$IFNDEF DisableFPImage}
IntfImage: TLazIntfImage;
{$ENDIF}
begin
if (FImage.RefCount>1) then begin
//DebugLn('TBitmap.UnshareImage ',ClassName,' ',Width,',',Height,' ',DbgS(Self));
@ -470,7 +468,6 @@ begin
if CopyContent and FImage.HandleAllocated
and (Width>0) and (Height>0) then begin
// copy content
{$IFNDEF DisableFPImage}
IntfImage:=TLazIntfImage.Create(0,0);
try
IntfImage.LoadFromBitmap(FImage.FHandle,FImage.FMaskHandle);
@ -481,7 +478,6 @@ begin
finally
IntfImage.Free;
end;
{$ENDIF}
end;
FreeCanvasContext;
OldImage:=FImage;
@ -502,8 +498,10 @@ begin
if FImage.FSaveStream<>nil then begin
//DebugLn('TBitmap.FreeSaveStream A ',ClassName,' ',FImage.FSaveStream.Size);
end;
UnshareImage(false);
FreeAndNil(FImage.FSaveStream);
FImage.SaveStreamType:=bnNone;
FImage.SaveStreamClass:=nil;
end;
procedure TBitmap.ReadStream(Stream: TStream; UseSize: boolean; Size: Longint);
@ -525,7 +523,6 @@ procedure TBitmap.ReadStream(Stream: TStream; UseSize: boolean; Size: Longint);
'TBitmap.ReadStream: Invalid size of bitmap stream (bmp,xpm,ico)');
end;
{$IFNDEF DisableFPImage}
var
CacheStream: TStream;
StreamType: TBitmapNativeType;
@ -576,147 +573,6 @@ begin
CacheStream.Free;
end;
end;
{$ELSE if DisableFPImage}
var
MemStream: TMemoryStream;
procedure CreateEmptyBitmap;
var
DIB: TDIBSection;
begin
FillChar(DIB, sizeof(DIB), 0);
//NewImage(0, 0, DIB, False);
end;
procedure ReadBMPStream;
type
TBitsObj = array[1..1] of byte;
PBitsObj = ^TBitsObj;
const
BI_RGB = 0;
var
BmpHead: TBitmapFileHeader;
ReadSize: integer;
BmpInfo: PBitmapInfo;
ImgSize: longint;
Bits: PBitsObj;
InfoSize: integer;
BitsPerPixel, ColorsUsed: integer;
begin
FillChar(BmpHead,SizeOf(BmpHead),0);
ReadSize:=MemStream.Read(BmpHead, SizeOf(BmpHead));
if (ReadSize<>SizeOf(BmpHead))
or (BmpHead.bfType <> Word($4D42))
or (BmpHead.bfOffBits<DWORD(ReadSize))
then
RaiseInvalidBitmapHeader;
InfoSize:=BmpHead.bfOffBits-SizeOf(BmpHead);
GetMem(BmpInfo,InfoSize);
try
ReadSize:=MemStream.Read(BmpInfo^,InfoSize);
if ReadSize<>InfoSize then
raise EInOutError.Create(
'TBitmap.ReadBMPStream: Invalid windows bitmap (info)');
if BmpInfo^.bmiHeader.biSize<>SizeOf(BitmapInfoHeader) then
raise EInOutError.Create(
'TBitmap.ReadBMPStream: OS2 bitmaps are not supported yet');
if BmpInfo^.bmiHeader.biCompression<>bi_RGB then
raise EInOutError.Create(
'TBitmap.ReadBMPStream: RLE compression is not supported yet');
// Let's now support only 16/24bit bmps! Then we don't need a palette.
BitsPerPixel:=BmpInfo^.bmiHeader.biBitCount;
if BitsPerPixel<16 then begin
ColorsUsed:=BmpInfo^.bmiHeader.biClrUsed;
if ColorsUsed=0 then ColorsUsed:=1 shl ColorsUsed;
// s:=SizeOf(TLogPalette)+(ColorsUsed-1)*SizeOf(TPaletteEntry);
end;
// Palette is fake now. Then it'll be better!
// EInOutError.Create('Only truecolor is supported yet.');
ImgSize:=BmpInfo^.bmiHeader.biSizeImage;
GetMem(Bits,ImgSize);
try
ReadSize:=MemStream.Read(Bits^,ImgSize);
if ReadSize<>ImgSize then
raise EInOutError.Create(
'TBitmap.ReadBMPStream: Invalid windows bitmap (bits)');
Handle := CreateBitmap(BmpInfo^.bmiHeader.biWidth,
BmpInfo^.bmiHeader.biHeight, BmpInfo^.bmiHeader.biPlanes,
BitsPerPixel, Bits);
finally
FreeMem(Bits);
end;
finally
FreeMem(BmpInfo);
end;
end;
procedure ReadXPMStream;
var
XPM: PPChar;
NewWidth, NewHeight, NewColorCount: integer;
begin
XPM:=ReadXPMFromStream(MemStream,Size);
try
if not ReadXPMSize(XPM,NewWidth,NewHeight,NewColorCount) then
raise EInOutError.Create('TBitmap.ReadXPMStream: ERROR: reading xpm');
// free old pixmap
// Create the pixmap
if (FTransparentColor = clNone) or (FTransparentColor = clDefault) 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));
finally
if XPM<>nil then
FreeMem(XPM);
end;
if HandleAllocated then begin
FWidth:=NewWidth;
FHeight:=NewHeight;
end else begin
FWidth:=0;
FHeight:=0;
end;
end;
begin
UnshareImage(false);
if Size = 0 then begin
CreateEmptyBitmap;
exit;
end;
// store original stream
StoreOriginalStream(Stream,Size);
// hide SaveStream (so, that it won't be destroyed due to the change)
MemStream:=FImage.SaveStream;
try
FImage.SaveStream:=nil;
// determine stream type
FImage.SaveStreamType:=TestStreamBitmapNativeType(MemStream);
// read stream
case FImage.SaveStreamType of
bnWinBitmap: ReadBMPStream;
bnXPixmap: ReadXPMStream;
else
RaiseInvalidBitmapHeader;
end;
finally
FImage.SaveStream:=MemStream;
end;
end;
{$ENDIF if DisableFPImage}
procedure TBitmap.LoadFromMimeStream(Stream: TStream; const MimeType: string);
begin
@ -745,163 +601,8 @@ begin
end;
procedure TBitmap.WriteStream(Stream: TStream; WriteSize: Boolean);
{$IFDEF DisableFPImage}
Type
TBITMAPHEADER = packed record
FileHeader : tagBitmapFileHeader;
InfoHeader : tagBitmapInfoHeader;
end;
var
MemStream: TMemoryStream;
Procedure DoWriteStreamSize(DestStream: TStream; Size: longint);
begin
if WriteSize then
DestStream.WriteBuffer(Size, SizeOf(Size));
end;
procedure DoWriteOriginal;
begin
DoWriteStreamSize(Stream,longint(FImage.SaveStream.Size));
FImage.SaveStream.Position:=0;
Stream.CopyFrom(FImage.SaveStream,longint(FImage.SaveStream.Size));
end;
Procedure DoWriteSize(Header: TBitmapHeader);
begin
DoWriteStreamSize(MemStream,Header.FileHeader.bfSize);
end;
Procedure FillBitmapInfo(Bitmap : hBitmap; var Bits : Pointer;
Var Header : TBitmapHeader);
var
ScreenDC, DC : hDC;
DIB : TDIBSection;
BitmapHeader : TagBITMAPINFO;
begin
FillChar(DIB, SizeOf(DIB), 0);
GetObject(Bitmap, SizeOf(DIB), @DIB);
with DIB.dsbm, DIB.dsbmih do
begin
biSize := sizeof(DIB.dsbmih);
biWidth := bmWidth;
biHeight := bmHeight;
biPlanes := 1;
biBitCount := bmPlanes * bmBitsPixel;
if biSizeImage = 0 then begin
biSizeImage := ((bmWidth * biBitCount) + 31) and not 31;
biSizeImage := biSizeImage div 8;
biSizeImage := Abs(biSizeImage) * Abs(bmHeight);
end;
end;
Bits := AllocMem(Longint(Dib.dsBmih.biSizeImage)*SizeOf(Byte));
BitmapHeader.bmiHeader := DIB.dsbmih;
ScreenDC := GetDC(0);
DC := CreateCompatibleDC(ScreenDC);
GetDIBits(DC, Bitmap, 0, Abs(Dib.dsBmih.biHeight), Bits, BitmapHeader, DIB_RGB_COLORS);
ReleaseDC(0, ScreenDC);
DeleteDC(DC);
With Header, Header.FileHeader, Header.InfoHeader do begin
InfoHeader := BitmapHeader.bmiHeader;
FillChar(FileHeader, sizeof(FileHeader), 0);
bfType := $4D42;
bfSize := SizeOf(Header) + biSizeImage;
bfOffBits := SizeOf(Header);
end;
end;
Procedure WriteBitmapHeader(Header : TBitmapHeader);
begin
MemStream.WriteBuffer(Header, SizeOf(Header));
end;
Procedure WriteTRIColorMap(Color : PLongint; size : Longint); //For OS/2 Bitmaps
var
I : Longint;
TRI : RGBTRIPLE;
begin
size := size div 3;
for i := 0 to size - 1 do
begin
Tri.rgbtBlue := Blue(Color[i]);
Tri.rgbtGreen := Green(Color[i]);
Tri.rgbtRed := Red(Color[i]);
MemStream.WriteBuffer(Tri, 3);
end;
end;
Procedure WriteQUADColorMap(Color : PLongint; size : Longint); //For MS Bitmaps
var
I : Longint;
Quad : RGBQUAD;
begin
size := size div 4;
for i := 0 to size - 1 do
begin
FillChar(QUAD, SizeOf(RGBQUAD),0);
Quad.rgbBlue := Blue(Color[i]);
Quad.rgbGreen := Green(Color[i]);
Quad.rgbRed := Red(Color[i]);
MemStream.WriteBuffer(Quad, 4);
end;
end;
Procedure WriteColorMap(Header : TBitmapHeader);
begin
///Figure out how to get colors then call Quad/Tri
end;
Procedure WritePixels(Bits : PByte; Header : TBitmapHeader);
begin
MemStream.WriteBuffer(Bits^, Header.InfoHeader.biSizeImage);
end;
var
Bits: PByte;
Header: TBitmapHeader;
StreamSize: TStreamSeekType;
{$ENDIF}
begin
{$IFNDEF DisableFPImage}
WriteStreamWithFPImage(Stream,WriteSize,TFPWriterBMP);
if (FImage.SaveStream<>nil) and (FImage.SaveStreamType=bnNone) then
FImage.SaveStreamType:=bnWinBitmap;
{$ELSE}
if (FImage.SaveStream<>nil) and (FImage.SaveStream.Size>0)
and (FImage.SaveStreamType<>bnNone) then begin
DoWriteOriginal;
exit;
end;
DebugLn('TBitmap.WriteStream A Warning: creating BMP does not always work ',
dbgs(FImage.SaveStream<>nil),' ',dbgs(ord(FImage.SaveStreamType)),'. Please use FPImage.');
// write image in BMP format to temporary stream
MemStream:=TMemoryStream.Create;
try
Bits:=nil;
FillBitmapInfo(Handle, Bits, Header);
WriteBitmapHeader(Header);
WriteColorMap(Header);
WritePixels(Bits, Header);
// save stream, so that further saves will be fast
MemStream.Position:=0;
FreeSaveStream;
FImage.SaveStream:=MemStream;
MemStream:=nil;
FImage.SaveStreamType:=bnWinBitmap;
// copy savestream to destination stream
if WriteSize then begin
StreamSize:=FImage.SaveStream.Size;
Stream.WriteBuffer(StreamSize, SizeOf(StreamSize));
end;
Stream.CopyFrom(FImage.SaveStream,FImage.SaveStream.Size);
finally
ReallocMem(Bits, 0);
MemStream.Free;
end;
{$ENDIF}
end;
procedure TBitmap.StoreOriginalStream(Stream: TStream; Size: integer);
@ -916,10 +617,18 @@ begin
FImage.FSaveStream:=MemStream;
end;
FImage.SaveStreamType:=bnNone;
FImage.SaveStreamClass:=nil;
FImage.SaveStream.Position:=0;
end;
{$IFNDEF DisableFPImage}
function TBitmap.CanReadGraphicStreams(AClass: TFPCustomImageWriterClass
): boolean;
begin
Result:=(AClass=GetDefaultFPWriter)
or (((ClassType=TBitmap) or (ClassType=TPixmap))
and ((AClass=TFPWriterBMP) or (AClass=TLazWriterXPM)));
end;
{------------------------------------------------------------------------------
procedure TBitmap.ReadStreamWithFPImage(Stream: TStream; UseSize: boolean;
Size: Longint; ReaderClass: TFPCustomImageReaderClass);
@ -928,7 +637,7 @@ end;
Stream: source stream. After reading Position will be at end of bitmap.
UseSize: if True, Size is used. If False then Size is calculated
automatically.
Size: Only used when UseSize=True. This amount of bytes are read.
Size: Only used when UseSize=True. This amount of bytes is read.
------------------------------------------------------------------------------}
procedure TBitmap.ReadStreamWithFPImage(Stream: TStream; UseSize: boolean;
Size: Longint; ReaderClass: TFPCustomImageReaderClass);
@ -996,6 +705,13 @@ begin
finally
// set save stream
FImage.SaveStream:=NewSaveStream;
if ReaderClass=TFPReaderBMP then begin
FImage.SaveStreamType:=bnWinBitmap;
FImage.SaveStreamClass:=TFPWriterBMP;
end else if ReaderClass=TLazReaderXPM then begin
FImage.SaveStreamType:=bnXPixmap;
FImage.SaveStreamClass:=TLazWriterXPM;
end;
// clean up
IntfImg.Free;
ImgReader.Free;
@ -1025,12 +741,17 @@ var
ImgWriter: TFPCustomImageWriter;
begin
//DebugLn('WriteStreamWithFPImage Self=',DbgS(Self),' ',Width,',',Height,' Using SaveStream=',(FImage.SaveStream<>nil) and (FImage.SaveStream.Size>0));
if (FImage.SaveStream<>nil) and (FImage.SaveStream.Size>0) then begin
if (FImage.SaveStream<>nil) and (FImage.SaveStream.Size>0)
and ((FImage.SaveStreamType<>bnNone)
or CanReadGraphicStreams(FImage.SaveStreamClass))
then begin
// it's a stream format, that this graphic class can read
// (important for restore)
DoWriteOriginal;
exit;
end;
//DebugLn('WriteStreamWithFPImage');
// write image to temporary stream
MemStream:=TMemoryStream.Create;
IntfImg:=nil;
@ -1048,7 +769,13 @@ begin
MemStream.Position:=0;
FreeSaveStream;
FImage.SaveStream:=MemStream;
FImage.SaveStreamType:=bnNone;
if WriterClass=TLazWriterXPM then
FImage.SaveStreamType:=bnXPixmap
else if WriterClass=TFPWriterBMP then
FImage.SaveStreamType:=bnWinBitmap
else
FImage.SaveStreamType:=bnNone;
FImage.SaveStreamClass:=WriterClass;
MemStream:=nil;
// copy savestream to destination stream
DoWriteOriginal;
@ -1070,7 +797,8 @@ end;
procedure TBitmap.InitFPImageWriter(ImgWriter: TFPCustomImageWriter);
begin
if ImgWriter.ClassType=TFPWriterBMP then
TFPWriterBMP(ImgWriter).BytesPerPixel:=4; // allow alpha
end;
procedure TBitmap.FinalizeFPImageReader(ImgReader: TFPCustomImageReader);
@ -1082,7 +810,6 @@ procedure TBitmap.FinalizeFPImageWriter(ImgWriter: TFPCustomImageWriter);
begin
end;
{$ENDIF}
procedure TBitMap.SaveToStream(Stream: TStream);
begin
@ -1148,7 +875,6 @@ begin
Result := 0;
end;
{$IFNDEF DisableFPImage}
function TBitmap.GetFPReaderForFileExt(const FileExtension: string
): TFPCustomImageReaderClass;
begin
@ -1189,7 +915,7 @@ end;
function TBitmap.GetDefaultFPWriter: TFPCustomImageWriterClass;
begin
if (AnsiCompareText(ClassName,'TBitmap')=0) then
if ClassType=TBitmap then
Result:=TFPWriterBMP
else
Result:=nil;
@ -1207,8 +933,10 @@ begin
RaiseGDBException('Invalid SaveStreamType');
end;
WriteStreamWithFPImage(Stream,WriteSize,Writer);
if (FImage.SaveStream<>nil) and (FImage.SaveStreamType=bnNone) then
if (FImage.SaveStream<>nil) and (FImage.SaveStreamType=bnNone) then begin
FImage.SaveStreamType:=SaveStreamType;
FImage.SaveStreamClass:=Writer;
end;
end;
function TBitmap.CreateIntfImage: TLazIntfImage;
@ -1216,7 +944,6 @@ begin
Result:=TLazIntfImage.Create(0,0);
Result.LoadFromBitmap(Handle,MaskHandle);
end;
{$ENDIF}
function TBitmap.GetEmpty: boolean;
begin
@ -1278,6 +1005,9 @@ end;
{ =============================================================================
$Log$
Revision 1.97 2005/06/22 09:45:59 mattias
implemented saving alpha bmp and using transparency for IDE glyph editor
Revision 1.96 2005/03/07 21:59:44 vincents
changed hexstr(cardinal()) for pointers to dbgs() and other 64-bits fixes from Peter Vreman

1
lcl/include/bitmapimage.inc
View File

@ -20,6 +20,7 @@ destructor TBitmapImage.Destroy;
begin
FreeAndNil(FSaveStream);
FSaveStreamType:=bnNone;
FSaveStreamClass:=nil;
if FDIBHandle <> 0 then
begin
DeleteObject(FDIBHandle);

12
lcl/include/pixmap.inc
View File

@ -267,12 +267,9 @@ begin
Result:=(ResourceType='XPM');
end;
{$IFNDEF DisableFPImage}
procedure TPixmap.WriteStream(Stream: TStream; WriteSize: Boolean);
begin
WriteStreamWithFPImage(Stream,WriteSize,TLazWriterXPM);
if (FImage.SaveStream<>nil) and (FImage.SaveStreamType=bnNone) then
FImage.SaveStreamType:=bnXPixmap;
end;
function TPixmap.GetDefaultFPReader: TFPCustomImageReaderClass;
@ -284,12 +281,6 @@ function TPixmap.GetDefaultFPWriter: TFPCustomImageWriterClass;
begin
Result:=TLazWriterXPM;
end;
{$ELSE DisableFPImage}
procedure TPixmap.WriteStream(Stream: TStream; WriteSize: Boolean);
begin
inherited WriteStream(Stream,WriteSize);
end;
{$ENDIF}
// included by graphics.pp
@ -297,6 +288,9 @@ end;
{ =============================================================================
$Log$
Revision 1.31 2005/06/22 09:45:59 mattias
implemented saving alpha bmp and using transparency for IDE glyph editor
Revision 1.30 2004/09/14 10:23:44 mattias
implemented finding DefineProperties in registered TPersistent, implemented auto commenting of missing units for Delphi unit conversion

13
lcl/intfgraphics.pas
View File

@ -110,6 +110,8 @@ type
Prec, Shift: cardinal; Bits: word);
{ TLazIntfImage }
TLazIntfImage = class(TFPCustomImage)
private
FAutoCreateMask: boolean;
@ -191,6 +193,7 @@ type
procedure CreateAllData; virtual;
procedure CreatePixelData; virtual;
procedure CreateMaskData; virtual;
function HasTransparency: boolean; virtual;
public
property PixelData: PByte read FPixelData;
property MaskData: PByte read FMaskData;
@ -1537,6 +1540,16 @@ begin
ChooseGetSetColorFunctions;
end;
function TLazIntfImage.HasTransparency: boolean;
var
RawImage: TRawImage;
begin
Result:=true;
GetRawImage(RawImage);
if not RawImageMaskIsEmpty(@RawImage,true) then exit;
Result:=false;
end;
procedure TLazIntfImage.CreateDataAndLineStarts(var Data: Pointer;
var DataSize: cardinal; var TheLineStarts: PRawImagePosition;
TheBitsPerPixel: cardinal; TheLineEnd: TRawImageLineEnd);