{-------------------------------------------------------------------------------
Author:      Jan Krieger, Ismaning (Munich), Germany
             jan@jkrieger.de
             http://www.jkrieger.de/
Date:        June 10./11. 2000
Name:        TJKDBPackImage
Version:     1.0
Copyright:   (c) 2000 by Jan W. Krieger. All rights reserved.
Description: this component is like TDBImage, but it packs the images before
             saving it to the database and unpacks it when showing them
             it needs the zlib (provided on the Delphi-CD) to be compiled!
             the property Compressionlevel may be used to optimize packing
             for speed, or size!
Status:      This unit is FREEWARE, so no support can be granted
             Everybody may feel free to copy and use it.
             If you alter the sourcecode, it would be kind to send me the
             new source!

--------------------------------------------------------------------------------
                   This comment may not be deleted !!!
--------------------------------------------------------------------------------}
unit JKDBPackImage;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  DBCtrls, db, dbtables, clipbrd, zlib;

type
  TJKDBPackImage = class(TCustomControl)
  private
    FDataLink: TFieldDataLink;
    FPicture: TPicture;
    FBorderStyle: TBorderStyle;
    FAutoDisplay: Boolean;
    FStretch: Boolean;
    FCenter: Boolean;
    FPictureLoaded: Boolean;
    FQuickDraw: Boolean;
    FCompressionLevel:TCompressionLevel;
    procedure DataChange(Sender: TObject);
    function GetDataField: string;
    function GetDataSource: TDataSource;
    function GetField: TField;
    function GetReadOnly: Boolean;
    procedure PictureChanged(Sender: TObject);
    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;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure CopyToClipboard;
    procedure CutToClipboard;
    function ExecuteAction(Action: TBasicAction): Boolean; override;
    procedure LoadPicture;
    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 CompressionLevel:TCompressionLevel read FCompressionLevel write FCompressionLevel default clFastest;
    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 OnContextPopup;
    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;

procedure PackStream(inStream, outStream :TStream; CompressionLevel:TCompressionLevel);
procedure ExpandStream(inStream, outStream :TStream);

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('JKSoft', [TJKDBPackImage]);
end;

procedure PackStream(inStream, outStream :TStream; CompressionLevel:TCompressionLevel);
var ZStream: TCompressionStream;
begin
    ZStream := TCompressionStream.Create(CompressionLevel, OutStream);
  try
    ZStream.CopyFrom(InStream, 0);
  finally
    ZStream.Free;
  end;
end;

procedure ExpandStream(inStream, outStream :TStream);
const
  BufferSize = 4096;
var
  Count: Integer;
  ZStream: TDecompressionStream;
  Buffer: array[0..BufferSize-1] of Byte;
begin
  ZStream := TDecompressionStream.Create(InStream);
  try
    while True do
      begin
        Count := ZStream.Read(Buffer, BufferSize);
        if Count <> 0 then OutStream.WriteBuffer(Buffer, Count) else Break;
      end;
  finally
    ZStream.Free;
  end;
end;





constructor TJKDBPackImage.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 TJKDBPackImage.Destroy;
begin
  FPicture.Free;
  FDataLink.Free;
  FDataLink := nil;
  inherited Destroy;
end;

function TJKDBPackImage.GetDataSource: TDataSource;
begin
  Result := FDataLink.DataSource;
end;

procedure TJKDBPackImage.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 TJKDBPackImage.GetDataField: string;
begin
  Result := FDataLink.FieldName;
end;

procedure TJKDBPackImage.SetDataField(const Value: string);
begin
  FDataLink.FieldName := Value;
end;

function TJKDBPackImage.GetReadOnly: Boolean;
begin
  Result := FDataLink.ReadOnly;
end;

procedure TJKDBPackImage.SetReadOnly(Value: Boolean);
begin
  FDataLink.ReadOnly := Value;
end;

function TJKDBPackImage.GetField: TField;
begin
  Result := FDataLink.Field;
end;

function TJKDBPackImage.GetPalette: HPALETTE;
begin
  Result := 0;
  if FPicture.Graphic is TBitmap then
    Result := TBitmap(FPicture.Graphic).Palette;
end;

procedure TJKDBPackImage.SetAutoDisplay(Value: Boolean);
begin
  if FAutoDisplay <> Value then
  begin
    FAutoDisplay := Value;
    if Value then LoadPicture;
  end;
end;

procedure TJKDBPackImage.SetBorderStyle(Value: TBorderStyle);
begin
  if FBorderStyle <> Value then
  begin
    FBorderStyle := Value;
    RecreateWnd;
  end;
end;

procedure TJKDBPackImage.SetCenter(Value: Boolean);
begin
  if FCenter <> Value then
  begin
    FCenter := Value;
    Invalidate;
  end;
end;

procedure TJKDBPackImage.SetPicture(Value: TPicture);
begin
  FPicture.Assign(Value);
end;

procedure TJKDBPackImage.SetStretch(Value: Boolean);
begin
  if FStretch <> Value then
  begin
    FStretch := Value;
    Invalidate;
  end;
end;

procedure TJKDBPackImage.Paint;
var
  Size: TSize;
  R: TRect;
  S: string;
  DrawPict: TPicture;
  Form: TCustomForm;
  Pal: HPalette;
// ------------------------------
  Blob:TBlobStream;
  Mem:TMemoryStream;
  bmp:TBitMap;
// ------------------------------

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
// Entpacken des Feldes -----------------------------------------------------------------------
          try
            blob:=TBlobSTream.create(TBlobField(GetField), bmRead);
            Mem:=TMemoryStream.create;
            try ExpandStream(blob,mem); except end;
            mem.Position:=0;
//          showmessage('loading');
            DrawPict.bitmap.LoadFromStream(mem);
            bmp:=TBitMap.create;
            bmp.LoadFromStream(mem);
//          form2.image1.canvas.draw(1,1,bmp);
            DrawPict.Assign(bmp);
            bmp.free;
            blob.free;
            mem.free;
          except
          end;
// --------------------------------------------------------------------------------------------



          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 TJKDBPackImage.PictureChanged(Sender: TObject);
begin
  if FPictureLoaded then FDataLink.Modified;
  FPictureLoaded := True;
  Invalidate;
end;

procedure TJKDBPackImage.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (FDataLink <> nil) and
    (AComponent = DataSource) then DataSource := nil;
end;

procedure TJKDBPackImage.LoadPicture;
var blob:TBlobStream;
    mem:TMemoryStream;
    bmp:TBitMap;
begin
  if not FPictureLoaded and (not Assigned(FDataLink.Field) or FDataLink.Field.IsBlob) then begin
    // Entpacken des Feldes -----------------------------------------------------------------------
    try
       blob:=TBlobSTream.create(TBlobField(FDataLink.Field), bmRead);
       blob.position:=0;
       Mem:=TMemoryStream.create;
       try ExpandStream(blob,mem); except end;
       mem.Position:=0;
       bmp:=TBitMap.create;
       bmp.LoadFromStream(mem);
       Picture.assign(bmp);
       bmp.free;
       blob.free;
       mem.free;
    except
    end;
    // --------------------------------------------------------------------------------------------
    FPictureLoaded:=true;
  end;
end;

procedure TJKDBPackImage.DataChange(Sender: TObject);
begin
  Picture.Graphic := nil;
  FPictureLoaded := False;
  if FAutoDisplay then LoadPicture;
end;

procedure TJKDBPackImage.UpdateData(Sender: TObject);
var blob:TBlobStream;
    mem:TMemoryStream;
begin
  if Picture.Graphic is TBitmap then begin
//     FDataLink.Field.Assign(Picture.Graphic)
    // Packen des Feldes --------------------------------------------------------------------------
    try
          TBlobField(GetField).clear;
          blob:=TBlobSTream.create(TBlobField(GetField), bmWrite);
          blob.Position:=0;
          Mem:=TMemoryStream.create;
          Picture.graphic.SaveToStream(mem);
//          mem.Position:=0;
//          form2.Image1.Picture.bitmap.LoadFromStream(mem);
//          ShowMessage('packe');
          mem.Position:=0;
          PackStream(mem,blob,CompressionLevel);
          //TBlobField(GetField).loadfromstream(blob);
          blob.free;
          mem.free;
    except
    end;
    // --------------------------------------------------------------------------------------------
  end else FDataLink.Field.Clear;
end;

procedure TJKDBPackImage.CopyToClipboard;
begin
  if Picture.Graphic <> nil then Clipboard.Assign(Picture);
end;

procedure TJKDBPackImage.CutToClipboard;
begin
  if Picture.Graphic <> nil then
    if FDataLink.Edit then
    begin
      CopyToClipboard;
      Picture.Graphic := nil;
    end;
end;

procedure TJKDBPackImage.PasteFromClipboard;
begin
  if Clipboard.HasFormat(CF_BITMAP) and FDataLink.Edit then
    Picture.Bitmap.Assign(Clipboard);
end;

procedure TJKDBPackImage.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 TJKDBPackImage.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 TJKDBPackImage.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 TJKDBPackImage.CMGetDataLink(var Message: TMessage);
begin
  Message.Result := Integer(FDataLink);
end;

procedure TJKDBPackImage.CMEnter(var Message: TCMEnter);
begin
  Invalidate; { Draw the focus marker }
  inherited;
end;

procedure TJKDBPackImage.CMExit(var Message: TCMExit);
begin
  try
    FDataLink.UpdateRecord;
  except
    SetFocus;
    raise;
  end;
  Invalidate; { Erase the focus marker }
  inherited;
end;

procedure TJKDBPackImage.CMTextChanged(var Message: TMessage);
begin
  inherited;
  if not FPictureLoaded then Invalidate;
end;

procedure TJKDBPackImage.WMLButtonDown(var Message: TWMLButtonDown);
begin
  if TabStop and CanFocus then SetFocus;
  inherited;
end;

procedure TJKDBPackImage.WMLButtonDblClk(var Message: TWMLButtonDblClk);
begin
  LoadPicture;
  inherited;
end;

procedure TJKDBPackImage.WMCut(var Message: TMessage);
begin
  CutToClipboard;
end;

procedure TJKDBPackImage.WMCopy(var Message: TMessage);
begin
  CopyToClipboard;
end;

procedure TJKDBPackImage.WMPaste(var Message: TMessage);
begin
  PasteFromClipboard;
end;

procedure TJKDBPackImage.WMSize(var Message: TMessage);
begin
  inherited;
  Invalidate;
end;

function TJKDBPackImage.ExecuteAction(Action: TBasicAction): Boolean;
begin
  Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and
    FDataLink.ExecuteAction(Action);
end;

function TJKDBPackImage.UpdateAction(Action: TBasicAction): Boolean;
begin
  Result := inherited UpdateAction(Action) or (FDataLink <> nil) and
    FDataLink.UpdateAction(Action);
end;


end.