Hi all,
The attached patch actually implements TDBImage and solves a problem
with TDBMemo when a dataset is closed.
Beware, it'll only work with sqldb from fpc 2.1.1, or maybe wit
ZEOS/tDbf. The patch solves bugs 1739 and 1477.
regards,
Joost.
Index: include/dbmemo.inc
===================================================================
--- include/dbmemo.inc (revision 10438)
+++ include/dbmemo.inc (working copy)
@@ -98,6 +98,16 @@
inherited ReadOnly:=not (FDataLink.Editing and FDBMemoLoaded);
end;
+procedure TDBMemo.ActiveChange(Sender: TObject);
+begin
+ if FDatalink.Active then datachange(sender)
+ else
+ begin
+ Lines.Clear;
+ FDataLink.reset;
+ end;
+end;
+
procedure TDBMemo.Notification(AComponent: TComponent; Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
@@ -124,6 +134,7 @@
FDataLink.Control:=Self;
FDataLink.OnDataChange:[EMAIL PROTECTED];
FDataLink.OnEditingChange:[EMAIL PROTECTED];
+ FDataLInk.OnActiveChange := @ActiveChange;
FDataLink.OnUpdateData:[EMAIL PROTECTED];
inherited ReadOnly:=True;
end;
Index: include/dbimage.inc
===================================================================
--- include/dbimage.inc (revision 10438)
+++ include/dbimage.inc (working copy)
@@ -30,6 +30,13 @@
begin
Result:=FDataLink.Field;
end;
+procedure TDBImage.Change;
+begin
+ //need to override this to make sure the datalink gets notified
+ //its been modified, then when post etc, it will call
+ //updatedata to update the field data with current value
+ FDataLink.Modified;
+end;
function TDBImage.GetReadOnly: Boolean;
begin
@@ -72,24 +79,107 @@
procedure TDBImage.DataChange(Sender: TObject);
begin
+ FUpdatingRecord := True;
Picture.Graphic:=nil;
FPictureLoaded:=False;
if AutoDisplay then LoadPicture;
+ FUpdatingRecord := False;
end;
procedure TDBImage.UpdateData(Sender: TObject);
+
+var s : Tstream;
+ fe : String;
+ i : Integer;
+
begin
- if Picture.Graphic is TBitmap then
- FDataLink.Field.Assign(Picture.Graphic)
+ if not assigned(Picture.Graphic) or (Picture.Graphic.Empty) then
+ begin
+ FDataLink.Field.Clear;
+ end
else
- FDataLink.Field.Clear;
+ begin
+ fe := Picture.Graphic.GetFileExtensions;
+ s := FDataLink.DataSet.CreateBlobStream(FDataLink.Field,bmwrite);
+ try
+ i := pos(';',fe);
+ if i > 0 then fe := copy(fe,1,i-1);
+ s.WriteAnsiString(fe);
+ Picture.Graphic.SaveToStream(s);
+ finally
+ s.Free;
+ end;
+ end;
end;
+procedure TDBImage.ActiveChange(Sender: TObject);
+begin
+ if FDatalink.Active then datachange(sender)
+ else
+ begin
+ Picture.Clear;
+ FDataLink.reset;
+ end;
+end;
+
+procedure TDBImage.PictureChanged(Sender: TObject);
+begin
+ Inherited;
+ if not FUpdatingRecord then
+ Change;
+end;
+
procedure TDBImage.LoadPicture;
+
+var s : Tstream;
+ GraphExt : string;
+ gc : TGraphicClass;
+ AGraphic : TGraphic;
+
begin
- if not FPictureLoaded
- and (not Assigned(FDataLink.Field) or FDataLink.Field.IsBlob) then
- Picture.Assign(FDataLink.Field);
+ if not FPictureLoaded then
+ begin
+ FUpdatingRecord := True;
+ if not assigned(FDatalink.Field) then Picture.Assign(FDatalink.Field)
+ else
+ if FDatalink.field.IsBlob then
+ begin
+ if FDatalink.field is TBlobField then
+ begin
+ if FDatalink.Field.IsNull then
+ begin
+ Picture.Clear;
+ exit;
+ end;
+ s := FDataLink.DataSet.CreateBlobStream(FDataLink.Field,bmRead);
+ if s.Size = 0 then
+ begin
+ Picture.Clear;
+ exit;
+ end;
+ try
+ GraphExt := s.ReadAnsiString;
+
+ gc := GetGraphicClassForFileExtension(GraphExt);
+ if assigned(gc) then
+ begin
+ AGraphic := gc.Create;
+ AGraphic.LoadFromStream(s);
+
+ Picture.Assign(AGraphic);
+ end;
+ finally
+ if assigned(AGraphic) then AGraphic.Free;
+ s.Free;
+ end {try}
+
+ end
+ else
+ Picture.Assign(FDataLink.FField);
+
+ end;
+ FUpdatingRecord := False;
+ end;
end;
procedure TDBImage.Loaded;
@@ -109,6 +199,8 @@
FDataLink.Control:=Self;
FDataLink.OnDataChange:[EMAIL PROTECTED];
FDataLink.OnUpdateData:[EMAIL PROTECTED];
+ FDataLInk.OnActiveChange := @ActiveChange;
+ FUpdatingRecord := False;
end;
destructor TDBImage.Destroy;
Index: extctrls.pp
===================================================================
--- extctrls.pp (revision 10438)
+++ extctrls.pp (working copy)
@@ -528,8 +528,8 @@
procedure SetProportional(const AValue: Boolean);
procedure SetStretch(Value : Boolean);
procedure SetTransparent(Value : Boolean);
- procedure PictureChanged(Sender : TObject);
protected
+ procedure PictureChanged(Sender : TObject); virtual;
function DestRect: TRect; virtual;
procedure DoAutoSize; Override;
Procedure Paint; Override;
Index: dbctrls.pp
===================================================================
--- dbctrls.pp (revision 10438)
+++ dbctrls.pp (working copy)
@@ -540,6 +540,7 @@
function WordWrapIsStored: boolean; override;
procedure DataChange(Sender: TObject); virtual;
procedure EditingChange(Sender: TObject); virtual;
+ procedure ActiveChange(Sender: TObject); virtual;
procedure Notification(AComponent: TComponent;
Operation: TOperation); override;
procedure UpdateData(Sender: TObject); virtual;
@@ -642,6 +643,7 @@
FDataLink: TFieldDataLink;
FQuickDraw: Boolean;
FPictureLoaded: boolean;
+ FUpdatingRecord: boolean;
function GetDataField: string;
function GetDataSource: TDataSource;
function GetField: TField;
@@ -655,12 +657,15 @@
Operation: TOperation); override;
procedure DataChange(Sender: TObject); virtual;
procedure UpdateData(Sender: TObject); virtual;
+ procedure ActiveChange(Sender: TObject); virtual;
+ procedure PictureChanged(Sender: TObject); override;
procedure LoadPicture; virtual;
procedure Loaded; override;
public
constructor Create(TheOwner: TComponent); override;
destructor Destroy; override;
property Field: TField read GetField;
+ procedure Change; virtual;
published
property Align;
property Anchors;
