How to save / load any TPicture-contained TGraphic to / from a stream (Views: 34)
Problem/Question/Abstract: How to save / load any TPicture-contained TGraphic to / from a stream Answer: I have a general solution for storing (and loading back) any TPicture-contained TGraphic's into and from a stream (no need to know which TGraphic descendant is contained in the TPicture): TPictureFiler = class(TFiler) public ReadData: TStreamProc; WriteData: TStreamProc; constructor Create; overload; procedure DefineProperty(const Name: string; ReadData: TReaderProc; WriteData: TWriterProc; HasData: Boolean); override; procedure DefineBinaryProperty(const Name: string; ReadData, WriteData: TStreamProc; HasData: Boolean); override; procedure FlushBuffer; override; end; {Since I use TFiler only partially, the inherited constructor TFiler.Create is unnecessary, so I use this dummy} constructor TPictureFiler.Create; begin end; {Will be called by TPicture, handing over the private methods to read/write TPicture from/to Stream} procedure TPictureFiler.DefineBinaryProperty(const Name: string; ReadData, WriteData: TStreamProc; HasData: Boolean); begin if Name = 'Data' then begin Self.ReadData := ReadData; Self.WriteData := WriteData; end; end; procedure TPictureFiler.DefineProperty(const Name: string; ReadData: TReaderProc; WriteData: TWriterProc; HasData: Boolean); begin {At this time TPicture don't call this function. Only implemented as a precaution to (unlikely) changes in future Delphi versions} end; procedure TPictureFiler.FlushBuffer; begin {At this time TPicture don't call this function. Only implemented as precaution to (unlikely) changes in future Delphi versions} end; {Wrapper to call protected TPicture.DefineProperties. Must be in same unit as ReadWritePictureFromStream} type TMyPicture = class(TPicture) end; procedure ReadWritePictureFromStream(Picture: TPicture; Stream: TStream; Read: Boolean); var Filer: TPictureFiler; begin Filer := TPictureFiler.Create; try {TPicture.DefineProperties is protected, but TMyPicture is declared in this unit. TMyPicture's protected members (also the inherited) are public to this unit} TMyPicture(Picture).DefineProperties(Filer); {TPicture.DefineProperties calls Filer.DefineBinaryProperty} if Read then Filer.ReadData(Stream) {TPicture does the work} else Filer.WriteData(Stream); {TPicture does the work} finally Filer.Free; end; end; {Whatever TIcons actual image size, its LoadFromStream(Stream: TStream) reads just to the end of the stream. If I have additional things after TIcon streamed, they are lost after TIcon.LoadFromStream. So I store the actual size before in the stream} procedure WritePictureToStream(Picture: TPicture; Stream: TStream); var MStream: TMemoryStream; iPictureSize: Integer; begin MStream := TMemoryStream.Create; try ReadWritePictureFromStream(Picture, MStream, False); {Store TPicture data in TMemoryStream} iPictureSize := MStream.Size; Stream.WriteBuffer(iPictureSize, sizeof(iPictureSize)); {Store size of TPicture data in TStream} Stream.WriteBuffer(MStream.Memory^, iPictureSize); {Store TMemoryStream(containing TPicture data) in TStream} finally MStream.Free; end; end; procedure ReadPictureFromStream(Picture: TPicture; Stream: TStream); var MStream: TMemoryStream; iPictureSize: Integer; begin MStream := TMemoryStream.Create; try Stream.ReadBuffer(iPictureSize, sizeof(iPictureSize)); {Read size of TPicture data} MStream.SetSize(iPictureSize); {adjust buffer size} Stream.ReadBuffer(MStream.Memory^, iPictureSize); {get TPicture data} {Why TMemoryStream ? See what I said above about TIcon} ReadWritePictureFromStream(Picture, MStream, True); {read TPicture data} finally MStream.Free; end; end; Now WritePictureToStream and ReadPictureFromStream could be used to save/load any TPicture to / from any TStream. Example (in pseudo code): TStream := TDataSet.CreateBlobStream(TBlobField, bmWrite); try WritePictureToStream(TPicture, TStream); finally TStream.Free; end; TStream := TDataSet.CreateBlobStream(TBlobField, bmRead); try ReadPictureFromStream(TPicture, TStream); finally TStream.Free; end; Perhaps this looks a bit tricky, but I think changes to the VCL and TPicture streaming system are very unlikely. |