Delphi控件源码

开发平台：
Delphi

VrSlideShow.pas：源码内容
							{*****************************************************}
{                                                     }
{     Varian Component Workshop                       }
{                                                     }
{     Varian Software NL (c) 1996-2000                }
{     All Rights Reserved                             }
{                                                     }
{*****************************************************}
unit VrSlideShow;
{$I VRLIB.INC}
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  VrTypes, VrClasses, VrControls, VrSysUtils, VrThreads, VrSystem;
type
  TVrTransitionEffect =
   (StretchFromLeft, StretchFromRight, StretchFromTop,
    StretchFromBottom, StretchFromTopLeft, StretchFromBottomRight,
    StretchFromXcenter, StretchFromYcenter, PushFromBottom, PushFromLeft,
    PushFromRight, PushFromTop, SlideFromLeft, SlideFromRight, SlideFromTop,
    SlideFromBottom, SlideFromTopLeft, SlideFromBottomRight,Zoom);
  TVrSlideShow = class(TVrGraphicImageControl)
  private
    FActive: Boolean;
    FBitmapList: TVrBitmapList;
    FBitmapListLink: TVrChangeLink;
    FImage1: TBitmap;
    FImage2: TBitmap;
    FImageIndex1: Integer;
    FImageIndex2: Integer;
    FNewImage: Boolean;
//  FImageOrg: TBitmap;
//  FImageNew: TBitmap;
    FCurrentStep: Integer;
    FSteps: Integer;
    FLoop: Boolean;
    FSlideCount: Integer;
    FTransition: TVrTransitionEffect;
    FAnimateInit: Boolean;
    FTimer: TVrTimer;
    FThreaded: Boolean;
    FOnNotify: TNotifyEvent;
    FOnNextSlide: TNotifyEvent;
    sglGrowX, sglGrowY: Double;
    function GetInterval: Integer;
    procedure SetActive(Value: Boolean);
    procedure SetInterval(Value: Integer);
    procedure SetSteps(Value: Integer);
//  procedure SetTransition(Value: TVrTransitionEffect);
    procedure SetThreaded(Value: Boolean);
    procedure SetImageIndex1(Value: Integer);
    procedure SetImageIndex2(Value: Integer);
    procedure SetBitmapList(Value: TVrBitmapList);
    procedure TimerEvent(Sender: TObject);
    procedure BitmapListChanged(Sender: TObject);
  protected
    procedure CalcViewParams;
    procedure Paint; override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure Step;
    procedure Stop;
    procedure Next;
    function GetBitmap(Index: Integer): TBitmap;
//  procedure ExchangeImages;
  public
    destructor Destroy; override;
    constructor Create(AOwner: TComponent);override;
  published
    property Threaded: Boolean read FThreaded write SetThreaded default True;
    property Interval: integer read GetInterval write SetInterval;
    property BitmapList: TVrBitmapList read FBitmapList write SetBitmapList;
    property ImageIndex1: Integer read FImageIndex1 write SetImageIndex1 default -1;
    property ImageIndex2: Integer read FImageIndex2 write SetImageIndex2 default -1;
//  property ImageOrg: TBitmap read FImageOrg write SetImageOrg;
//  property ImageNew: TBitmap read FImageNew write SetImageNew;
    property Steps: integer read FSteps write SetSteps default 10;
    property Transition: TVrTransitionEffect read FTransition write FTransition;
    property Loop: Boolean read FLoop write FLoop default True;
    property Active: Boolean read FActive write SetActive default false;
    property OnNotify: TNotifyEvent read FOnNotify Write FOnNotify;
    property OnNextSlide: TNotifyEvent read FOnNextSlide Write FOnNextSlide;
{$IFDEF VER110}
    property Anchors;
    property Constraints;
{$ENDIF}
    property Align;
    property DragCursor;
{$IFDEF VER110}
    property DragKind;
{$ENDIF}
    property DragMode;
    property Hint;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Visible;
    property OnClick;
{$IFDEF VER130}
    property OnContextPopup;
{$ENDIF}
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
{$IFDEF VER110}
    property OnEndDock;
{$ENDIF}
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
{$IFDEF VER110}
    property OnStartDock;
{$ENDIF}
    property OnStartDrag;
  end;
implementation
constructor TVrSlideShow.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque];
  Width := 110;
  Height := 110;
  FActive := false;
  FSteps := 10;
  FLoop := True;
  FNewImage := True;
  FImageIndex1 := -1;
  FImageIndex2 := -1;
  FSlideCount := 0;
  FBitmapListLink := TVrChangeLink.Create;
  FBitmapListLink.OnChange := BitmapListChanged;
  FThreaded := True;
  FTimer := TVrTimer.Create(self);
  FTimer.Enabled := False;
  FTimer.OnTimer := TimerEvent;
  FTimer.Interval := 100;
end;
destructor TVrSlideShow.Destroy;
begin
  FTimer.Free;
  FBitmapListLink.Free;
  inherited Destroy;
end;
procedure TVrSlideShow.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) then
    if AComponent = BitmapList then BitmapList := nil;
end;
function TVrSlideShow.GetBitmap(Index: Integer): TBitmap;
begin
  Result := nil;
  if Assigned(FBitmapList) then
    Result := FBitmapList.GetBitmap(Index);
end;
procedure TVrSlideShow.BitmapListChanged(Sender: TObject);
begin
  UpdateControlCanvas;
end;
procedure TVrSlideShow.CalcViewParams;
begin
  sglGrowX := Width / FSteps;
  sglGrowY := Height / FSteps;
  FCurrentStep := 0;
  FImage1 := GetBitmap(FImageIndex1);
  FImage2 := GetBitmap(FImageIndex2);
end;
procedure TVrSlideShow.Paint;
begin
  CalcViewParams;
  if FImage1 = nil then
    ClearBitmapCanvas;
  if (FImage1 <> nil) then
  begin
    BitmapCanvas.Brush.Style := bsSolid;
    BitmapCanvas.CopyRect(ClientRect, FImage1.Canvas,
      BitmapRect(FImage1));
  end;
  ShowDesignFrame(BitmapCanvas);
  inherited Paint;
end;
procedure TVrSlideShow.Stop;
begin
  if not Designing then
    Active := false;
end;
procedure TVrSlideShow.Next;
begin
  if FImageIndex1 < BitmapList.Bitmaps.Count - 1 then
    Inc(FImageIndex1) else FImageIndex1 := 0;
  if FImageIndex2 < BitmapList.Bitmaps.Count - 1 then
   Inc(FImageIndex2) else FImageIndex2 := 0;
  if Assigned(OnNextSlide) then
  try
    OnNextSlide(Self);
  except
    Application.HandleException(Self);
  end;
end;
procedure TVrSlideShow.Step;
var
  IntLeft, IntRight, IntTop, IntBottom: Integer;
begin
  if (FImage1 = nil) or (FImage2 = nil) then
  begin
    Active := false;
    raise EVrException.Create('Transition bitmap(s) not assigned.');
  end;
  IntRight := Width;
  IntTop := 0;
  IntBottom := Height;
  case FTransition of
   SlideFromLeft,
   SlideFromTopLeft,
   PushFromLeft: IntLeft := Trunc((sglGrowX * FCurrentStep) - Width);
   StretchFromBottomRight,
   StretchFromRight,
   SlideFromRight,
   SlideFromBottomRight,
   PushFromRight: IntLeft := Trunc(Width - (sglGrowX * FCurrentStep));
   Zoom,
   StretchFromXcenter: IntLeft := Trunc((Width - (sglGrowX * FCurrentStep)) / 2);
   else
     IntLeft:=0;
  end;
  case FTransition of
    SlideFromRight,
    SlideFromBottomRight,
    PushFromRight: IntRight := Trunc((Width * 2) - (sglGrowX * FCurrentStep));
    StretchFromLeft,
    StretchFromTopLeft,
    SlideFromLeft,
    SlideFromTopLeft,
    PushFromLeft: IntRight := Trunc(sglGrowX * FCurrentStep);
    Zoom,
    StretchFromXcenter: IntRight := IntLeft + Trunc(sglGrowX * FCurrentStep);
  end;
  case FTransition of
    SlideFromTop,
    SlideFromTopLeft,
    PushFromTop: IntTop := Trunc((sglGrowY * FCurrentStep) - Height);
    StretchFromBottom,
    StretchFromBottomRight,
    SlideFromBottom,
    SlideFromBottomRight,
    PushFromBottom: IntTop := Trunc(Height - (sglGrowY * FCurrentStep));
    Zoom,
    StretchFromYcenter: IntTop := Trunc((Height - (sglGrowY * FCurrentStep)) / 2);
  end;
  case FTransition of
    SlideFromBottom,
    SlideFromBottomRight,
    PushFromBottom: IntBottom := Trunc((Height * 2) - (sglGrowY * FCurrentStep));
    StretchFromTop,
    StretchFromTopLeft,
    SlideFromTop,
    SlideFromTopLeft,
    PushFromTop: IntBottom := Trunc(sglGrowY * FCurrentStep);
    Zoom,
    StretchFromYcenter: IntBottom := IntTop + Trunc(sglGrowY * FCurrentStep);
  end;
  BitmapCanvas.CopyRect(Rect(IntLeft, IntTop, IntRight, IntBottom),
    FImage2.Canvas, Rect(0, 0, FImage2.Width, FImage2.Height));
  case FTransition of
    PushFromBottom:
      BitmapCanvas.CopyRect(Rect(0, IntTop - Height, Width, IntTop),
        FImage1.Canvas, BitmapRect(FImage1));
    PushFromLeft:
      BitmapCanvas.CopyRect(Rect(IntRight, 0, IntRight + Width, Height),
        FImage1.Canvas, BitmapRect(FImage1));
    PushFromRight:
      BitmapCanvas.CopyRect(Rect(IntLeft - Width, 0, IntLeft, Height),
        FImage1.Canvas, BitmapRect(FImage1));
    PushFromTop:
      BitmapCanvas.CopyRect(Rect(0, IntBottom, Width, IntBottom + Height),
        FImage1.Canvas, BitmapRect(FImage1));
  end;
  inherited Paint;
  Inc(FCurrentStep);
  if FCurrentStep > FSteps then
  begin
    FAnimateInit := True;
    if Loop then Next
    else
    begin
      if FSlideCount < BitmapList.Bitmaps.Count - 2 then
      begin
        Next;
        Inc(FSlideCount);
      end
      else
      begin
        Next;
        Active := false;
        if Assigned(OnNotify) then OnNotify(Self);
      end;
    end;
  end;
end;
procedure TVrSlideShow.TimerEvent(Sender: TObject);
begin
  if FAnimateInit then
  begin
    CalcViewParams;
    FAnimateInit := false;
  end else Step;
end;
procedure TVrSlideShow.SetActive(Value: Boolean);
begin
  if FActive <> Value then
  begin
    FActive := Value;
    FSlideCount := 0;
    if Designing then Exit;
    FTimer.Enabled := Value;
    if Value then FAnimateInit := True
    else UpdateControlCanvas;
  end;
end;
procedure TVrSlideShow.SetImageIndex1(Value: Integer);
begin
  if FImageIndex1 <> Value then
  begin
    FImageIndex1 := Value;
    if not Active then
      UpdateControlCanvas;
  end;
end;
procedure TVrSlideShow.SetImageIndex2(Value: Integer);
begin
  if FImageIndex2 <> Value then
  begin
    FImageIndex2 := Value;
    if not Active then
      UpdateControlCanvas;
  end;
end;
procedure TVrSlideShow.SetBitmapList(Value: TVrBitmapList);
begin
  if FBitmapList <> nil then
    FBitmapList.RemoveLink(FBitmapListLink);
  FBitmapList := Value;
  if FBitmapList <> nil then
    FBitmapList.InsertLink(FBitmapListLink);
  if not Loading then Stop;
  UpdateControlCanvas;
end;
procedure TVrSlideShow.SetSteps(Value: Integer);
begin
  if (Value > 0) and (Value < Height) and (Value < Width) then
  begin
    if not Loading then Stop;
    FSteps := Value
  end;
end;
function TVrSlideShow.GetInterval: Integer;
begin
  Result := FTimer.Interval;
end;
procedure TVrSlideShow.SetInterval(Value: Integer);
begin
  FTimer.Interval := Value;
end;
procedure TVrSlideShow.SetThreaded(Value: Boolean);
begin
  if FThreaded <> Value then
  begin
    FThreaded := Value;
    if Value then FTimer.TimerType := ttThread
    else FTimer.TimerType := ttSystem;
  end;
end;
end.

						