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 .
UDBImageExExemple :
Code : Sélectionner tout - Visualiser dans une fenêtre à part
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.
Unit1.pas
Unit1.dfm
Code : Sélectionner tout - Visualiser dans une fenêtre à part
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.
Code : Sélectionner tout - Visualiser dans une fenêtre à part
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
Partager