Challenge TBDImage avec Image au format jpeg
La manière la plus rapide pour rendre un TBDImage capable de sauver tous les formats supportées par TPicture
au format jpeg sans etre obliger pour installer un nouveau composant , j'ai créé deux routines appelées
PictureToJpgStream JpgStreamToPicture pour manipuler le flux entre le TDBImage et le champ lié, ces fonctions
utilisent le composant TJpegImage pour obtenir un taux acceptable de compression mais vous pouvez les remplacer
par votre propre code.
Comment utiliser l'unité UDBImageEx
pour utiliser l'unité tu devrais mettre le nom de l'unité dans la section inteface juste aprés
DBCtrls et tout les TBDImage sur la fiche seront patchés.Le code fonctionne que au temps d'exécution
il faut rester deconnecter au conception .
UDBImageEx
Code:
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131
| unit UDBImageEx;
interface
uses
Windows, SysUtils, Classes, Graphics, Controls, ExtCtrls, DB, DBCtrls;
type
TDBImage=class(DBCtrls.TDBImage)
private
FDataLink :TFieldDataLink;
procedure UpdateData(Sender: TObject);
public
constructor Create(AOwner:TComponent);override;
procedure LoadFromFile(const Filename: string);
end;
implementation
uses jpeg;
const BOM :LongWord =$012345801;
procedure PictureToJpgStream(APicture:TPicture;Stream:TStream);
var
Bmp:TBitmap;
Jpg: TJPEGImage;
begin
if APicture.Graphic is TJpegImage then
begin
APicture.Graphic.SaveToStream(Stream);
end else with APicture do
begin
Bmp := TBitmap.Create;
Jpg := TJPEGImage.Create;
try
Bmp.PixelFormat:=pf24Bit;
if Graphic is TBitmap then
Bmp.Assign(Graphic)
else begin
Bmp.Width := Graphic.Width;
Bmp.Height := Graphic.Height;
Bmp.Canvas.Draw(0,0,Graphic);
end;
Jpg.Assign(Bmp);
Jpg.Compress();
Jpg.SaveToStream(Stream);
finally
Jpg.Free;
Bmp.Free;
end;
end;
end;
procedure JpgStreamToPicture(APicture:TPicture;Stream:TStream);
var
Jpg: TJPEGImage;
begin
Jpg := TJpegImage.Create();
try
Jpg.LoadFromStream(Stream);
APicture.Assign(Jpg);
finally
Jpg.Free;
end;
end;
type
TDBPicture = class(TPicture,IStreamPersist)
public
procedure LoadFromStream(Stream: TStream);
procedure SaveToStream(Stream: TStream);
end;
{ TDBImage }
constructor TDBImage.Create(AOwner: TComponent);
var
F:TPicture;
begin
inherited;
FDataLink := TFieldDataLink(Perform(CM_GETDATALINK,0,0));
FDataLink.OnUpdateData := UpdateData;
F := TDBPicture.Create();
F.OnChange := Picture.OnChange;
Picture.Free;
PPointer(@Picture)^:= F;
end;
procedure TDBImage.LoadFromFile(const Filename: string);
begin
if FDataLink.Edit then
begin
Picture.LoadFromFile(Filename);
FDataLink.Modified;
end;
end;
procedure TDBImage.UpdateData(Sender: TObject);
begin
FDataLink.Field.Assign(Picture)
end;
procedure TDBPicture.LoadFromStream(Stream: TStream);
var
OldPos:int64;
Sn:LongWord;
begin
with Stream do
begin
if Size = 0 then
Exit;
OldPos := Position;
if (Read(Sn,SizeOf(Sn)) = SizeOf(Sn)) and(Sn = BOM)then
JpgStreamToPicture(Self,Stream)
else begin
Position := OldPos;
inherited;
end;
end;
end;
procedure TDBPicture.SaveToStream(Stream: TStream);
begin
if Graphic = nil then
Exit;
Stream.Write(BOM,SizeOf(BOM));
PictureToJpgStream(Self,Stream);
end;
end. |
Exemple :
Unit1.pas
Code:
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71
| unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, DB, DBTables, StdCtrls, DBCtrls,UDBImageEx, Mask, ExtCtrls;
type
TForm1 = class(TForm)
DataSource1: TDataSource;
DBNavigator1: TDBNavigator;
DBImage1: TDBImage;
Button1: TButton;
Table1: TTable;
Table1Id: TAutoIncField;
Table1Picture: TGraphicField;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Déclarations privées }
public
{ Déclarations publiques }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
with Table1 do
begin
TableType := ttParadox;
TableName := 'images.db';
if not Exists then
begin
with FieldDefs do
begin
Clear;
with AddFieldDef do begin
Name := 'Id';
DataType := ftAutoInc;
Required := True;
end;
with AddFieldDef do begin
Name := 'Picture';
DataType := ftBlob;
end;
end;
CreateTable;
end;
Open;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
S:string;
begin
if PromptForfilename(S,GraphicFilter(TGraphic)) then
DBImage1.LoadFromFile(s);
end;
end. |
Unit1.dfm
Code:
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52
| object Form1: TForm1
Width = 265
Height = 190
Caption = 'Form1'
OldCreateOrder = False
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 13
object DBNavigator1: TDBNavigator
Left = 8
Top = 120
Width = 240
Height = 25
DataSource = DataSource1
TabOrder = 0
end
object DBImage1: TDBImage
Left = 8
Top = 8
Width = 105
Height = 105
DataField = 'Picture'
DataSource = DataSource1
Stretch = True
TabOrder = 1
end
object Button1: TButton
Left = 144
Top = 56
Width = 75
Height = 25
Caption = 'Load Image'
TabOrder = 2
OnClick = Button1Click
end
object DataSource1: TDataSource
DataSet = Table1
Left = 64
Top = 24
end
object Table1: TTable
Left = 32
Top = 24
object Table1Id: TAutoIncField
FieldName = 'Id'
end
object Table1Picture: TGraphicField
FieldName = 'Picture'
BlobType = ftGraphic
end
end
end |