Haber si esto te puede ayudar
Código Delphi
[-]
unit noudbct;
{$R-}
interface
uses
Windows, SysUtils, Messages, Classes, Controls, Forms, Graphics,
Menus, StdCtrls, ExtCtrls, Mask, Buttons, ComCtrls, Db, dbctrls;
type
TDBImage2 = class(TCustomControl)
private
FDataLink: TFieldDataLink;
FPicture: TPicture;
FBorderStyle: TBorderStyle;
FAutoDisplay: Boolean;
FStretch: Boolean;
FCenter: Boolean;
FPictureLoaded: Boolean;
FQuickDraw: Boolean;
procedure DataChange(Sender: TObject);
function GetDataField: string;
function GetDataSource: TDataSource;
function GetField: TField;
function GetReadOnly: Boolean;
procedure SetAutoDisplay(Value: Boolean);
procedure SetBorderStyle(Value: TBorderStyle);
procedure SetCenter(Value: Boolean);
procedure SetDataField(const Value: string);
procedure SetDataSource(Value: TDataSource);
procedure SetPicture(Value: TPicture);
procedure SetReadOnly(Value: Boolean);
procedure SetStretch(Value: Boolean);
procedure UpdateData(Sender: TObject);
procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;
procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
procedure CMExit(var Message: TCMExit); message CM_EXIT;
procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
procedure WMLButtonDblClk(var Message: TWMLButtonDblClk);
message WM_LBUTTONDBLCLK;
procedure WMCut(var Message: TMessage); message WM_CUT;
procedure WMCopy(var Message: TMessage); message WM_COPY;
procedure WMPaste(var Message: TMessage); message WM_PASTE;
procedure WMSize(var Message: TMessage); message WM_SIZE;
protected
procedure CreateParams(var Params: TCreateParams); override;
function GetPalette: HPALETTE; override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure KeyPress(var Key: Char); override;
procedure Notification(AComponent: TComponent;
Operation: TOperation); override;
procedure Paint; override;
procedure PictureChanged(Sender: TObject); virtual;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure CopyToClipboard;
procedure CutToClipboard;
function ExecuteAction(Action: TBasicAction): Boolean; override;
procedure LoadPicture; virtual;
procedure PasteFromClipboard;
function UpdateAction(Action: TBasicAction): Boolean; override;
property Field: TField read GetField;
property Picture: TPicture read FPicture write SetPicture;
published
property Align;
property Anchors;
property AutoDisplay: Boolean read FAutoDisplay write SetAutoDisplay default True;
property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
property Center: Boolean read FCenter write SetCenter default True;
property Color;
property Constraints;
property Ctl3D;
property DataField: string read GetDataField write SetDataField;
property DataSource: TDataSource read GetDataSource write SetDataSource;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property Font;
property ParentColor default False;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
property QuickDraw: Boolean read FQuickDraw write FQuickDraw default True;
property ShowHint;
property Stretch: Boolean read FStretch write SetStretch default False;
property TabOrder;
property TabStop default True;
property Visible;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnStartDock;
property OnStartDrag;
end;
implementation
uses
Clipbrd, DBConsts, Dialogs;
constructor TDBImage2.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := ControlStyle + [csOpaque, csReplicatable];
if not NewStyleControls then
ControlStyle := ControlStyle + [csFramed];
Width := 105;
Height := 105;
TabStop := True;
ParentColor := False;
FPicture := TPicture.Create;
FPicture.OnChange := PictureChanged;
FBorderStyle := bsSingle;
FAutoDisplay := True;
FCenter := True;
FDataLink := TFieldDataLink.Create;
FDataLink.Control := Self;
FDataLink.OnDataChange := DataChange;
FDataLink.OnUpdateData := UpdateData;
FQuickDraw := True;
end;
destructor TDBImage2.Destroy;
begin
FPicture.Free;
FDataLink.Free;
FDataLink := nil;
inherited Destroy;
end;
function TDBImage2.GetDataSource: TDataSource;
begin
Result := FDataLink.DataSource;
end;
procedure TDBImage2.SetDataSource(Value: TDataSource);
begin
if not (FDataLink.DataSourceFixed and (csLoading in ComponentState)) then
FDataLink.DataSource := Value;
if Value <> nil then
Value.FreeNotification(Self);
end;
function TDBImage2.GetDataField: string;
begin
Result := FDataLink.FieldName;
end;
procedure TDBImage2.SetDataField(const Value: string);
begin
FDataLink.FieldName := Value;
end;
function TDBImage2.GetReadOnly: Boolean;
begin
Result := FDataLink.ReadOnly;
end;
procedure TDBImage2.SetReadOnly(Value: Boolean);
begin
FDataLink.ReadOnly := Value;
end;
function TDBImage2.GetField: TField;
begin
Result := FDataLink.Field;
end;
function TDBImage2.GetPalette: HPALETTE;
begin
Result := 0;
if FPicture.Graphic is TBitmap then
Result := TBitmap(FPicture.Graphic).Palette;
end;
procedure TDBImage2.SetAutoDisplay(Value: Boolean);
begin
if FAutoDisplay <> Value then
begin
FAutoDisplay := Value;
if Value then
LoadPicture;
end;
end;
procedure TDBImage2.SetBorderStyle(Value: TBorderStyle);
begin
if FBorderStyle <> Value then
begin
FBorderStyle := Value;
RecreateWnd;
end;
end;
procedure TDBImage2.SetCenter(Value: Boolean);
begin
if FCenter <> Value then
begin
FCenter := Value;
Invalidate;
end;
end;
procedure TDBImage2.SetPicture(Value: TPicture);
begin
FPicture.Assign(Value);
end;
procedure TDBImage2.SetStretch(Value: Boolean);
begin
if FStretch <> Value then
begin
FStretch := Value;
Invalidate;
end;
end;
procedure TDBImage2.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;
if FPictureLoaded or (csPaintCopy in ControlState) then
begin
DrawPict := TPicture.Create;
Pal := 0;
try
if (csPaintCopy in ControlState) and Assigned(FDataLink.Field) and FDataLink.Field.IsBlob then
begin
DrawPict.Assign(FDataLink.Field);
if DrawPict.Graphic is TBitmap then
DrawPict.Bitmap.IgnorePalette := QuickDraw;
end
else
begin
DrawPict.Assign(Picture);
if Focused and (DrawPict.Graphic <> nil) and (DrawPict.Graphic.Palette <> 0) then
begin
Pal := SelectPalette(Handle, DrawPict.Graphic.Palette, False);
RealizePalette(Handle);
end;
end;
if Stretch then
if (DrawPict.Graphic = nil) or DrawPict.Graphic.Empty then
FillRect(ClientRect)
else
StretchDraw(ClientRect, DrawPict.Graphic)
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
else
begin
Font := Self.Font;
if FDataLink.Field <> nil then
S := FDataLink.Field.DisplayLabel
else
S := Name;
S := '(' + S + ')';
Size := TextExtent(S);
R := ClientRect;
TextRect(R, (R.Right - Size.cx) div 2, (R.Bottom - Size.cy) div 2, S);
end;
Form := GetParentForm(Self);
if (Form <> nil) and (Form.ActiveControl = Self) and not (csDesigning in ComponentState) and
not (csPaintCopy in ControlState) then
begin
Brush.Color := clWindowFrame;
FrameRect(ClientRect);
end;
end;
end;
procedure TDBImage2.PictureChanged(Sender: TObject);
begin
if FPictureLoaded then
FDataLink.Modified;
FPictureLoaded := True;
Invalidate;
end;
procedure TDBImage2.Notification(AComponent: TComponent; Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if (Operation = opRemove) and (FDataLink <> nil) and (AComponent = DataSource) then
DataSource := nil;
end;
procedure TDBImage2.LoadPicture;
begin
if not FPictureLoaded and (not Assigned(FDataLink.Field) or FDataLink.Field.IsBlob) then
Picture.Assign(FDataLink.Field);
end;
procedure TDBImage2.DataChange(Sender: TObject);
begin
Picture.Graphic := nil;
FPictureLoaded := False;
if FAutoDisplay then
LoadPicture;
end;
procedure TDBImage2.UpdateData(Sender: TObject);
begin
if Picture.Graphic is TBitmap then
FDataLink.Field.Assign(Picture.Graphic)
else
FDataLink.Field.Clear;
end;
procedure TDBImage2.CopyToClipboard;
begin
if Picture.Graphic <> nil then
Clipboard.Assign(Picture);
end;
procedure TDBImage2.CutToClipboard;
begin
if Picture.Graphic <> nil then
if FDataLink.Edit then
begin
CopyToClipboard;
Picture.Graphic := nil;
end;
end;
procedure TDBImage2.PasteFromClipboard;
begin
if Clipboard.HasFormat(CF_BITMAP) and FDataLink.Edit then
Picture.Bitmap.Assign(Clipboard);
end;
procedure TDBImage2.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do
begin
if FBorderStyle = bsSingle then
if NewStyleControls and Ctl3D then
ExStyle := ExStyle or WS_EX_CLIENTEDGE
else
Style := Style or WS_BORDER;
WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
end;
end;
procedure TDBImage2.KeyDown(var Key: Word; Shift: TShiftState);
begin
inherited KeyDown(Key, Shift);
case Key of
VK_INSERT:
if ssShift in Shift then
PasteFromClipBoard
else if ssCtrl in Shift then
CopyToClipBoard;
VK_DELETE:
if ssShift in Shift then
CutToClipBoard;
end;
end;
procedure TDBImage2.KeyPress(var Key: Char);
begin
inherited KeyPress(Key);
case Key of
^X: CutToClipBoard;
^C: CopyToClipBoard;
^V: PasteFromClipBoard;
#13: LoadPicture;
#27: FDataLink.Reset;
end;
end;
procedure TDBImage2.CMGetDataLink(var Message: TMessage);
begin
Message.Result := Integer(FDataLink);
end;
procedure TDBImage2.CMEnter(var Message: TCMEnter);
begin
Invalidate;
inherited;
end;
procedure TDBImage2.CMExit(var Message: TCMExit);
begin
try
FDataLink.UpdateRecord;
except
SetFocus;
raise;
end;
Invalidate;
inherited;
end;
procedure TDBImage2.CMTextChanged(var Message: TMessage);
begin
inherited;
if not FPictureLoaded then
Invalidate;
end;
procedure TDBImage2.WMLButtonDown(var Message: TWMLButtonDown);
begin
if TabStop and CanFocus then
SetFocus;
inherited;
end;
procedure TDBImage2.WMLButtonDblClk(var Message: TWMLButtonDblClk);
begin
LoadPicture;
inherited;
end;
procedure TDBImage2.WMCut(var Message: TMessage);
begin
CutToClipboard;
end;
procedure TDBImage2.WMCopy(var Message: TMessage);
begin
CopyToClipboard;
end;
procedure TDBImage2.WMPaste(var Message: TMessage);
begin
PasteFromClipboard;
end;
procedure TDBImage2.WMSize(var Message: TMessage);
begin
inherited;
Invalidate;
end;
function TDBImage2.ExecuteAction(Action: TBasicAction): Boolean;
begin
Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and
FDataLink.ExecuteAction(Action);
end;
function TDBImage2.UpdateAction(Action: TBasicAction): Boolean;
begin
Result := inherited UpdateAction(Action) or (FDataLink <> nil) and FDataLink.UpdateAction(Action);
end;
end.
end.