unit dbpathp_w_picpath;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
DBCtrls,db;
type
Tdbpathp_w_picpath = class(TDBImage)
private
fTransparent: boolean;
protected
procedure Paint; override;
procedure SetTransparent(const Value: boolean);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Transparent: boolean read fTransparent write SetTransparent default True;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Data Controls', [Tdbpathp_w_picpath]);
end;
constructor Tdbpathp_w_picpath.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
//使用双缓冲绘制图片,先把图片绘制到内存中,
//然后在显示到控件中,这样就不会闪烁
self.DoubleBuffered:=true;
end;
destructor Tdbpathp_w_picpath.Destroy;
begin
inherited Destroy;
end;
procedure TDBpathImage.SetTransparent(const Value: boolean);
begin
fTransparent := Value;
Invalidate;
end;
procedure Tdbpathp_w_picpath.Paint;
var
Size: TSize;
R: TRect;
S: string;
DrawPict: TPicture;
Form: TCustomForm;
Pal: HPalette;
begin
with Canvas do
begin
Brush.Style := bsSolid;
Brush.Color := Color;
DrawPict := TPicture.Create;
Pal := 0;
s:='';
try
if (field=nil) or (field.asstring='') then
begin
Font := Self.Font;
S := '(无图片)';
Size := TextExtent(S);
R := ClientRect;
TextRect(R, (R.Right - Size.cx) div 2, (R.Bottom - Size.cy) div 2, S);
end
else
begin
try //当调入图片失败后,显示'调入失败'
DrawPict.LoadFromFile(field.asstring);
if DrawPict.Graphic is TBitmap then
DrawPict.Bitmap.IgnorePalette := QuickDraw;
except
Font := Self.Font;
S := '(调入失败)';
Size := TextExtent(S);
R := ClientRect;
TextRect(R, (R.Right - Size.cx) div 2, (R.Bottom - Size.cy) div 2, S);
end;
end;
if Stretch then
begin
if (DrawPict.Graphic = nil) or DrawPict.Graphic.Empty then
begin
Font := Self.Font;
if s='' then S := '(无图片)';
Size := TextExtent(S);
R := ClientRect;
TextRect(R, (R.Right - Size.cx) div 2, (R.Bottom - Size.cy) div 2, S);
end
//FillRect(ClientRect)
else
StretchDraw(ClientRect, DrawPict.Graphic);
end
else
begin
SetRect(R, 0, 0, DrawPict.Width, DrawPict.Height);
if Center then OffsetRect(R, (ClientWidth - DrawPict.Width) div 2,
(ClientHeight - DrawPict.Height) div 2);
StretchDraw(R, DrawPict.Graphic);
ExcludeClipRect(Handle, R.Left, R.Top, R.Right, R.Bottom);
FillRect(ClientRect);
SelectClipRgn(Handle, 0);
end;
finally
if Pal <> 0 then SelectPalette(Handle, Pal, True);
DrawPict.Free;
end;
end;
end;
end.
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
DBCtrls,db;
type
Tdbpathp_w_picpath = class(TDBImage)
private
fTransparent: boolean;
protected
procedure Paint; override;
procedure SetTransparent(const Value: boolean);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Transparent: boolean read fTransparent write SetTransparent default True;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Data Controls', [Tdbpathp_w_picpath]);
end;
constructor Tdbpathp_w_picpath.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
//使用双缓冲绘制图片,先把图片绘制到内存中,
//然后在显示到控件中,这样就不会闪烁
self.DoubleBuffered:=true;
end;
destructor Tdbpathp_w_picpath.Destroy;
begin
inherited Destroy;
end;
procedure TDBpathImage.SetTransparent(const Value: boolean);
begin
fTransparent := Value;
Invalidate;
end;
procedure Tdbpathp_w_picpath.Paint;
var
Size: TSize;
R: TRect;
S: string;
DrawPict: TPicture;
Form: TCustomForm;
Pal: HPalette;
begin
with Canvas do
begin
Brush.Style := bsSolid;
Brush.Color := Color;
DrawPict := TPicture.Create;
Pal := 0;
s:='';
try
if (field=nil) or (field.asstring='') then
begin
Font := Self.Font;
S := '(无图片)';
Size := TextExtent(S);
R := ClientRect;
TextRect(R, (R.Right - Size.cx) div 2, (R.Bottom - Size.cy) div 2, S);
end
else
begin
try //当调入图片失败后,显示'调入失败'
DrawPict.LoadFromFile(field.asstring);
if DrawPict.Graphic is TBitmap then
DrawPict.Bitmap.IgnorePalette := QuickDraw;
except
Font := Self.Font;
S := '(调入失败)';
Size := TextExtent(S);
R := ClientRect;
TextRect(R, (R.Right - Size.cx) div 2, (R.Bottom - Size.cy) div 2, S);
end;
end;
if Stretch then
begin
if (DrawPict.Graphic = nil) or DrawPict.Graphic.Empty then
begin
Font := Self.Font;
if s='' then S := '(无图片)';
Size := TextExtent(S);
R := ClientRect;
TextRect(R, (R.Right - Size.cx) div 2, (R.Bottom - Size.cy) div 2, S);
end
//FillRect(ClientRect)
else
StretchDraw(ClientRect, DrawPict.Graphic);
end
else
begin
SetRect(R, 0, 0, DrawPict.Width, DrawPict.Height);
if Center then OffsetRect(R, (ClientWidth - DrawPict.Width) div 2,
(ClientHeight - DrawPict.Height) div 2);
StretchDraw(R, DrawPict.Graphic);
ExcludeClipRect(Handle, R.Left, R.Top, R.Right, R.Bottom);
FillRect(ClientRect);
SelectClipRgn(Handle, 0);
end;
finally
if Pal <> 0 then SelectPalette(Handle, Pal, True);
DrawPict.Free;
end;
end;
end;
end.
转载于:https://blog.51cto.com/zsqztg/309413