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