
{                                                                              }
{ IB_JPEGImage                                                                 }
{                                                                              }

{***************************************************************}
{                                                               }
{          IB Objects Components and Resources Library          }
{                                                               }
{          Copyright (C) 1996-2007 Jason Wharton                }
{          and Computer Programming Solutions, Mesa, AZ         }
{                                                               }
{  This source code unit is released under the terms of the     }
{  CPS Trustware License.                                       }
{  It may be distributed or deployed as source code or in       }
{  compiled form only in compliance with the terms and          }
{  conditions of the CPS Trustware License which may be         )
{  examined at http://www.ibobjects.com/ibo_trustware.html      )
{                                                               }
{***************************************************************}

{$INCLUDE IB_Directives.inc}

unit
  IB_JPEGImage;
{
----------------------------------------------------------------

Note, this unit has been totally rewritten, though what is currently in place
was inspired from the contributions in the former unit with the same name
contributed by community members into freeware.

It seemed apparent the TIB_CustomImage component was the model followed in
making the former component so is all I have essentially done is make it a sub-
class of it instead of patterning after it.

Jason Wharton
jwharton@ibobjects.com

----------------------------------------------------------------
These were the original credits in the former unit file:

TIB_JPEGImage v1.1 - IBO data aware JPEG component
(03.02.2001)
(c) 2001 by Thomas Steinmaurer

(28.05.2001) Changes by Martin Schmid - www.equitania.de
Replaced Paint Procedure with the routine TDBImageAspect of from http://www.ec-software.com
The difference is, that the image will be displayed with its correct aspect ratio, when 'Stretch := true' (it is by default). 
When 'Stretch := false', it behaves like a normal DBImage. 
NOTE: The Image is only stretched until its original size, not beyond.

E-Mail: iblogmanager@aon.at

This component is Freeware. Please distribute always the whole component unchanged.
If you find bugs or have any suggestions, please send me an E-Mail. Thanks!

The use of this component is at your own risk.
I do not take any responsibility for any damages.

See also: IB LogManager - The Logging Tool for Interbase

WWW:        http://www.equitania.de/interbase/iblogmanager/start.htm   (German)
            http://www.equitania.de/interbase/iblogmanager/default.htm (English)
Newsgroups: news://victory.equitania.de/interbase.iblogmanager.de      (German)
            news://victory.equitania.de/interbase.iblogmanager.en      (English)
eGroups:    http://www.egroups.com/group/iblogmanager
E-Mail:     iblogmanager@aon.at}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  IB_Session, IB_Components, IB_Controls, IB_Constants, Jpeg, shellApi;

type

TJPEGChangeEvent= procedure( Val: Byte ) of object;

TJPEGOptions = Class(TPersistent)
private
  FGrayScale: Boolean;
  FPixelFormat: TJPEGPixelFormat;
  FProgressiveDisplay: Boolean;
  FPerformance : TJPEGPerformance;
  FScale: TJPEGScale;
  FSmoothing: Boolean;
  FOnChange: TJPEGChangeEvent;
protected
  procedure SetGrayScale(Value : Boolean);
  procedure SetPixelFormat(Value : TJPEGPixelFormat);
  procedure SetProgressiveDisplay(Value : Boolean);
  procedure SetPerformance(Value : TJPEGPerformance );
  procedure SetScale(Value : TJPEGScale);
  procedure SetSmoothing(Value : Boolean);
public
  constructor Create;
  procedure Change( Val: Byte );
published
  property GrayScale: Boolean read FGrayScale write SetGrayScale default false;
  property PixelFormat: TJPEGPixelFormat read FPixelFormat
                                         write SetPixelFormat
                                         default jf24Bit;
  property ProgressiveDisplay: Boolean read FProgressiveDisplay
                                       write SetProgressiveDisplay
                                       default False;
  property Performance: TJPEGPerformance read FPerformance
                                         write SetPerformance
                                         default jpBestQuality;
  property Scale: TJPEGScale read FScale write SetScale default jsFullSize;
  property Smoothing: Boolean Read FSmoothing write SetSmoothing default true;
  property OnChange: TJPEGChangeEvent read FOnChange write FOnChange;
end;

TIB_JPEGImage = class(TIB_CustomImage)
private
  FJPEGOptions: TJPEGOptions;
  procedure UpdateJPEG(Flag : Byte);
  procedure WMCREATE(var Message: TMessage); message WM_CREATE;
  procedure WMDROPFILES(var Msg: TMessage); message WM_DROPFILES;
protected
  procedure InternalUpdateData; override;
  procedure InternalLoadPicture; override;
  procedure Paint; override;
  procedure SysPictureChanged; override;
public
  constructor Create(AOwner: TComponent); override;
  destructor Destroy; override;

  procedure PasteFromClipboard; override;
{$DEFINE IB_FieldControl}
{$DEFINE IBC_Image}
{$DEFINE IB_AutoLabel}
{$I IB_WinControl.PBL}
{$UNDEF IB_AutoLabel}
{$UNDEF IBC_Image}
{$UNDEF IB_FieldControl}
published
  property JPEGOptions: TJPEGOptions read FJPEGOptions write FJPEGOptions;
  property AutoDisplay;
  property AutoSize;
  property Center;
  property QuickDraw;
  property Stretch;
end;

implementation

uses
  Clipbrd;

constructor TIB_JPEGImage.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FJPEGOptions := TJPEGOptions.Create;
  FJPEGOptions.OnChange := UpdateJPEG;
end;

destructor TIB_JPEGImage.Destroy;
begin
  inherited Destroy;
  FJPEGOptions.Free;
  FJPEGOptions := nil;
end;

procedure TIB_JPEGImage.InternalUpdateData;
var
  JPEG: TJPEGImage;
begin
  if Assigned( Picture.Graphic ) and ( not Picture.Graphic.Empty ) then
  begin
    if Picture.Graphic is TJpegImage then
      Field.Assign( Picture.Graphic )
    else
    begin
      JPEG := TJPEGImage.Create;
      try
        JPEG.Assign( Picture.Graphic );
        Field.Assign( JPEG );
      finally
        JPEG.Free;
      end;
    end;
  end
  else
    Field.Clear;
end;

procedure TIB_JPEGImage.InternalLoadPicture;
var
  JPEG: TJPEGImage;
  BlobStream: TStream;
begin
  JPEG := TJPEGImage.Create;
  try
    BlobStream := DataLink.Dataset.CreateBlobStream( Field, bsmRead );
    try
      JPEG.LoadFromStream( BlobStream );
      Picture.Assign( JPEG );
    finally
      BlobStream.Free;
    end;
  finally
    JPEG.Free;
  end;
end;

procedure TIB_JPEGImage.SysPictureChanged;
begin
  if Picture.Graphic is TJPEGImage then
    with TJPEGImage(Picture.Graphic) do
    begin
      PixelFormat := FJPEGOptions.PixelFormat;
      Scale := FJPEGOptions.Scale;
      Grayscale := FJPEGOptions.GrayScale;
      Performance := FJPEGOptions.Performance;
      ProgressiveDisplay := FJPEGOptions.ProgressiveDisplay;
      Smoothing := FJPEGOptions.Smoothing;
    end;
  inherited SysPictureChanged;
end;

procedure TIB_JPEGImage.PasteFromClipboard;
var
  JPEG: TJpegImage;
begin
  if Clipboard.HasFormat(CF_PICTURE) and DataLink.Modify then
  begin
    JPEG := TJpegImage.Create;
    try
      Picture.Assign( Clipboard );
      JPEG.Assign( Picture.Graphic );
      Picture.Graphic := JPEG;
    finally
      JPEG.Free;
    end;
  end;
end;

procedure TIB_JPEGImage.Paint;
var
  W, H: Integer;
  X, Y: Integer;
  R, RAspect: TRect;
  S: string;
  DrawPict: TPicture;
  JPEG: TJPEGImage;
  BlobStream: TStream;
begin
  with Canvas do
  begin
    Brush.Style := bsSolid;
    Brush.Color := Color;
    if Assigned( Field ) and
       ( PictureLoaded or (csPaintCopy in ControlState)) then
    begin
      DrawPict := TPicture.Create;
      H := 0;
      try
        if (csPaintCopy in ControlState) and
           Assigned(Field) and
           Field.IsBlob then
        begin
          if Field.IsNotNull then
          begin
            JPEG := TJPEGImage.Create;
            try
              BlobStream := DataLink.Dataset.CreateBlobStream( Field, bsmRead );
              try
                JPEG.LoadFromStream( BlobStream );
                DrawPict.Assign( JPEG );
              finally
                BlobStream.Free;
              end;
            finally
              JPEG.Free;
            end;
          end;
          if DrawPict.Graphic is TBitmap then
            DrawPict.Bitmap.IgnorePalette := QuickDraw; //!!
        end
        else
        begin
          DrawPict.Assign( Picture );
          if Focused and
             ( DrawPict.Graphic is TBitmap ) and
             ( DrawPict.Bitmap.Palette <> 0 ) then
          begin
          { Control has focus, so realize the bitmap palette in foreground }
            H := SelectPalette( Handle, DrawPict.Bitmap.Palette, False );
            RealizePalette( Handle );
          end;
        end;
        if Stretch then
          if (DrawPict.Graphic = nil) or DrawPict.Graphic.Empty then
            FillRect(ClientRect)
          else
          begin
            x := DrawPict.width;
            y := DrawPict.height;
            if x > Clientwidth then
            begin
              y := round(y * (Clientwidth/x));
              x := Clientwidth;
            end;
            if y > Clientheight then
            begin
              x := round(x * (Clientheight/y));
              y := Clientheight;
            end;
            RAspect := ClientRect;
            RAspect.right := x;
            RAspect.bottom:= y;
            if Center then
              OffsetRect( RAspect, (ClientWidth - x) div 2,
                                   (ClientHeight - y) div 2 );
            StretchDraw( RAspect , DrawPict.Graphic);
            ExcludeClipRect( Handle, RAspect.Left,
                                     RAspect.Top,
                                     RAspect.Right,
                                     RAspect.Bottom );
            FillRect( ClientRect );
            SelectClipRgn( Handle, 0 );
          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 H <> 0 then
          SelectPalette(Handle, H, True);
        DrawPict.Free;
      end;
    end
    else
    begin
      Font := Self.Font;
      if Field <> nil then
        S := Field.DisplayLabel
      else
        S := Name;
      S := '(' + S + ')';
      W := TextWidth(S);
      H := TextHeight(S);
      R := ClientRect;
      TextRect( R, (R.Right - W) div 2, (R.Bottom - H) div 2, S );
    end;
    if ( GetParentForm(Self).ActiveControl = Self ) and
       not (csDesigning in ComponentState) and
       not (csPaintCopy in ControlState) then
    begin
      Brush.Color := clWindowFrame;
      FrameRect( ClientRect );
    end;
  end;
end;

procedure TIB_JPEGImage.WMCREATE(var Message: TMessage);
begin
  DragAcceptFiles( Handle, True );
end;

procedure TIB_JPEGImage.WMDROPFILES(var Msg: TMessage);
  function CompareFileExtension( FileName: PChar; Extension: string ): boolean;
  begin
    Result := UpperCase(ExtractFileExt(StrPas(FileName))) = Extension;
  end;
var
  fileCount: integer;
  fileName: pchar;
  size: integer;
begin
  fileName := '';
  fileCount := DragQueryFile( Msg.WParam, $FFFFFFFF, fileName, 255 );
  if fileCount = 1 then
  begin
    size := DragQueryFile( Msg.WParam, 0, nil, 0 ) + 1;
    fileName := StrAlloc( size );
    DragQueryFile(Msg.WParam, 0, fileName, size);
    try
      if CompareFileExtension( fileName, '.JPG'  ) or
         CompareFileExtension( fileName, '.JPEG' ) or
         CompareFileExtension( fileName, '.WMF'  ) or
         CompareFileExtension( fileName, '.BMP'  ) or
         CompareFileExtension( fileName, '.ICO'  ) then
        Picture.LoadFromFile( StrPas( fileName ))
      else
        raise Exception.Create( E_Graphic_Format_Not_Supported );
    finally
      StrDispose( fileName );
    end;
    DragFinish( Msg.WParam );
  end
  else
    raise Exception.Create( E_Only_one_file_allowed );
end;

procedure TIB_JPEGImage.UpdateJPEG(Flag: Byte);
begin
  if Picture.Graphic is TJPEGImage then
    with TJPEGImage(Picture.Graphic) do
    begin
      case Flag of
        1: Grayscale := FJPEGOptions.GrayScale;
        2: PixelFormat := FJPEGOptions.PixelFormat;
        3: ProgressiveDisplay := FJPEGOptions.ProgressiveDisplay;
        4: Performance := FJPEGOptions.Performance;
        5: Scale := FJPEGOptions.Scale;
        6: Smoothing := FJPEGOptions.Smoothing;
      end;
//    if Flag <> 3 then if Assigned(FOldChanged) then FOldChanged(Picture);
  end;
end;

{ TJPEGOptions }

procedure TJPEGOptions.Change(Val: Byte);
begin
  if Assigned(OnChange) then OnChange(val);
end;

constructor TJPEGOptions.Create;
begin
  inherited Create;
  FGrayScale := False;
  FPixelFormat := jf24Bit;
  FProgressiveDisplay := False;
  FPerformance := jpBestQuality;
  FScale := jsFullSize;
  FSmoothing := True;
end;

procedure TJPEGOptions.SetGrayScale(Value: Boolean);
begin
  if Value <> FGrayScale then begin
    FGrayScale := Value;
    Change(1);
  end;
end;

procedure TJPEGOptions.SetPerformance(Value: TJPEGPerformance);
begin
  if Value <> FPerformance then begin
    FPerformance := Value;
    Change(4);
  end;
end;

procedure TJPEGOptions.SetPixelFormat(Value: TJPEGPixelFormat);
begin
  if Value <> FPixelFormat then begin
    FPixelFormat := Value;
    Change(2);
  end;
end;

procedure TJPEGOptions.SetProgressiveDisplay(Value: Boolean);
begin
  if Value <> FProgressiveDisplay then begin
    FProgressiveDisplay := Value;
    Change(3);
  end;
end;

procedure TJPEGOptions.SetScale(Value: TJPEGScale);
begin
  if Value <> FScale then begin
    FScale := Value;
    Change(5);
  end;
end;

procedure TJPEGOptions.SetSmoothing(Value: Boolean);
begin
  if Value <> FSmoothing then begin
    FSmoothing := Value;
    Change(6);
  end;
end;

end.
