dynamicimage.pas

一个基于不需引擎的文件管理系统,使用了许多界面比较好的控件

unit Dynamicimage;

interface

uses Messages, Windows, SysUtils, Classes, Controls, Forms, Dialogs, Graphics,
     StdCtrls, Consts, Jpeg;

type
  TDynamicimageThread=class;

  TDynamicimage = class(TGraphicControl)
  private
    DynamicTimer:TDynamicimageThread;
    CurIdx:integer;
    FPicture: TPicture;
    FOnProgress: TProgressEvent;
    FStretch: Boolean;
    FCenter: Boolean;
    FIncrementalDisplay: Boolean;
    FTransparent: Boolean;
    FDrawing: Boolean;
    FProportional: Boolean;
    FFrameCount: integer;
    FDynamicPicture: TPicture;
    FActive: Boolean;
    FHalt: Boolean;
    Finterval: integer;
    FStickTime: integer;
    function GetCanvas: TCanvas;
    procedure PictureChanged(Sender: TObject);
    procedure SetCenter(Value: Boolean);
    procedure SetPicture(Value: TPicture);
    procedure SetStretch(Value: Boolean);
    procedure SetTransparent(Value: Boolean);
    procedure SetProportional(Value: Boolean);
    procedure SetFrameCount(const Value: integer);
    procedure SetDynamicPicture(const Value: TPicture);
    procedure CutSinglePic(Pic:TPicture;idx:integer);
    procedure SetActive(const Value: Boolean);
    procedure SetHalt(const Value: Boolean);
    procedure Setinterval(const Value: integer);
    procedure SetStickTime(const Value: integer);
  protected
    function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;
    function DestRect: TRect;
    function DoPaletteChange: Boolean;
    function GetPalette: HPALETTE; override;
    procedure Paint; override;
    procedure Progress(Sender: TObject; Stage: TProgressStage;
      PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string); dynamic;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure play;
    property Canvas: TCanvas read GetCanvas;
    property Halt:Boolean read FHalt write SetHalt;
  published
    property FrameCount:integer read FFrameCount write SetFrameCount;
    property DynamicPicture: TPicture read FDynamicPicture write SetDynamicPicture;
    property Active:Boolean read FActive write SetActive;
    property interval:integer read Finterval write Setinterval;
    property StickTime:integer read FStickTime write SetStickTime;
    property Align;
    property Anchors;
    property AutoSize;
    property Center: Boolean read FCenter write SetCenter default False;
    property Constraints;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property IncrementalDisplay: Boolean read FIncrementalDisplay write FIncrementalDisplay default False;
    property ParentShowHint;
    property Picture: TPicture read FPicture write SetPicture;
    property PopupMenu;
    property Proportional: Boolean read FProportional write SetProportional default false;
    property ShowHint;
    property Stretch: Boolean read FStretch write SetStretch default False;
    property Transparent: Boolean read FTransparent write SetTransparent default False;
    property Visible;
    property OnClick;
    property OnContextPopup;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnProgress: TProgressEvent read FOnProgress write FOnProgress;
    property OnStartDock;
    property OnStartDrag;
  end;

  TDynamicimageThread=class(TThread)
  private
    Createor:TDynamicimage;
  protected
    procedure Execute; override;
  public
    constructor Create(CreateSuspended: Boolean);
    procedure AfterConstruction; override;
  end;

implementation

{ TImage }

constructor TDynamicimage.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csReplicatable];
  FPicture := TPicture.Create;
  FDynamicPicture := TPicture.Create;
  FPicture.OnChange := PictureChanged;
  FPicture.OnProgress := Progress;
  Height := 105;
  Width := 105;
  Finterval := 125;
  FStickTime := 500;
end;

destructor TDynamicimage.Destroy;
begin
  FPicture.Free;
  FDynamicPicture.Free; 
  inherited Destroy;
end;

function TDynamicimage.GetPalette: HPALETTE;
begin
  Result := 0;
  if FPicture.Graphic <> nil then
    Result := FPicture.Graphic.Palette;
end;

function TDynamicimage.DestRect: TRect;
var
  w, h, cw, ch: Integer;
  xyaspect: Double;
begin
  w := Picture.Width;
  h := Picture.Height;
  cw := ClientWidth;
  ch := ClientHeight;
  if Stretch or (Proportional and ((w > cw) or (h > ch))) then
  begin
    if Proportional and (w > 0) and (h > 0) then
    begin
      xyaspect := w / h;
      if w > h then
      begin
        w := cw;
        h := Trunc(cw / xyaspect);
        if h > ch then  // woops, too big
        begin
          h := ch;
          w := Trunc(ch * xyaspect);
        end;
      end
      else
      begin
        h := ch;
        w := Trunc(ch * xyaspect);
        if w > cw then  // woops, too big
        begin
          w := cw;
          h := Trunc(cw / xyaspect);
        end;
      end;
    end
    else
    begin
      w := cw;
      h := ch;
    end;
  end;

  with Result do
  begin
    Left := 0;
    Top := 0;
    Right := w;
    Bottom := h;
  end;

  if Center then
    OffsetRect(Result, (cw - w) div 2, (ch - h) div 2);
end;

procedure TDynamicimage.Paint;
var
  Save: Boolean;
begin
  if csDesigning in ComponentState then
  with inherited Canvas do
  begin
    Pen.Style := psDash;
    Brush.Style := bsClear;
    Rectangle(0, 0, Width, Height);
  end;
  Save := FDrawing;
  FDrawing := True;
  try
    with inherited Canvas do
      StretchDraw(DestRect, Picture.Graphic);
  finally
    FDrawing := Save;
  end;
end;

function TDynamicimage.DoPaletteChange: Boolean;
var
  ParentForm: TCustomForm;
  Tmp: TGraphic;
begin
  Result := False;
  Tmp := Picture.Graphic;
  if Visible and (not (csLoading in ComponentState)) and (Tmp <> nil) and
    (Tmp.PaletteModified) then
  begin
    if (Tmp.Palette = 0) then
      Tmp.PaletteModified := False
    else
    begin
      ParentForm := GetParentForm(Self);
      if Assigned(ParentForm) and ParentForm.Active and Parentform.HandleAllocated then
      begin
        if FDrawing then
          ParentForm.Perform(wm_QueryNewPalette, 0, 0)
        else
          PostMessage(ParentForm.Handle, wm_QueryNewPalette, 0, 0);
        Result := True;
        Tmp.PaletteModified := False;
      end;
    end;
  end;
end;

procedure TDynamicimage.Progress(Sender: TObject; Stage: TProgressStage;
  PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string);
begin
  if FIncrementalDisplay and RedrawNow then
  begin
    if DoPaletteChange then
      Update
    else
      Paint;
  end;
  if Assigned(FOnProgress) then
    FOnProgress(Sender, Stage, PercentDone, RedrawNow, R, Msg);
end;

function TDynamicimage.GetCanvas: TCanvas;
var
  Bitmap: TBitmap;
begin
  if Picture.Graphic = nil then
  begin
    Bitmap := TBitmap.Create;
    try
      Bitmap.Width := Width;
      Bitmap.Height := Height;
      Picture.Graphic := Bitmap;
    finally
      Bitmap.Free;
    end;
  end;
  if Picture.Graphic is TBitmap then
    Result := TBitmap(Picture.Graphic).Canvas
  else
    raise EInvalidOperation.Create(SImageCanvasNeedsBitmap);
end;

procedure TDynamicimage.SetCenter(Value: Boolean);
begin
  if FCenter <> Value then
  begin
    FCenter := Value;
    PictureChanged(Self);
  end;
end;

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

procedure TDynamicimage.SetStretch(Value: Boolean);
begin
  if Value <> FStretch then
  begin
    FStretch := Value;
    PictureChanged(Self);
  end;
end;

procedure TDynamicimage.SetTransparent(Value: Boolean);
begin
  if Value <> FTransparent then
  begin
	FTransparent := Value;
	PictureChanged(Self);
  end;
end;

procedure TDynamicimage.SetProportional(Value: Boolean);
begin
  if FProportional <> Value then
  begin
	FProportional := Value;
	PictureChanged(Self);
  end;
end;

procedure TDynamicimage.PictureChanged(Sender: TObject);
var
  G: TGraphic;
begin
  if AutoSize and (Picture.Width > 0) and (Picture.Height > 0) then
    SetBounds(Left, Top, Picture.Width, Picture.Height);
  G := Picture.Graphic;
  if G <> nil then
  begin
    if not ((G is TMetaFile) or (G is TIcon)) then
      G.Transparent := FTransparent;
    if (not G.Transparent) and Stretch and not Proportional then
      ControlStyle := ControlStyle + [csOpaque]
    else  // picture might not cover entire clientrect
      ControlStyle := ControlStyle - [csOpaque];
    if DoPaletteChange and FDrawing then Update;
  end
  else
    ControlStyle := ControlStyle - [csOpaque];

  if not FDrawing then
    Invalidate;
end;

function TDynamicimage.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
begin
  Result := True;
  if not (csDesigning in ComponentState) or (Picture.Width > 0) and
    (Picture.Height > 0) then
  begin
    if Align in [alNone, alLeft, alRight] then
      NewWidth := Picture.Width;
    if Align in [alNone, alTop, alBottom] then
      NewHeight := Picture.Height;
  end;
end;

procedure TDynamicimage.SetFrameCount(const Value: integer);
begin
  FFrameCount := Value;
  if FPicture.Graphic<>nil then
  begin
    if value>0 then
      CutSinglePic(FDynamicPicture,0);
  end;
end;

procedure TDynamicimage.SetDynamicPicture(const Value: TPicture);
var
  rect:Trect;
  AHeight,AWidth:integer;
  BitMap:TBitMap;
begin
  if value.Graphic<>nil then
  begin
    if (value.Graphic is TBitMap) or (value.Graphic is TJpegImage) then
    begin
      BitMap:=TBitMap.Create;
      if value.Graphic is TJpegImage then
      begin
        BitMap.Assign(value.Graphic);
        FDynamicPicture.Assign(BitMap);
        BitMap.Assign(nil);
      end
      else
        FDynamicPicture.Assign(Value);
      BitMap.Free;
      CutSinglePic(value,0);
    end
    else
      showmessage('Only support Bitmap and Jpg.');
  end
  else
  begin
    FPicture.Assign(nil);
    FDynamicPicture.Assign(nil);
  end;
end;

procedure TDynamicimage.CutSinglePic(Pic:TPicture;idx:integer);
var
  rect,rect1:Trect;
  AHeight,AWidth:integer;
  BitMap:TBitMap;
begin
  BitMap:=TBitMap.Create;
  AHeight:=Pic.Graphic.Height;
  if FFrameCount>0 then
    AWidth:=Pic.Graphic.Width div FFrameCount
  else
    AWidth:=Pic.Graphic.Width;

  rect.Left:=0;
  rect.Top:=0;
  rect.Right:=AWidth;
  rect.Bottom:=AHeight;

  rect1.Left:=AWidth*idx;
  rect1.Top:=0;
  rect1.Right:=AWidth*(idx+1);
  rect1.Bottom:=AHeight;
  FPicture.Assign(nil);

  BitMap.Width:=AWidth;
  BitMap.Height:=AHeight;
  BitMap.Canvas.CopyRect(rect,FDynamicPicture.Bitmap.Canvas,rect1);
  FPicture.Assign(BitMap);
  BitMap.Free;
end;

procedure TDynamicimage.SetActive(const Value: Boolean);
begin
  FActive := Value;

  if csDesigning in ComponentState then
    exit;

  if FActive then
  begin
    if DynamicPicture.Graphic<>nil then
    begin
      DynamicTimer:=TDynamicimageThread.Create(true);
      DynamicTimer.Createor:=self;
      DynamicTimer.Resume;
    end;
  end
  else
  begin
    if assigned(DynamicTimer) then
    begin
      DynamicTimer.Terminate;
      FHalt:=false;
      CurIdx:=0;
      CutSinglePic(DynamicPicture,CurIdx);
    end;
  end;
end;

procedure TDynamicimage.play;
begin
  FHalt:=false;
  CutSinglePic(DynamicPicture,CurIdx);
  if CurIdx=0 then
    FHalt:=true;
  inc(CurIdx);
  if CurIdx>FFrameCount-1 then
  begin
    CurIdx:=0;
    CutSinglePic(DynamicPicture,CurIdx);
  end;
end;

{ TDynamicimageThread }

procedure TDynamicimageThread.AfterConstruction;
begin
  inherited;
end;

constructor TDynamicimageThread.Create(CreateSuspended: Boolean);
begin
  inherited Create(CreateSuspended);
  FreeOnTerminate:=true;
end;

procedure TDynamicimageThread.Execute;
begin
  repeat
    Synchronize(Createor.play);
    if Createor.Halt then
      sleep(Createor.StickTime);
  until Terminated or (SleepEx(Createor.interval,False)<>0);
end;

procedure TDynamicimage.SetHalt(const Value: Boolean);
begin
  FHalt := Value;
end;

procedure TDynamicimage.Setinterval(const Value: integer);
begin
  Finterval := Value;
end;

procedure TDynamicimage.SetStickTime(const Value: integer);
begin
  FStickTime := Value;
end;

end.