paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-09 15:28:14 +02:00
Code Issues Packages Projects Releases Wiki Activity

Examples, simplified mushroom sample to use new dbimage writing/loading support

Browse Source 
git-svn-id: trunk@43783 -
This commit is contained in:
jesus 2014-01-22 20:39:40 +00:00
parent 81a96b4100
commit d957a7dd6b
2 changed files with 109 additions and 119 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
examples/database/sqlite_mushrooms/unit1.lfm
View File

@ -1,7 +1,7 @@
object Form1: TForm1
Left = 517
Left = 485
Height = 667
Top = 119
Top = 50
Width = 531
BorderStyle = bsSingle
Caption = 'Deadly Mushrooms by Jurassic Pork'
@ -206,7 +206,7 @@ object Form1: TForm1
end
object DBEdit1: TDBEdit
Left = 128
Height = 21
Height = 23
Top = 408
Width = 166
DataField = 'Image_Link'
@ -215,7 +215,6 @@ object Form1: TForm1
Color = clCream
MaxLength = 255
TabOrder = 3
OnChange = DBEdit1Change
end
object Button1: TButton
Left = 307
@ -236,32 +235,32 @@ object Form1: TForm1
Columns = <
item
Title.Caption = 'Common Name'
Width = 86
Width = 108
FieldName = 'Common_Name'
end
item
Title.Caption = 'Scientific Name'
Width = 87
Width = 110
FieldName = 'Scientific_Name'
end
item
Title.Caption = 'Order'
Width = 43
Width = 49
FieldName = 'Order'
end
item
Title.Caption = 'Genus'
Width = 45
Width = 53
FieldName = 'Genus'
end
item
Title.Caption = 'ID'
Width = 26
Width = 28
FieldName = 'ID'
end
item
Title.Caption = 'Notes'
Width = 43
Width = 49
FieldName = 'Notes'
end>
DataSource = Datasource1
@ -278,8 +277,8 @@ object Form1: TForm1
BevelOuter = bvNone
BorderWidth = 2
BorderStyle = bsSingle
ClientHeight = 324
ClientWidth = 318
ClientHeight = 326
ClientWidth = 320
ParentColor = False
TabOrder = 6
object Image1: TImage
@ -304,8 +303,8 @@ object Form1: TForm1
BevelOuter = bvNone
BorderWidth = 2
BorderStyle = bsSingle
ClientHeight = 324
ClientWidth = 158
ClientHeight = 326
ClientWidth = 160
ParentColor = False
TabOrder = 7
object DBImage1: TDBImage
@ -321,23 +320,22 @@ object Form1: TForm1
DataField = 'Picture'
DataSource = Datasource1
OnDblClick = DBImage1DblClick
OnDBImageRead = DBImage1DBImageRead
Proportional = True
end
end
object Label1: TLabel
Left = 8
Height = 13
Height = 15
Top = 55
Width = 18
Width = 25
Caption = 'Link'
ParentColor = False
end
object Label2: TLabel
Left = 360
Height = 13
Height = 15
Top = 55
Width = 20
Width = 26
Caption = 'Blob'
ParentColor = False
end
@ -352,14 +350,15 @@ object Form1: TForm1
end
object Label3: TLabel
Left = 8
Height = 13
Height = 15
Top = 424
Width = 30
Width = 36
Caption = 'Note :'
ParentColor = False
end
object Datasource1: TDataSource
DataSet = SQLQuery1
OnDataChange = Datasource1DataChange
left = 216
top = 192
end
@ -404,7 +403,6 @@ object Form1: TForm1
PreviewButtons = [pbZoom, pbLoad, pbSave, pbPrint, pbFind, pbHelp, pbExit]
DataType = dtDataSet
OnEnterRect = frReport1EnterRect
OnDBImageRead = frReport1DBImageRead
left = 384
top = 344
end

186
examples/database/sqlite_mushrooms/unit1.pas
View File

@ -38,21 +38,21 @@ type
SQLTransaction1: TSQLTransaction;
procedure Button1Click(Sender: TObject);
procedure Bt_PrintClick(Sender: TObject);
procedure DBEdit1Change(Sender: TObject);
procedure Datasource1DataChange(Sender: TObject; Field: TField);
procedure DBGrid1PrepareCanvas(sender: TObject; DataCol: Integer;
Column: TColumn; AState: TGridDrawState);
procedure DBImage1DBImageRead(Sender: TObject; S: TStream;
var GraphExt: string);
procedure DBImage1DblClick(Sender: TObject);
procedure DBNavigator1BeforeAction(Sender: TObject; Button: TDBNavButtonType
);
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormCreate(Sender: TObject);
procedure frReport1DBImageRead(Sender: TObject; S: TStream;
var GraphExt: string);
procedure frReport1EnterRect(Memo: TStringList; View: TfrView);
private
{ private declarations }
procedure UpdateImageLink;
procedure ChangeImage;
procedure LoadDbImage(aFileName: string);
function RecreateDB: boolean;
public
{ public declarations }
end;
@ -66,39 +66,9 @@ implementation
{ TForm1 }
procedure TForm1.DBImage1DBImageRead(Sender: TObject; S: TStream;
var GraphExt: string);
var val1,val2: WORD;
begin
S.Seek(0, soFromBeginning);
S.Read(val1,2);
S.Position := 2;
S.Read(val2,2);
if (val1 = $4D42) then GraphExt := 'bmp';
if (val1 = $4947) and (val2 = $3846) then GraphExt := 'gif';
if (val1 = $5089) and (val2 = $474E) then GraphExt := 'png';
if (val1 = $D8FF) and (val2 = $E0FF) then GraphExt := 'jpg';
S.Seek(0, soFromBeginning);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if SQLQuery1.Active then begin
OpenDialog1.Filter :=
'All image files (*.bmp,*.jpg,*.png,*.gif)|*.bmp;*.jpg;*.png;*.gif|' +
'BMP files (*.bmp)|*.bmp|' +
'JPEG files (*.jpg)|*.jpg|' +
'PNG files (*.png)|*.png|' +
'GIF files (*.gif)|*.gif';
OpenDialog1.InitialDir := ExtractFilePath(ParamStr(0)) + 'images';
if OpenDialog1.Execute then begin
if SQLQuery1.State <> dsEdit then
SQLQuery1.Edit;
Image1.Picture.LoadFromFile(OpenDialog1.FileName);
DBEdit1.Text := ExtractFileName(OpenDialog1.FileName);
SQLQuery1.Post;
end;
end;
ChangeImage;
end;
procedure TForm1.Bt_PrintClick(Sender: TObject);
@ -107,12 +77,11 @@ begin
'Mushroom_Report.lrf');
frReport1.ShowReport();
end;
procedure TForm1.DBEdit1Change(Sender: TObject);
procedure TForm1.Datasource1DataChange(Sender: TObject; Field: TField);
begin
if DBEdit1.Text <> '' then
Image1.Picture.LoadFromFile(ExtractFilePath(ParamStr(0)) +
'images' + DirectorySeparator + DBEdit1.Text) else
Image1.Picture.Clear;
if Field=nil then
UpdateImageLink;
end;
procedure TForm1.DBGrid1PrepareCanvas(sender: TObject; DataCol: Integer;
@ -127,52 +96,19 @@ begin
end;
end;
procedure TForm1.DBImage1DblClick(Sender: TObject);
var
BlobStream: TStream;
FileStream: TStream;
begin
if SQLQuery1.Active then begin
OpenDialog1.Filter :=
'All image files (*.bmp,*.jpg,*.png,*.gif)|*.bmp;*.jpg;*.png;*.gif|' +
'BMP files (*.bmp)|*.bmp|' +
'JPEG files (*.jpg)|*.jpg|' +
'PNG files (*.png)|*.png|' +
'GIF files (*.gif)|*.gif';
if OpenDialog1.Execute then begin
begin
if SQLQuery1.State <> dsEdit then
SQLQuery1.Edit;
try
FileStream := TFileStream.Create(OpenDialog1.FileName, fmOpenRead);
try
BlobStream := SQLQuery1.CreateBlobStream(
SQLQuery1.FieldByName('Picture'), bmWrite);
BlobStream.CopyFrom(FileStream, FileStream.Size);
SQLQuery1.Post;
finally
FileStream.Free;
end;
finally
BlobStream.Free;
end;
end;
end;
end;
ChangeImage;
end;
procedure TForm1.DBNavigator1BeforeAction(Sender: TObject;
Button: TDBNavButtonType);
begin
if Button = nbRefresh then
begin
SQLQuery1.ApplyUpdates;
SQLTransaction1.CommitRetaining;
end;
begin
SQLQuery1.ApplyUpdates;
SQLTransaction1.CommitRetaining;
end;
end;
procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
@ -183,24 +119,19 @@ end;
procedure TForm1.FormCreate(Sender: TObject);
begin
SQLQuery1.Close;
SQLite3Connection1.DatabaseName:= ExtractFilePath(ParamStr(0)) + 'ImageTest.db3';
SQLQuery1.Active := true;
end;
procedure TForm1.frReport1DBImageRead(Sender: TObject; S: TStream;
var GraphExt: string);
var val1,val2: WORD;
begin
S.Seek(0, soFromBeginning);
S.Read(val1,2);
S.Position := 2;
S.Read(val2,2);
if (val1 = $4D42) then GraphExt := 'bmp';
if (val1 = $4947) and (val2 = $3846) then GraphExt := 'gif';
if (val1 = $5089) and (val2 = $474E) then GraphExt := 'png';
if (val1 = $D8FF) and (val2 = $E0FF) then GraphExt := 'jpg';
S.Seek(0, soFromBeginning);
SQLQuery1.Close;
SQLite3Connection1.DatabaseName:= ExtractFilePath(ParamStr(0)) + 'ImageTest.db3';
try
SQLQuery1.Active := true;
except
on E:Exception do begin
//WriteLn(E.ClassName,': '+E.Message);
if RecreateDb then begin
SQLQuery1.Active := true;
ShowMessage('The database has been recreated');
end;
end;
end;
end;
procedure TForm1.frReport1EnterRect(Memo: TStringList; View: TfrView);
@ -211,6 +142,67 @@ begin
'images' + DirectorySeparator + frDBDataSet1.DataSet.FieldByName('Image_Link').AsString);
end;
procedure TForm1.UpdateImageLink;
var
s: String;
begin
if DBEdit1.Text <> '' then begin
s := ExtractFilePath(ParamStr(0)) + 'images' + DirectorySeparator + DBEdit1.Text;
Image1.Picture.LoadFromFile(s);
end else
Image1.Picture.Clear;
end;
procedure TForm1.ChangeImage;
var
WasEditing: Boolean;
begin
if SQLQuery1.Active then begin
OpenDialog1.Filter :=
'All image files (*.bmp,*.jpg,*.png,*.gif)|*.bmp;*.jpg;*.png;*.gif|' +
'BMP files (*.bmp)|*.bmp|' +
'JPEG files (*.jpg)|*.jpg|' +
'PNG files (*.png)|*.png|' +
'GIF files (*.gif)|*.gif';
OpenDialog1.InitialDir := ExtractFilePath(ParamStr(0)) + 'images';
if OpenDialog1.Execute then begin
WasEditing := (SQLQuery1.State = dsEdit);
if not WasEditing then
SQLQuery1.Edit;
DBEdit1.Text := ExtractFileName(OpenDialog1.FileName);
LoadDbImage(OpenDialog1.FileName);
if not WasEditing then
SQLQuery1.Post;
end;
end;
end;
procedure TForm1.LoadDbImage(aFileName: string);
begin
DbImage1.WriteHeader:=false;
DbImage1.Picture.LoadFromFile(aFileName);
end;
function TForm1.RecreateDB: boolean;
begin
try
SQLite3Connection1.ExecuteDirect(
'CREATE TABLE DeadlyMushrooms '+LineEnding+
'-- This table created by Jurassic Pork '+LineEnding+
'-- for Free Pascal Lazarus '+LineEnding+
'-- Create date:2013-08-05 23:55:09 '+LineEnding+
'( '+LineEnding+
' ID INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT, '+LineEnding+
' Scientific_Name VARCHAR NOT NULL, '+LineEnding+
' Common_Name VARCHAR, '+LineEnding+
' `Order` VARCHAR, `Genus` VARCHAR, `Notes` TEXT, `Picture` BLOB, `Image_Link` VARCHAR)'
);
result := true;
except
result := false;
end;
end;
end.