Google Groups no longer supports new Usenet posts or subscriptions. Historical content remains viewable.
Dismiss

Jpeg в БД

9 views
Skip to first unread message

Igor Cheban

unread,
May 15, 2000, 3:00:00 AM5/15/00
to
Hello All.

Hедавно здесь пpоходил пpимеpчик для хpанения (отобpажения) jpeg в БД. Пpошу,
намыльте мне, а то диск гpохнулся, пpимеpчики все вместе с ним.


Игоpь.


Alexander Grischenko

unread,
May 18, 2000, 3:00:00 AM5/18/00
to

"Igor Cheban" <Igor....@p14.f117.n469.z2.fidonet.org> wrote in message
news:9584...@p14.f117.n469.z2.ftn...

Того примера у меня нет. Могу взамен предложить свое видение :)

Нужно создать dpk и заргистрировать его в IDE
Затем в датамодуле вместо поля TGraphicsField для графики выбираешь
TExtGrapicField, а на форме вместо DBImage - ExtDBImage. Получаешь
возможность хранить bmp, wmf, ico.
Для хранения jpeg в инициализации своего модуля данных добавляешь
RegisterPictureField('jpg',TJpegImage);

А затем в программе делаешь
DataSet.FieldByName('Picture').Assign(jpegimage);
Благодаря полиморфизму возможно хранить любой тип графики.

Замечание: в Assign можно использовать TPicture или потомков TGraphic
Обратная операция (т.е. назначить содержимое поля объекту) определена только
для TPicture. Будет автоматически создан экземпляр нужного графического
класса-наследника от TGraphic и назначен классу-контейнеру TPicture.
Получить доступ к полученной картинке можно через Picture.Graphic

unit dbGraph;

interface
Uses Windows, SysUtils, Classes, Controls, DB, DBCtrls, Graphics;

{ Графическое поле, позволяющее хранить картинки не только в
формате BMP }

Type
TExtGraphicField = class(TGraphicField)
private
procedure LoadFromGraphic(Graphic: TGraphic);
procedure LoadFromPicture(aPicture: TPicture);
procedure SaveToPicture(aPicture: TPicture);
function ReadGraphicClass(BlobStream: TStream): TGraphicClass;
protected
procedure GetText(var Text: string; DisplayText: Boolean); override;
function GetGraphicClass: TGraphicClass;
public
procedure Assign(Source: TPersistent); override;
procedure AssignTo(Dest: TPersistent); override;
end;

type
TExtDBImage = class(TDBImage)
private
FDataLink: TFieldDataLink;
procedure UpdateData(Sender: TObject);
procedure DataChange(Sender: Tobject);
protected
property DataLink: TFieldDataLink read FDataLink;
public
constructor Create(aOwner: TComponent); override;
end;

procedure RegisterPictureField(const Format:String; GraphClass:
TGraphicClass);

procedure Register;


implementation

type
THackGraphic = class(TGraphic)
public
Constructor Create; override;
end;

THackGraphicClass = class of THackGraphic;

constructor THackGraphic.Create;
Begin
Inherited Create;
end;


{ Заголовок графического BLOB Paradox'а. Взят из DB.PAS }

type
TGraphicHeader = record
Count: Word; { Fixed at 1 }
HType: Word; { Fixed at $0100 }
Size: Longint; { Size not including header }
end;

const
GRAPHHDR : CARDINAL = ORD('P') SHL 24 or
ORD('I') SHL 16 or
ORD('C') SHL 8 or
ORD('T');

var
GraphFormats : TStringList;

procedure RegisterPictureField(const Format:String; GraphClass:
TGraphicClass);
Begin
GraphFormats.AddObject(Format, Pointer(GraphClass));
end;

function FindPictureClass(const Format: String): TGraphicClass;
var Index: Integer;
Begin
Result := nil;
Index := GraphFormats.IndexOf(Format);
if Index<>-1 then
Result := TGraphicClass(GraphFormats.Objects[Index]);
end;

function FindPictureFormat(GraphClass: TGraphicClass): String;
var I: Integer;
Begin
Result := '';
for i:=0 to GraphFormats.Count-1 do
if TGraphicClass(GraphFormats.Objects[i]) = GraphClass then
Begin
Result := GraphFormats[i];
Break;
end;
end;


{ TExtGraphicField }

procedure TExtGraphicField.GetText(var Text: string; DisplayText: Boolean);
var GraphClass: TGraphicClass;
begin
if IsNull then Inherited GetText(Text, DisplayText)
else Begin
GraphClass := GetGraphicClass;
if GraphClass = nil
then FmtStr(Text, '(Unknown) (%d bytes)', [GetBlobSize])
else FmtStr(Text, '%s (%d bytes)', [GraphClass.ClassName,
GetBlobSize]);
end;
end;

function TExtGraphicField.GetGraphicClass: TGraphicClass;
var BlobStream: TStream;
Begin
BlobStream := DataSet.CreateBlobStream(Self, bmRead);
try
Result := ReadGraphicClass(BlobStream);
finally
BlobStream.free;
end;
end;


procedure TExtGraphicField.Assign(Source: TPersistent);
begin
if (Source is TPicture) then
begin
LoadFromPicture(TPicture(Source));
Exit;
end;

if (Source is TGraphic) then
begin
LoadFromGraphic(TGraphic(Source));
Exit;
end;

inherited Assign(Source);
end;

procedure TExtGraphicField.AssignTo(Dest: TPersistent);
begin
if (Dest is TPicture) then
begin
SaveToPicture(TPicture(Dest));
Exit;
end;

inherited AssignTo(Dest);
end;

function TExtGraphicField.ReadGraphicClass(BlobStream: TStream):
TGraphicClass;
var
Size: Longint;
Header: TGraphicHeader;

GRFHeader: Cardinal;
GraphType: String;
StrLen: Byte;
NoBmpHeader: Boolean;

GraphClass: TGraphicClass;

begin
GraphClass := nil;
NoBmpHeader := true;

Size := BlobStream.Size;
if Size >= SizeOf(TGraphicHeader) then
begin
BlobStream.Read(Header, SizeOf(Header));
NoBmpHeader :=
(Header.Count <> 1) or (Header.HType <> $0100) or
(Header.Size <> Size - SizeOf(Header));
if NoBmpHeader then
BlobStream.Position := 0;
end;

{ Если стандартного заголовка нет, то пытаемся выявить
нестандратный тип графики }
If NoBmpHeader then
begin
Try
if Size = 0 then Abort;

BlobStream.ReadBuffer(GRFHeader, sizeof(GRFHeader));
if GRFHeader = GRAPHHDR then
begin
BlobStream.ReadBuffer(StrLen, sizeof(StrLen));
SetLength(GraphType, StrLen);
BlobStream.ReadBuffer(GraphType[1], StrLen);
GraphClass := FindPictureClass(GraphType);
end
else Abort;

Except
{ В случае ошибки чтения из потока
создаем нормальный битмап }
BlobStream.Position := 0;
if GraphClass = nil
then GraphClass:=TBitmap;
End;
end

{ Если был заголовок, то создаем Windows BMP }
else
GraphClass := TBitmap;

Result := GraphClass;
end;

procedure TExtGraphicField.LoadFromPicture(aPicture: TPicture);
var
Graphic: TGraphic;
Begin
Graphic := aPicture.Graphic;
if Graphic = nil then Exit;
LoadFromGraphic(Graphic);
end;


procedure TExtGraphicField.LoadFromGraphic(Graphic: TGraphic);
var
BlobStream: TStream;
Header: TGraphicHeader;

GraphType: String;
StrLen: Byte;

begin
BlobStream := DataSet.CreateBlobStream(Self, bmWrite);
try
if ((DataType = ftGraphic) or (DataType = ftTypedBinary))
and (Graphic is TBitmap) then
begin
Header.Count := 1;
Header.HType := $0100;
Header.Size := 0;
BlobStream.Write(Header, SizeOf(Header));
Graphic.SaveToStream(BlobStream);
Header.Size := BlobStream.Position - SizeOf(Header);
BlobStream.Position := 0;
BlobStream.Write(Header, SizeOf(Header));
end

else

// if DataType = ftBLOB then
begin
BlobStream.Write(GRAPHHDR, sizeof(GRAPHHDR));
GraphType := FindPictureFormat(TGraphicClass(Graphic.ClassType));
StrLen := length(GraphType);
BlobStream.Write(StrLen, sizeof(StrLen));
BlobStream.Write(GraphType[1], StrLen);
Graphic.SaveToStream(BlobStream);
end;

finally
BlobStream.Free;
end;
end;

procedure TExtGraphicField.SaveToPicture(aPicture: TPicture);
var
BlobStream: TStream;
Graphic: TGraphic;

begin
BlobStream := DataSet.CreateBlobStream(Self, bmRead);
try
Graphic := THackGraphicClass(ReadGraphicClass(BlobStream)).Create;
aPicture.Graphic := Graphic;
Graphic.free;
if aPicture.Graphic <> nil
then aPicture.Graphic.LoadFromStream(BlobStream);
finally
BlobStream.Free;
end;
end;

{ TExtDBImage }

constructor TExtDBImage.Create(aOwner: TComponent);
begin
inherited;
FDataLink := TFieldDataLink(Perform(CM_GETDATALINK, 0, 0));
// fDataLink.OnDataChange := DataChange;
fDataLink.OnUpdateData := UpdateData;
end;

procedure TExtDBImage.DataChange(Sender: Tobject);
begin

end;

procedure TExtDBImage.UpdateData(Sender: TObject);
begin
FDataLink.Field.Assign(Picture)
end;

procedure Register;
begin
RegisterFields([TExtGraphicField]);
RegisterComponents('Data Controls',[TExtDBImage]);
end;

initialization
GraphFormats := TStringList.Create;
RegisterPictureField('bmp', TBitmap);
RegisterPictureField('wmf', TMetafile);
RegisterPictureField('emf', TMetafile);
RegisterPictureField('ico', TIcon);

finalization
GraphFormats.free;

end.

0 new messages