ugsimage.pas

[原创]这是我写的一个图像组件!组件中使用了GraphicEx库

unit uGSImage;
(*
   * 开发: 默默
   * QQ: 520098973   261815701  87232728
   * Website: http://www.getstars.net
*)
interface

uses
  Windows,Graphics,SysUtils,Classes, Controls,ExtCtrls,Messages,jpeg,GGraphic;

type
  TBoxBorder=(bbLeft,bbTop,bbBottom,bbRight);
  TBoxBorders=set of TBoxBorder;
  TImageStyle=(isNone=0,isStretch=1,isRepeat=2);
  TImageHAlign=(iaHLeft=0,iaHCenter=1,iaHRight=2);//图像水平对齐方式
  TImageVAlign=(iaVTop=0,iaVCenter=1,iaVBottom=2);//图像垂直对齐方式
  TImageType=(
              itUnknow=0,
              itBMP,          (* *.bmp, *.rle, *.dib *)
              itJpeg,         (* *.jpg , *.jpeg *)
              itGif,          (* *.gif *)
              itPng,          (* *.png *)
              itTiff,         (* *.tif; *.tiff; *.fax *)
              itSgi,          (* *.bw, *.rgb, *.rgba, *.sgi *)
              itAutodesk,     (* *.cel; *.pic *)
              itTruevision,   (* *.tga; *.vst; *.icb; *.vda; *.win *)
              itZSof,         (* *.pcx; *.pcc; *.scr *)
              itKodak,        (* *.pcd *)
              itPortable,     (* *.ppm, *.pgm, *.pbm *)
              itDr,           (* *.cut, *.pal *)
              itSGIWavefront, (* *.rla, *.rpf *)
              itPhotoshop,    (* *.psd, *.pdd *)
              itPaintshop,    (* *.psp *)
              itIcon 
             );//图片类型

  TGSImage = class(TControl)
  private
      FCanvas:TCanvas;
      FBoxBorders:TBoxBorders;
      FShowBorder:Boolean;
      FBorderWidth:Integer;
      FBorderColor:TColor;
      FPicture:TPicture;
      FBrushStyle:TBrushStyle;
      FAutoSize:Boolean;
      FStyle:TImageStyle;
      FHAlign:TImageHAlign;
      FVAlign:TImageVAlign;
      FSmallBackColor:TColor;//缩略图的背影色(当图的尺寸小于要生成的缩略图的尺寸时才有效)
      FSmallWidth,FSmallHeight:LongInt;//缩略图的尺寸(宽,高)
      FSmall:Boolean;//是否是缩略图
      FImageType:TImageType;
      FPlayGif:Boolean;//如果图片是GIF动画,是否播放?,注意: 如果是缩略图显示方式,则无论此属性为何值,都不会生效
      FGifPicCount:Integer; //对GIF有效,GIF中帧的数量
      FGifIndex:Integer;    //当前播放的帧的索引

      FOnMouseLeave,FOnMouseEnter:TNotifyEvent;
      FFirstEnter:Boolean;

      FWindowHandle: HWND;
      procedure WndProc(var Msg: TMessage);
      procedure UpdateTimer(const AInterval:Integer=0);

      procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
      procedure WMMouseLeave(var Message: TMessage); message WM_MOUSELEAVE;
      procedure WMMouseOver(var Message: TMessage); message WM_MOUSEHOVER;
      procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;

      procedure SetBrushStyle(const value:TBrushStyle);
      procedure SetAutoSize(const value:Boolean);
      procedure SetStyle(const value:TImageStyle);
      procedure setHAlign(const value:TImageHAlign);
      procedure setVAlign(const value:TImageVAlign);
      procedure SetSmallBackColor(const value:TColor);
      procedure SetSmallWidth(const value:LongInt);
      procedure SetSmallHeight(const value:LongInt);
      procedure SetSmall(const value:Boolean);
      procedure DoChange(ASender:TObject);
      procedure setPalyGif(const value:boolean);
      procedure SetImageType(const value:TImageType);
      function getImageCount:Integer;
      procedure setImageCount(const value:Integer);
  protected
      procedure set_show_border(const value:Boolean);virtual;
      procedure set_borders(const value:TBoxBorders);virtual;
      procedure set_border_width(const value:integer);virtual;
      procedure set_border_color(const value:TColor);virtual;
      procedure DrawBorder();virtual;
      procedure DrawClientRect();virtual;
      procedure DrawPicture();virtual;
      procedure DrawGif();virtual;
      procedure Paint; virtual;
      procedure ClearCanvas;
      function GetClientRect: TRect;override;
      procedure SetPicture(const value:TPicture);virtual;

      procedure DoTimer;virtual;

  public
    constructor Create(AOwner:TComponent);override;
    destructor Destroy;override;
    function Jpg2BMP(const filename:string):TBitmap;overload;
    function Jpg2BMP(const AJpeg:TJpegImage):TBitmap;overload;
    function GetSmallImage(const ABmp:TBitmap;const width,height:integer;const BaclgroundColor:TColor=clBlack):TBitmap;
    procedure Reset;
  published
     property ShowBorder:Boolean read FShowBorder write set_show_border default True;
     property Borders:TBoxBorders read FBoxBorders write set_borders;
     property BorderWidth:Integer read FBorderWidth write set_border_width;
     property BorderColor:TColor read FBorderColor write set_border_color default clBlack;

     property Picture:TPicture read FPicture write SetPicture;
     property BrushStyle:TBrushStyle read FBrushStyle write SetBrushStyle;
     property AutoSize:Boolean read FAutoSize write SetAutoSize;
     property Style:TImageStyle read FStyle write SetStyle;
     property HAlign:TImageHAlign read FHAlign write setHAlign;
     property VAlign:TImageVAlign read FVAlign write setVAlign;
     property SmallBackColor:TColor read FSmallBackColor write SetSmallBackColor;
     property SmallWidth:LongInt read FSmallWidth write SetSmallWidth;
     property SmallHeight:LongInt read FSmallHeight write SetSmallHeight;
     property Small:Boolean read FSmall write SetSmall;
     property ImageType:TImageType read FImageType write SetImageType;
     property PalyGif:Boolean read FPlayGif write setPalyGif;
     property ImageCount:Integer read getImageCount write setImageCount;

     property Color;
     property Font;
     property Align;
     property PopupMenu;
     property ActionLink;
     property Caption;
     property DesktopFont;
     property DragKind;
     property DragCursor;
     property DragMode;
     property IsControl;
     property MouseCapture;
     property ParentBiDiMode;
     property ParentColor;
     property ParentFont;
     property ParentShowHint;
     property Visible;

     property OnCanResize;
     property OnClick;
     property OnConstrainedResize;
     property OnContextPopup;
     property OnDblClick;
     property OnDragDrop;
     property OnDragOver;
     property OnEndDock;
     property OnEndDrag;
     property OnMouseDown;
     property OnMouseMove;
     property OnMouseUp;
     property OnMouseWheel;
     property OnMouseWheelDown;
     property OnMouseWheelUp;
     property OnResize;
     property OnStartDock;
     property OnStartDrag;

     property OnMouseLeave:TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
     property OnMouseEnter:TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
  end;

procedure Register;
      
implementation

procedure Register;
begin
  RegisterComponents('摘星软件', [TGSImage]);
end;

procedure TGSImage.WMPaint(var Message: TWMPaint);
begin
  if Message.DC <> 0 then
  begin                 
    FCanvas.Lock;
    try
      FCanvas.Handle := Message.DC;
      try
         Paint;
      finally
         FCanvas.Handle := 0;
      end;
    finally
      FCanvas.Unlock;    
    end;
  end;
end;

procedure TGSImage.WMMouseLeave(var Message:TMessage);
begin
  FFirstEnter:=True;
  inherited;
  if Assigned(FOnMouseLeave) then try FOnMouseLeave(Self);except end;
end;

procedure TGSImage.WMMouseOver(var Message: TMessage);
begin
  inherited;
  if Assigned(FOnMouseEnter) then try FOnMouseEnter(Self);except end;
end;

procedure TGSImage.WMMouseMove(var Message: TWMMouseMove);
var
  tme:TTRACKMOUSEEVENT;
begin
    if FFirstEnter and Assigned(Parent) then
    begin
        tme.cbSize := sizeof(tme);
        tme.hwndTrack := Parent.Handle;
        tme.dwFlags := TME_LEAVE;
        TrackMouseEvent(tme);
        FFirstEnter:=False;
        if Assigned(FOnMouseEnter) then try FOnMouseEnter(Self);except end;
    end;
    inherited;
end;

procedure TGSImage.SetBrushStyle(const value:TBrushStyle);
begin
    FBrushStyle:=value;
    Repaint;
end;

procedure TGSImage.SetAutoSize(const value:Boolean);
begin
    FAutoSize:=value;
    if value then
    begin
       //SetStyle(isNone);
       //setVAlign(iaVTop);
       //setHAlign(iaHLeft);
    end;
    Repaint;
end;

procedure TGSImage.SetStyle(const value:TImageStyle);
begin
    FStyle:=value;
    if not FAutoSize then Repaint;
end;

procedure TGSImage.setHAlign(const value:TImageHAlign);
begin
    FHAlign:=value;
    if (not (FStyle in [isStretch,isRepeat])) and (not FAutoSize) then Repaint;
end;

procedure TGSImage.setVAlign(const value:TImageVAlign);
begin
    FVAlign:=value;
    if (not (FStyle in [isStretch,isRepeat])) and (not FAutoSize) then Repaint;
end;

procedure TGSImage.SetSmallBackColor(const value:TColor);
begin
    FSmallBackColor:=value;
    if FSmall then Repaint;
end;

procedure TGSImage.SetSmallWidth(const value:LongInt);
begin
    FSmallWidth:=value;
    if FSmall then Repaint;
end;

procedure TGSImage.SetSmallHeight(const value:LongInt);
begin
    FSmallHeight:=value;
    if FSmall then Repaint;
end;

procedure TGSImage.SetSmall(const value:Boolean);
begin
    FSmall:=value;
    Repaint; 
end;

procedure TGSImage.DoChange(ASender:TObject);
begin
    FImageType:=itUnknow;
    UpdateTimer(0);
    if FPicture.Graphic is TGIFGraphic then
    begin
       //FGifPicCount:=TGIFGraphic(FPicture.Graphic).ImageProperties.ImageCount;
       FGifIndex:=0;
       FImageType:=itGif;
       //TGIFGraphic(FPicture.Graphic).ReadImageProperties()
    end else if FPicture.Graphic is TTIFFGraphic then begin
       FImageType:=itTiff;
    end else if FPicture.Graphic is TSGIGraphic then begin
       FImageType:=itSgi;
    end else if FPicture.Graphic is TAutodeskGraphic then begin
       FImageType:=itAutodesk;
    end else if FPicture.Graphic is TTargaGraphic then begin
       FImageType:=itTruevision;
    end else if FPicture.Graphic is TPCXGraphic then begin
       FImageType:=itZSof;
    end else if FPicture.Graphic is TPCDGraphic then begin
       FImageType:=itKodak;
    end else if FPicture.Graphic is TPPMGraphic then begin
       FImageType:=itPortable;
    end else if FPicture.Graphic is TCUTGraphic then begin
       FImageType:=itDr;
    end else if FPicture.Graphic is TRLAGraphic then begin
       FImageType:=itSGIWavefront;
    end else if FPicture.Graphic is TPSDGraphic then begin
       FImageType:=itPhotoshop;
    end else if FPicture.Graphic is TPSPGraphic then begin
       FImageType:=itPaintshop;
    end else if FPicture.Graphic is TIcon then begin
       FImageType:=itIcon;
    end else if FPicture.Graphic is TJPEGImage then begin
       FImageType:=itJpeg;
    end else if FPicture.Graphic is TPNGGraphic  then begin
       FImageType:=itPng;
    end else if FPicture.Graphic is TBitmap then begin
       FImageType:=itBMP;
    end;
    
    if FAutoSize then
    begin
        if Assigned(FPicture.Graphic) and (not FPicture.Graphic.Empty) then
        begin
            ClientWidth:=FPicture.Width;
            ClientHeight:=FPicture.Height;
        end else begin
            ClientWidth:=6;
            ClientHeight:=6;
        end;
    end;
end;

procedure TGSImage.setPalyGif(const value:boolean);
begin
    FPlayGif:=value;
end;

procedure TGSImage.SetImageType(const value:TImageType);
begin
end;

procedure TGSImage.WndProc(var Msg: TMessage);
begin
  with Msg do
  begin
    if Msg = WM_TIMER then
    begin
      try
        DoTimer;
      except
        
      end
    end else begin
      Result := DefWindowProc(FWindowHandle, Msg, wParam, lParam);
    end;
  end;
end;

procedure TGSImage.UpdateTimer(const AInterval:Integer=0);
begin
  //更新时钟,如果参数 AInterval 小于等于0 则停止时钟
  if FWindowHandle<1 then Exit;
  KillTimer(FWindowHandle, 1);