A TDBImage component that reads and writes *.jpg images

Problem/Question/Abstract:

A TDBImage component that reads and writes *.jpg images

Answer:

unit MyImage;

{ Unit MyImage; Toni Martir, techni-web@pala.com}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, DB,
  DBCtrls, Menus, clipbrd, ExtDlgs, extctrls, dbtables, jpeg, noudbct;

type
  TZoomType = 1..1000;

  TDBMyImage = class(TDBImage2)
  private
    { Private declarations }
    PopUpDefault: TPopUpMenu;
    popcortar, poppegar, popabrir: TMenuItem;
    FSaveJpeg, FAutosize: Boolean;
    FZoom: TZoomType;
    FCompressionQuality: TJPEgQualityRange;
    procedure ComprovaEditant;
    procedure Cortar(Sender: TObject);
    procedure Copiar(Sender: TObject);
    procedure Pegar(Sender: TObject);
    procedure Guardar(Sender: TObject);
    procedure QuanPopUp(Sender: TObject);
    procedure SaveAsJPeg;
  protected
    { Protected declarations }
    procedure PictureChanged(Sender: TObject); override;
    procedure loaded; override;
  public
    { Public declarations }
    DefaultWidth: integer;
    DefaultHeight: integer;
    procedure Abrir(Sender: TObject);
    procedure LoadPicture; override;
    constructor Create(AOwner: TComponent); override;
  published
    { Published declarations }
    property SaveJpeg: Boolean read FSaveJpeg write FSaveJPeg default false;
    property CompressionQuality: TJPEgQualityRange read FCompressionQuality
      write FCompressionQuality default 70;
    property Autosize: Boolean read FAutosize write FAutosize default False;
    property Zoom: TZoomType read FZoom write FZoom default 100;
  end;

implementation

var
  cajpeg: array[0..10] of char = (chr($FF), chr($D8), chr($FF), chr($E0), chr($0),
    chr($10), 'J', 'F', 'I', 'F', chr(0));

constructor TDBMyImage.Create(AOwner: TComponent);
var
  item: TMenuItem;
begin
  inherited Create(AOWner);
  FCompressionQuality := 70;
  FSaveJPeg := false;
  FZoom := 100;
  PopUpMenu := TPopUpMenu.Create(Self);
  PopUpDefault := PopUpMenu;
  PopUpMenu.Onpopup := quanpopup;
  item := TMenuItem.Create(Self);
  item.Caption := '&Cortar';
  item.OnClick := Cortar;
  PopUpMenu.Items.Add(item);
  popcortar := item;
  item := TMenuItem.Create(Self);
  item.Caption := 'C&opiar';
  item.OnClick := Copiar;
  PopUpMenu.Items.Add(item);
  item := TMenuItem.Create(Self);
  item.Caption := '&Pegar';
  item.OnClick := Pegar;
  PopUpMenu.Items.Add(item);
  poppegar := item;
  item := TMenuItem.Create(Self);
  item.Caption := '&Abrir...';
  item.OnClick := Abrir;
  PopUpMenu.Items.Add(item);
  popabrir := item;
  item := TMenuItem.Create(Self);
  item.Caption := '&Guardar como...';
  item.OnClick := Guardar;
  PopUpMenu.Items.Add(item);
end;

procedure TDBMyImage.Cortar(Sender: TObject);
begin
  if readonly then
    exit;
  if Picture.Graphic <> nil then
  begin
    ComprovaEditant;
    CopyToClipboard;
    Picture.Graphic := nil;
  end;
end;

procedure TDBMyImage.Copiar(Sender: TObject);
begin
  if Picture.Graphic <> nil then
    CopyToClipboard;
end;

procedure TDBMyImage.Pegar(Sender: TObject);
begin
  if ClipBoard.HasFormat(CF_BITMAP) then
  begin
    ComprovaEditant;
    if not FSaveJpeg then
    begin
      PasteFromClipboard;
    end
    else
    begin
      PasteFromClipboard;
      SaveAsJpeg;
    end;
  end;
end;

procedure TDBMyImage.Abrir(Sender: TObject);
var
  Dia: TOpenPictureDialog;
  Image1: TImage;
begin
  if readonly then
    exit;
  Dia := TOpenPictureDialog.Create(Self);
  try
    Dia.Title := 'Abrir imagen';
    if Dia.Execute then
    begin
      ComprovaEditant;
      Image1 := TImage.Create(Self);
      try
        Image1.Picture.LoadFromFile(Dia.Filename);
        Picture.Bitmap.Assign(Image1.Picture.Graphic);
        if FSaveJpeg then
          SaveAsJPeg;
      finally
        Image1.free;
      end;
    end;
  finally
    Dia.free;
  end;
end;

procedure TDBMyImage.Guardar(Sender: TObject);
var
  Dia: TSavePictureDialog;
begin
  Dia := TSavePictureDialog.Create(Self);
  try
    Dia.Title := 'Guardar imagen';
    if Dia.Execute then
    begin
      Picture.Graphic.SaveToFile(Dia.Filename);
    end;
  finally
    Dia.free;
  end;
end;

procedure TDBMyImage.ComprovaEditant;
var
  Data: TDataSet;
begin
  if Datasource = nil then
    Abort;
  if Length(DataField) = 0 then
    Abort;
  Data := DataSource.DataSet;
  if Data = nil then
    Abort;
  if not (Data.State in dsEditModes) then
    if ((Data.BOF) and (Data.EOF)) then
      Data.Insert
    else
      Data.Edit;
end;

procedure TDBMyimage.LoadPicture;
var
  camp: TBlobField;
  jpeg1: TJpegImage;
  stream: TBlobStream;
  carregat: Boolean;
  buf: array[0..10] of char;
begin
  carregat := false;
  try
    if Field <> nil then
    begin
      if field is TBlobField then
      begin
        camp := TBlobField(Field);
        stream := TBlobStream.Create(camp, bmRead);
        try
          if 11 = stream.Read(buf, 11) then
          begin
            if CompareMem(@cajpeg, @buf, 11) then
            begin
              Stream.Seek(soFromBeginning, 0);
              Jpeg1 := TJpegImage.Create;
              try
                Jpeg1.LoadFromStream(Stream);
                Picture.Assign(Jpeg1);
                carregat := true;
              finally
                jpeg1.free;
              end;
            end;
          end;
        finally
          stream.free;
        end;
      end;
    end;
  except
  end;
  if not carregat then
    inherited LoadPicture;
end;

procedure TDBMyImage.QuanPopUp(Sender: TObject);
begin
  if ReadOnly then
  begin
    popabrir.enabled := false;
    poppegar.enabled := false;
    popcortar.enabled := false;
  end
  else
  begin
    popabrir.enabled := true;
    poppegar.enabled := true;
    popcortar.enabled := true;
  end;
end;

procedure TDBMyimage.SaveAsJPeg;
var
  jpeg1: TJpegImage;
  blobs: TBlobStream;
  camp: TBlobField;
begin
  if readonly then
    exit;
  if Field = nil then
    exit;
  if not (field is TBlobField) then
    exit;
  camp := TBlobfield(field);
  jpeg1 := TJpegImage.Create;
  try
    jpeg1.Assign(picture.graphic);
    jpeg1.CompressionQuality := FCompressionQuality;
    blobs := TBlobStream.Create(camp, bmWrite);
    try
      blobs.Truncate;
      jpeg1.SaveToStream(blobs);
    finally
      blobs.free;
    end;
    blobs := TBlobStream.Create(camp, bmRead);
    try
      jpeg1.LoadFromStream(blobs);
    finally
      blobs.free;
    end;
  finally
    jpeg1.free;
  end;
end;

procedure TDBMyimage.PictureChanged(Sender: TObject);
begin
  if (FAutosize and (Picture <> nil)) then
  begin
    if Picture.Graphic <> nil then
    begin
      if ((Picture.graphic.width = 0) or (Picture.graphic.height = 0)) then
      begin
        width := defaultwidth;
        height := defaultheight;
      end
      else
      begin
        if Stretch then
        begin
          width := MulDiv(Picture.graphic.width, Zoom, 100);
          height := MulDiv(Picture.graphic.height, Zoom, 100);
        end
        else
        begin
          width := Picture.graphic.width;
          height := Picture.graphic.height;
        end;
      end;
    end;
  end;
  inherited PictureChanged(Sender);
end;

procedure TDBMyImage.loaded;
begin
  inherited loaded;
  defaultwidth := width;
  defaultheight := height;
end;

{New unit

Unic canvi per qu� funcioni
Declarar virtual LoadPicture
i procedure PictureChanged(Sender: TObject);virtual}

unit noudbct;

{$R-}

interface

uses
  Windows, SysUtils, Messages, Classes, Controls, Forms, Graphics,
  Menus, StdCtrls, ExtCtrls, Mask, Buttons, ComCtrls, Db, dbctrls;

type

  { TDBImage }

  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;

{ TDBImage2 }

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 { Control has focus, so realize the bitmap palette in foreground }
            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; { Draw the focus marker }
  inherited;
end;

procedure TDBImage2.CMExit(var Message: TCMExit);
begin
  try
    FDataLink.UpdateRecord;
  except
    SetFocus;
    raise;
  end;
  Invalidate; { Erase the focus marker }
  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.