// included by graphics.pp {****************************************************************************** TBitMap ****************************************************************************** ***************************************************************************** * * * This file is part of the Lazarus Component Library (LCL) * * * * See the file COPYING.LCL, included in this distribution, * * for details about the copyright. * * * * This program is distributed in the hope that it will be useful, * * but WITHOUT ANY WARRANTY; without even the implied warranty of * * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. * * * ***************************************************************************** } function TestStreamBitmapNativeType(Stream: TMemoryStream): TBitmapNativeType; begin if TestStreamIsBMP(Stream) then Result:=bnWinBitmap else if TestStreamIsXPM(Stream) then Result:=bnXPixmap else Result:=bnNone; end; function TestStreamIsBMP(Stream: TMemoryStream): boolean; var BmpHeadbfType: word; ReadSize: Integer; OldPosition: Integer; begin BmpHeadbfType:=0; OldPosition:=Stream.Position; ReadSize:=Stream.Read(BmpHeadbfType,2); Result:=(ReadSize=2) and (BmpHeadbfType=word($4D42)); Stream.Position:=OldPosition; end; procedure TBitMap.Assign(Source: TPersistent); var SrcBitmap: TBitmap; begin //TODO: Finish TBITMAP ASSIGN if Source=Self then exit; if Source is TBitmap then begin UnshareImage; SrcBitmap:=TBitmap(Source); SetWidthHeight(SrcBitmap.Width,SrcBitmap.Height); Canvas.Brush.Color:=clWhite; Canvas.FillRect(Rect(0,0,Width,Height)); SrcBitmap.Draw(Canvas,Rect(0,0,Width,Height)); end else inherited; end; procedure TBitmap.Draw(ACanvas: TCanvas; const ARect: TRect); begin HandleNeeded; if HandleAllocated then ACanvas.CopyRect(ARect, Self.Canvas, Rect(0, 0, Width, Height)); end; constructor TBitmap.VirtualCreate; begin inherited VirtualCreate; FPixelFormat := pfDevice; FImage := TBitmapImage.Create; FImage.Reference; FTransparentColor := clNone; end; destructor TBitMap.Destroy; begin FreeCanvasContext; FImage.Release; FImage:=nil; FreeThenNil(FCanvas); inherited Destroy; end; procedure TBitMap.FreeCanvasContext; begin if (FCanvas <> nil) then TBitmapCanvas(FCanvas).FreeDC; end; function TBitmap.GetCanvas: TCanvas; begin if FCanvas = nil then begin HandleNeeded; CreateCanvas; end; Result := FCanvas; end; procedure TBitmap.CreateCanvas; begin if (FCanvas <> nil) or (bmisCreateingCanvas in FInternalState) then exit; Include(FInternalState,bmisCreateingCanvas); try FCanvas := TBitmapCanvas.Create(Self); FCanvas.OnChange := @Changed; FCanvas.OnChanging := @Changing; finally Exclude(FInternalState,bmisCreateingCanvas); end; end; procedure TBitMap.FreeImage; begin Handle := 0; end; function TBitmap.HandleAllocated: boolean; begin Result:=FImage.FHandle<>0; end; procedure TBitMap.Mask(ATransparentColor: TColor); begin end; function TBitmap.GetHandle: HBITMAP; begin UnshareImage; if FImage.FHandle=0 then HandleNeeded; Changing(Self); Result := FImage.FHandle; end; function TBitmap.GetHandleType: TBitmapHandleType; begin Result:=FImage.GetHandleType; end; function TBitmap.GetMaskHandle: HBITMAP; begin MaskHandleNeeded; Result := FImage.FMaskHandle; end; function TBitmap.GetScanline(Row: Integer): Pointer; begin // ToDo: Result:=nil; end; procedure TBitmap.SetHandleType(Value: TBitmapHandleType); begin end; procedure TBitmap.SetPixelFormat(const AValue: TPixelFormat); begin if AValue=PixelFormat then exit; writeln('WARNING: TBitmap.SetPixelFormat not implemented'); end; procedure TBitmap.UpdatePixelFormat; begin FPixelFormat := FImage.GetPixelFormat; end; procedure TBitmap.Changed(Sender: TObject); begin //FMaskBitsValid := False; inherited Changed(Sender); end; procedure TBitmap.Changing(Sender: TObject); // called before the bitmap is modified // -> make sure the handle is unshared (otherwise the modifications will also // modify all copies) begin UnshareImage; FImage.FDIB.dsbmih.biClrUsed := 0; FImage.FDIB.dsbmih.biClrImportant := 0; FreeAndNil(FImage.FSaveStream); FImage.SaveStreamType:=bnNone; end; procedure TBitMap.HandleNeeded; var n : integer; UseWidth, UseHeight : Longint; OldChangeEvent: TNotifyEvent; begin if (FImage.FHandle <> 0) then exit; // if the bitmap was loaded, create a handle from stream if (FImage.FDIBHandle = 0) and (FImage.FSaveStream <> nil) then begin FImage.FSaveStream.Position := 0; OldChangeEvent := OnChange; try OnChange := nil; LoadFromStream(FImage.FSaveStream); // Current FImage may be destroyed here finally OnChange := OldChangeEvent; end; end; if (FImage.FHandle = 0) then begin case PixelFormat of pfDevice : n:= ScreenInfo.ColorDepth; pf1bit : n:= 1; pf4bit : n:= 4; pf8bit : n:= 8; pf15bit : n:= 15; pf16bit : n:= 16; pf24bit : n:= 24; pf32bit : n:= 32; else raise EInvalidOperation.Create(rsUnsupportedBitmapFormat); end; UseWidth := Width; UseHeight := Height; if UseWidth<1 then UseWidth:=1; if UseHeight<1 then UseHeight:=1; FImage.FHandle:= CreateBitmap(UseWidth, UseHeight, 1, n, nil); end; end; procedure TBitMap.MaskHandleNeeded; begin //TODO end; procedure TBitmap.LoadFromLazarusResource(const ResName: String); var ms:TMemoryStream; res:TLResource; begin res:=LazarusResources.Find(ResName); if (res<>nil) and (res.Value<>'') then begin ms:=TMemoryStream.Create; try ms.Write(res.Value[1],length(res.Value)); ms.Position:=0; LoadFromStream(ms); finally ms.Free; end; end; end; procedure TBitMap.LoadFromStream(Stream: TStream); begin ReadStream(Stream, Stream.Size - Stream.Position); end; procedure TBitMap.LoadFromResourceName(Instance: THandle; const ResName: String); begin writeln('ToDo: TBitMap.LoadFromResourceName'); end; procedure TBitMap.LoadFromResourceID(Instance: THandle; ResID: Integer); begin writeln('ToDo: TBitMap.LoadFromResourceID'); end; procedure TBitmap.LoadFromClipboardFormat(FormatID: TClipboardFormat); begin writeln('ToDo: TBitMap.LoadFromClipboardFormat'); end; procedure TBitmap.SaveToClipboardFormat(FormatID: TClipboardFormat); begin writeln('ToDo: TBitmap.SaveToClipboardFormat'); end; Procedure TBitmap.LoadFromXPMFile(const Filename : String); var pstr : PChar; Begin HandleNeeded; if (Filename<>'') and HandleAllocated then begin pStr:=PChar(Filename); SendIntfMessage(LM_LOADXPM,Self,pstr); end; end; Procedure TBitmap.NewImage(NHandle: HBITMAP; NPallette: HPALETTE; const NDIB : TDIBSection; OS2Format : Boolean); Begin end; procedure TBitMap.PaletteNeeded; begin end; procedure TBitmap.UnshareImage; begin if (FImage.RefCount>1) then begin writeln('TBitmap.UnshareImage'); // release old FImage and create a new one FreeCanvasContext; FImage.Release; FImage := TBitmapImage.Create; FImage.Reference; end; end; procedure TBitmap.ReadStream(Stream: TStream; Size: Longint); var MemStream: TMemoryStream; procedure RaiseInvalidBitmapHeader; begin raise EInOutError.Create( 'TBitmap.ReadStream: Invalid windows bitmap (header)'); end; 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.bfOffBitsInfoSize 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 24bit bmps! Then we can use the palette. BitsPerPixel:=BmpInfo^.bmiHeader.biBitCount; if BitsPerPixel<>24 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; if Size = 0 then begin CreateEmptyBitmap; exit; end; // store original stream if Stream<>FImage.SaveStream then begin MemStream:=TMemoryStream.Create; MemStream.CopyFrom(Stream,Stream.Size); FreeAndNil(FImage.FSaveStream); FImage.SaveStream:=MemStream; end else MemStream:=FImage.SaveStream; FImage.SaveStreamType:=bnNone; MemStream.Position:=0; // determine stream type FImage.SaveStreamType:=TestStreamBitmapNativeType(MemStream); // read stream case FImage.SaveStreamType of bnWinBitmap: ReadBMPStream; bnXPixmap: ReadXPMStream; else RaiseInvalidBitmapHeader; end; end; procedure TBitmap.SetWidthHeight(NewWidth, NewHeight: integer); begin with FImage do if (FDIB.dsbm.bmHeight <> NewHeight) or (FDIB.dsbm.bmWidth <> NewWidth) then begin FDIB.dsbm.bmWidth := NewWidth; FDIB.dsbm.bmHeight := NewHeight; If (NewWidth > 0) and (NewHeight > 0) then HandleNeeded else FreeImage; Changed(Self); end; end; procedure TBitmap.WriteStream(Stream: TStream; WriteSize: Boolean); Type TBITMAPHEADER = packed record FileHeader : tagBitmapFileHeader; InfoHeader : tagBitmapInfoHeader; 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 DoWriteStreamSize(Size: longint); begin if WriteSize then Stream.WriteBuffer(Size, SizeOf(Size)); end; Procedure DoWriteSize(Header : TBitmapHeader); begin DoWriteStreamSize(Header.FileHeader.bfSize); end; Procedure WriteBitmapHeader(Header : TBitmapHeader); begin Stream.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]); Stream.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]); Stream.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 Stream.WriteBuffer(Bits^, Header.InfoHeader.biSizeImage); end; procedure DoWriteOriginal; begin DoWriteStreamSize(FImage.SaveStream.Size); FImage.SaveStream.Position:=0; Stream.CopyFrom(FImage.SaveStream,FImage.SaveStream.Size); end; var Bits: PByte; Header: TBitmapHeader; begin if (FImage.SaveStream<>nil) and (FImage.SaveStream.Size>0) and (FImage.SaveStreamType<>bnNone) then begin DoWriteOriginal; exit; end; Bits:=nil; try FillBitmapInfo(Handle, Bits, Header); DoWriteSize(Header); WriteBitmapHeader(Header); WriteColorMap(Header); WritePixels(Bits, Header); finally ReallocMem(Bits, 0); end; end; procedure TBitMap.SaveToStream(Stream: TStream); begin WriteStream(Stream, False); end; procedure TBitmap.SetHandle(Value: HBITMAP); begin if FImage.FHandle = Value then exit; if FImage.FHandle<>0 then begin UnshareImage; FreeCanvasContext; end; // TODO: get the properties from new bitmap with FImage do begin FreeHandle; FHandle:=Value; FillChar(FDIB, sizeof(FDIB), 0); if FHandle <> 0 then GetObject(FHandle, SizeOf(FDIB), @FDIB); Changed(Self); end; end; procedure TBitmap.SetMaskHandle(Value: HBITMAP); begin with FImage do begin if FMaskHandle <> Value then begin FMaskHandle := Value; //FMaskBitsValid := True; //FMaskValid := True; end; end; end; // creates handle and remove all references to give up ownership Function TBitmap.ReleaseHandle: HBITMAP; Begin HandleNeeded; FreeCanvasContext; Result := FImage.ReleaseHandle; end; function TBitmap.ReleasePalette: HPALETTE; begin // ToDo Result := 0; end; function TBitmap.GetEmpty: boolean; begin Result:=FImage.IsEmpty; end; function TBitmap.GetHeight: Integer; begin with FImage do Result := FDIB.dsbm.bmHeight; end; function TBitmap.GetPalette: HPALETTE; begin Result:=inherited GetPalette; end; function TBitmap.GetWidth: Integer; begin with FImage do Result := FDIB.dsbm.bmWidth; end; procedure TBitmap.ReadData(Stream: TStream); var Size: Longint; begin Stream.Read(Size, SizeOf(Size)); ReadStream(Stream, Size); end; procedure TBitmap.WriteData(Stream: TStream); begin WriteStream(Stream, True); end; procedure TBitmap.SetWidth(NewWidth: Integer); begin SetWidthHeight(NewWidth,Height); end; procedure TBitmap.SetHeight(NewHeight: Integer); begin SetWidthHeight(Width,NewHeight); end; procedure TBitmap.SetPalette(Value: HPALETTE); begin inherited SetPalette(Value); end; procedure TBitmap.SetTransparentMode(Value: TTransparentMode); begin if Value=TransparentMode then exit; writeln('TBitmap.SetTransparentMode not implemented'); end; // included by graphics.pp { ============================================================================= $Log$ Revision 1.36 2003/06/30 17:25:26 mattias fixed parsing of with do try finally end Revision 1.35 2003/06/30 16:31:04 mattias fixed find declaration of with A,B do C; statements Revision 1.34 2003/06/30 15:13:21 mattias fixed releasing bitmap handle Revision 1.33 2003/06/30 14:58:29 mattias implemented multi file add to package editor Revision 1.32 2003/06/30 10:09:46 mattias fixed Get/SetPixel for DC without widget Revision 1.31 2003/06/25 10:38:28 mattias implemented saving original stream of TBitmap Revision 1.30 2003/06/07 17:14:11 mattias small changes for fpc 1.1 Revision 1.29 2003/04/03 17:42:13 mattias added exception handling for createpixmapindirect Revision 1.28 2003/03/12 14:39:29 mattias fixed clipping origin in stretchblt Revision 1.27 2003/03/11 07:46:43 mattias more localization for gtk- and win32-interface and lcl Revision 1.26 2003/02/04 14:36:19 mattias fixed set method in OI Revision 1.25 2002/12/16 12:12:50 mattias fixes for fpc 1.1 Revision 1.24 2002/12/12 17:47:46 mattias new constants for compatibility Revision 1.23 2002/11/12 10:16:16 lazarus MG: fixed TMainMenu creation Revision 1.22 2002/11/09 15:02:06 lazarus MG: fixed LM_LVChangedItem, OnShowHint, small bugs Revision 1.21 2002/10/25 10:42:08 lazarus MG: broke minor circles Revision 1.20 2002/09/16 15:42:17 lazarus MG: fixed calling DestroyHandle if not HandleAllocated Revision 1.19 2002/09/13 16:58:27 lazarus MG: removed the 1x1 bitmap from TBitBtn Revision 1.18 2002/09/12 05:56:15 lazarus MG: gradient fill, minor issues from Andrew Revision 1.17 2002/09/10 06:49:19 lazarus MG: scrollingwincontrol from Andrew Revision 1.16 2002/09/03 08:07:19 lazarus MG: image support, TScrollBox, and many other things from Andrew 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 Revision 1.13 2002/05/10 06:05:51 lazarus MG: changed license to LGPL Revision 1.12 2001/12/21 18:16:59 lazarus Added TImage class Shane Revision 1.11 2001/10/10 17:55:04 lazarus MG: fixed caret lost, gtk cleanup, bracket lvls, bookmark saving Revision 1.10 2001/09/30 08:34:49 lazarus MG: fixed mem leaks and fixed range check errors Revision 1.9 2001/06/26 00:08:35 lazarus MG: added code for form icons from Rene E. Beszon Revision 1.8 2001/06/14 14:57:58 lazarus MG: small bugfixes and less notes Revision 1.7 2001/06/04 09:32:17 lazarus MG: fixed bugs and cleaned up messages Revision 1.6 2001/03/21 00:20:29 lazarus MG: fixed memory leaks Revision 1.5 2001/03/19 14:00:50 lazarus MG: fixed many unreleased DC and GDIObj bugs Revision 1.4 2001/03/12 09:40:44 lazarus MG: bugfix for readstream Revision 1.3 2001/03/05 14:20:04 lazarus added streaming to tgraphic, added tpicture Revision 1.2 2000/12/29 20:32:33 lazarus Speedbuttons can now draw disabled images. Shane Revision 1.1 2000/07/13 10:28:24 michael + Initial import Revision 1.2 2000/05/09 00:46:41 lazarus Changed writelns to Asserts. CAW Revision 1.1 2000/04/02 20:49:55 lazarus MWE: Moved lazarus/lcl/*.inc files to lazarus/lcl/include Revision 1.18 2000/03/30 18:07:53 lazarus Added some drag and drop code Added code to change the unit name when it's saved as a different name. Not perfect yet because if you are in a comment it fails. Shane Revision 1.17 2000/03/21 23:47:33 lazarus MWE: + Added TBitmap.MaskHandle & TGraphic.Draw & TBitmap.Draw Revision 1.16 2000/03/19 03:52:08 lazarus Added onclick events for the speedbuttons. Shane Revision 1.15 2000/03/16 23:58:46 lazarus MWE: Added TPixmap for XPM support Revision 1.14 2000/03/15 20:15:31 lazarus MOdified TBitmap but couldn't get it to work Shane Revision 1.13 2000/03/10 12:51:14 lazarus *** empty log message *** Revision 1.12 2000/03/07 19:00:15 lazarus Minor changes. Added the skeleton for TSpeedbutton Shane Revision 1.11 2000/03/06 00:05:05 lazarus MWE: Added changes from Peter Dyson for a new release of mwEdit (0.92) Revision 1.10 2000/01/18 22:18:34 lazarus Moved bitmap creation into appropriate place. Cleaned up a bit. Finished DeleteObject procedure. Revision 1.9 1999/12/31 14:58:00 lazarus MWE: Set unkown VK_ codesto 0 Added pfDevice support for bitmaps Revision 1.8 1999/12/18 18:27:31 lazarus MWE: Rearranged some events to get a LM_SIZE, LM_MOVE and LM_WINDOWPOSCHANGED Initialized the TextMetricstruct to zeros to clear unset values Get mwEdit to show more than one line Fixed some errors in earlier commits Revision 1.7 1999/12/14 22:05:37 lazarus More changes for TToolbar Shane Revision 1.6 1999/11/25 23:45:08 lazarus MWE: Added font as GDIobject Added some API testcode to testform Commented out some more IFDEFs in mwCustomEdit Revision 1.5 1999/11/17 01:16:39 lazarus MWE: Added some more API stuff Added an initial TBitmapCanvas Added some DC stuff Changed and commented out, original gtk linedraw/rectangle code. This is now called through the winapi wrapper. }