picshow.pas

免费控件PicShow的最新版本

{ TAnimateThread }

type
  TAnimateThread = class(TThread)
  private
    fExecuted: Boolean;
    PicShow: TCustomPicShow;
  protected
    constructor Create(APicShow: TCustomPicShow);
    procedure Execute; override;
    property Executed: Boolean read fExecuted;
  end;

constructor TAnimateThread.Create(APicShow: TCustomPicShow);
begin
  inherited Create(True);
  PicShow := APicShow;
  Priority := PicShow.ThreadPriority;
  Resume;
end;

procedure TAnimateThread.Execute;
var
  ProgressStep: Integer;
  ElapsedTime: Integer;
  Delay: Integer;
begin
  fExecuted := True;
  try
    ProgressStep := PicShow.Step;
    while not Terminated do
    begin
      if not PicShow.UpdateProgress(ProgressStep, ElapsedTime) then
        Terminate
      else if not Terminated then
      begin
        Delay := PicShow.Delay - ElapsedTime;
        if Delay >= 0 then
        begin
          Sleep(Delay);
          ProgressStep := PicShow.Step;
        end
        else if PicShow.ExactTiming then
          ProgressStep := MulDiv(PicShow.Step, PicShow.Delay - Delay, PicShow.Delay);
      end;
    end;
  finally
    PostMessage(PicShow.Handle, PS_THREADTERMINATED, 0, 0);
  end;
end;

{ TCustomPicShow }

constructor TCustomPicShow.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque];
  InitializeCriticalSection(CS);
  Display := TBitmap.Create;
  fPicture := TPicture.Create;
  fPicture.OnChange := PictureChange;
  fBgPicture := TPicture.Create;
  fBgPicture.OnChange := BgPictureChange;
  fBgMode := bmTiled;
  fStep := 4;
  fDelay := 40;
  fStyle := 51;
  fThreaded := True;
  fThreadPriority := tpNormal;
  fOverDraw := True;
  fFrameColor := clActiveBorder;
  Width := 100;
  Height := 100;
end;

destructor TCustomPicShow.Destroy;
begin
  Stop;
  Display.Free;
  Picture.Free;
  BgPicture.Free;
  DeleteCriticalSection(CS);
  inherited Destroy;
end;

procedure TCustomPicShow.SetPicture(Value: TPicture);
begin
  Picture.Assign(Value);
end;

procedure TCustomPicShow.SetBgPicture(Value: TPicture);
begin
  BgPicture.Assign(Value);
end;

procedure TCustomPicShow.SetBgMode(Value: TBackgroundMode);
begin
  if BgMode <> Value then
  begin
    fBgMode := Value;
    if BgPicture.Graphic <> nil then
    begin
      if DynamicOldPic and Assigned(OldPic) then
        UpdateOldPic;
      Invalidate;
    end;
  end;
end;

procedure TCustomPicShow.SetFrameColor(Value: TColor);
begin
  if FrameColor <> Value then
  begin
    fFrameColor := Value;
    if (FrameWidth <> 0) and not Display.Empty then
      Invalidate;
  end;
end;

procedure TCustomPicShow.SetFrameWidth(Value: TBorderWidth);
begin
  if FrameWidth <> Value then
  begin
    fFrameWidth := Value;
    if AutoSize then
      AdjustSize;
    if not Display.Empty then
    begin
      UpdateDisplayRect;
      Invalidate;
    end;
  end;
end;

procedure TCustomPicShow.SetCenter(Value: Boolean);
begin
  if Center <> Value then
  begin
    fCenter := Value;
    UpdateDisplayRect;
    if not Display.Empty then
      Invalidate;
  end;
end;

procedure TCustomPicShow.SetStretch(Value: Boolean);
begin
  if Stretch <> Value then
  begin
    fStretch := Value;
    UpdateDisplayRect;
    if not Display.Empty then
      Invalidate;
  end;
end;

procedure TCustomPicShow.SetProportional(Value: Boolean);
begin
  if Proportional <> Value then
  begin
    fProportional := Value;
    UpdateDisplayRect;
    if not Display.Empty then
      Invalidate;
  end;
end;

procedure TCustomPicShow.SetStep(Value: Word);
begin
  if Value = 0 then
    fStep := 1;
  if Value > 100 then
    fStep := 100
  else
    fStep := Value;
end;

procedure TCustomPicShow.SetStyle(Value: TShowStyle);
begin
  if (Style <> Value) and (Value in [Low(TShowStyle)..High(TShowStyle)]) then
  begin
    EnterCriticalSection(CS);
    try
      fStyle := Value;
    finally
      LeaveCriticalSection(CS);
    end;
    if Busy and Manual and not Stopping then
    begin
      UpdateDisplay;
      InvalidateRect(Handle, @DisplayRect, False);
    end;
  end;
end;

procedure TCustomPicShow.SetStyleName(const Value: String);
var
  TheStyle: TShowStyle;
begin
  if AnsiCompareText(CustomEffectName, Value) = 0 then
    Style := 0
  else
    for TheStyle := Low(PSEffects) to High(PSEffects) do
      if AnsiCompareText(PSEffects[TheStyle].Name, Value) = 0 then
      begin
        Style := TheStyle;
        Break;
      end;
end;

function TCustomPicShow.GetStyleName: String;
begin
  if Style = 0 then
    Result := CustomEffectName
  else
    Result := PSEffects[Style].Name;
end;

function TCustomPicShow.GetEmpty: Boolean;
begin
  Result := (Picture.Graphic = nil) or Picture.Graphic.Empty;
end;

procedure TCustomPicShow.PictureChange(Sender: TObject);
begin
  if not (csDestroying in ComponentState) then
  begin
    if (Picture.Graphic <> nil) and AutoSize then
      AdjustSize;
    DoChange;
  end;
end;

procedure TCustomPicShow.BgPictureChange(Sender: TObject);
begin
  if BgMode <> bmNone then
  begin
    if DynamicOldPic and Assigned(OldPic) then
      UpdateOldPic;
    Invalidate;
  end;
end;

procedure TCustomPicShow.SetProgress(Value: TPercent);
begin
  if Value < 0 then
    Value := 0
  else if Value > 100 then
    Value := 100;
  if Busy and (Progress <> Value) then
  begin
    EnterCriticalSection(CS);
    try
      fProgress := Value;
      UpdateDisplay;
    finally
      LeaveCriticalSection(CS);
    end;
    RedrawWindow(WindowHandle, @DisplayRect, 0, RDW_INVALIDATE or RDW_UPDATENOW);
    DoProgress;
  end;
end;

procedure TCustomPicShow.SetManual(Value: Boolean);
begin
  if Manual <> Value then
  begin
    fManual := Value;
    WaitForThread;
    if not Busy then
      if Reverse then
        fProgress := 100
      else
        fProgress := 0
    else if not Manual then
      Animate;
  end;
end;

{$IFNDEF DELPHI4_UP}
procedure TCustomPicShow.SetAutoSize(Value: Boolean);
begin
  if AutoSize <> Value then
  begin
    fAutoSize := Value;
    if AutoSize then AdjustSize;
  end;
end;
{$ENDIF}

function TCustomPicShow.GetStyleNames(Names: TStrings): Integer;
var
  I: Integer;
begin
  Result := 0;
  Names.BeginUpdate;
  try
    for I := Low(PSEffects) to High(PSEffects) do
    begin
      Names.Add(PSEffects[I].Name);
      Inc(Result);
    end;
  finally
    Names.EndUpdate;
  end;
end;

function TCustomPicShow.WaitForThread: Boolean;
var
  Msg: TMsg;
begin
  Result := False;
  if Thread <> nil then
  begin
    Thread.Terminate;
    Thread.WaitFor;
    if TAnimateThread(Thread).Executed then
      repeat
        if PeekMessage(Msg, Handle, PS_THREADTERMINATED, PS_THREADTERMINATED, PM_REMOVE) then
          DispatchMessage(Msg);
      until Thread = nil
    else
    begin
      { In a rare situation, it's possible the Thread.Therminate to be        }
      { called before the Delphi ThreadProc to be executed. In this case,     }
      { the AnimateThread cannot post the message to the PicShow's Window.    }
      { Therefore, we have to detect this case and send the message directly. }
      { Unfortunately, the OnTerminate event of TThread class does not work   }
      { correctly on all versions of Delphi and we cannot safely use it for   }
      { our purpose.                                                          }
      SendMessage(Handle, PS_THREADTERMINATED, 0, 0);
    end;
    Result := True;
  end;
end;

procedure TCustomPicShow.ThreadTerminated(var Msg: TMessage);
begin
  FreeAndNil(Thread);
  if Stopping or not Manual then
    Unprepare;
end;

procedure TCustomPicShow.WMEraseBkgnd(var Msg: TWMEraseBkgnd);
begin
  Msg.Result := 1;
end;

procedure TCustomPicShow.WMPaint(var Msg: TWMPaint);
var
  DC: HDC;
  PS: TPaintStruct;
  DrawImageOnly: Boolean;
begin
  if not Drawing then
  begin
    Drawing := True;
    try
      DC := Msg.DC;
      if DC = 0 then
        DC := BeginPaint(Handle, PS)
      else
        GetClipBox(DC, PS.rcPaint);
      try
        with PS.rcPaint do
        begin
          DrawImageOnly := not Display.Empty
            and (Left >= DisplayRect.Left) and (Top >= DisplayRect.Top)
            and (Right <= DisplayRect.Right) and (Bottom <= DisplayRect.Bottom);
        end;
        if DrawImageOnly then
        begin
          SetStretchBltMode(DC, COLORONCOLOR);
          Display.Canvas.Lock;
          try
            with DisplayRect do
              StretchBlt(DC, Left, Top, Right - Left, Bottom - Top,
                Display.Canvas.Handle, 0, 0, PicRect.Right, PicRect.Bottom, SRCCOPY);
          finally
            Display.Canvas.Unlock;
          end;
        end
        else
          PaintWindow(DC);
      finally
        if Msg.DC = 0 then
          EndPaint(Handle, PS);
      end;
      Msg.Result := 0;
    finally
      Drawing := False;
    end;
  end
  else
    Msg.Result := 1;
end;

procedure TCustomPicShow.CMMouseEnter(var Msg: TMessage);
begin
  inherited;
  if Assigned(fOnMouseEnter) then fOnMouseEnter(Self);
end;

procedure TCustomPicShow.CMMouseLeave(var Msg: TMessage);
begin
  inherited;
  if Assigned (fOnMouseLeave) then fOnMouseLeave(Self);
end;

procedure TCustomPicShow.WMSize(var Msg: TWMSize);
begin
  inherited;
  UpdateDisplayRect;
  if not Display.Empty then
    Invalidate;
end;

procedure TCustomPicShow.WMDestroy(var Msg: TWMDestroy);
begin
  Stop;
  inherited;
end;

procedure TCustomPicShow.DrawBackground(Canvas: TCanvas; const Rect: TRect);
var
  G: TGraphic;
  FillStyle: TBackgroundMode;
  SavedDC: Integer;
  R: TRect;
begin
  if RectVisible(Canvas.Handle, Rect) then
  begin
    BgPicture.OnChange := nil;
    try
      G := BgPicture.Graphic;
      if Assigned(G) and not G.Empty then
        FillStyle := BgMode
      else
        FillStyle := bmNone;
      case FillStyle of
        bmTiled:
          DrawTile(Canvas, Rect, G);
        bmStretched:
          Canvas.StretchDraw(Rect, G);
        bmCentered:
        begin
          R.Left := ((Rect.Right - Rect.Left) - G.Width) div 2;
          R.Top := ((Rect.Bottom - Rect.Top) - G.Height) div 2;
          R.Right := R.Left + G.Width;
          R.Bottom := R.Top + G.Height;
          Canvas.StretchDraw(R, G);
          SavedDC := SaveDC(Canvas.Handle);
          try
            ExcludeClipRect(Canvas.Handle, R.Left, R.Top, R.Right, R.Bottom);
            Canvas.Brush.Color := Color;
            Canvas.FillRect(Rect);
          finally
            RestoreDC(Canvas.Handle, SavedDC);
          end;
        end;
      else
        Canvas.Brush.Color := Color;
        Canvas.FillRect(Rect);
      end;
    finally
      BgPicture.OnChange := BgPictureChange;
    end;
  end;
end;

procedure TCustomPicShow.Draw(Canvas: TCanvas);
var
  SavedDC: HDC;
  FrameRect: TRect;
begin
  if not Display.Empty then
  begin
    if RectVisible(Canvas.Handle, DisplayRect) then
    begin
      Display.Canvas.Lock;
      try
        SetStretchBltMode(Canvas.Handle, COLORONCOLOR);
        Canvas.CopyRect(DisplayRect, Display.Canvas, PicRect);
      finally
        Display.Canvas.Unlock;
      end;
    end;
    FrameRect := DisplayRect;
    if FrameWidth <> 0 then
    begin
      InflateRect(FrameRect, FrameWidth, FrameWidth);
      if RectVisible(Canvas.Handle, FrameRect) then
      begin
        Canvas.Pen.Mode := pmCopy;
        Canvas.Pen.Color := FrameColor;
        Canvas.Pen.Width := FrameWidth;
        Canvas.Pen.Style := psInsideFrame;
        Canvas.Brush.Style := bsClear;
        with FrameRect do
          Canvas.Rectangle(Left, Top, Right, Bottom);
      end;
    end;
    SavedDC := SaveDC(Canvas.Handle);
    try
      with FrameRect do
        ExcludeClipRect(Canvas.Handle, Left, Top, Right, Bottom);
      DrawBackground(Canvas, ClientRect);
    finally
      RestoreDC(Canvas.Handle, SavedDC);
    end;
  end
  else
    DrawBackground(Canvas, ClientRect);
end;

procedure TCustomPicShow.Paint;
begin
  Draw(Canvas);
end;

{$IFDEF DELPHI4_UP}
function TCustomPicShow.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
begin
  Result := True;
  if (Picture.Graphic <> nil) and (Align <> alClient) then
  begin
    if not (Align in [alTop, alBottom]) then
      NewWidth := Picture.Width + 2 * FrameWidth + (Width - ClientWidth);
    if not (Align in [alLeft, alRight]) then
      NewHeight := Picture.Height + 2 * FrameWidth + (Height - ClientHeight);
  end;
end;
{$ENDIF}

{$IFNDEF DELPHI4_UP}
procedure TCustomPicShow.AdjustSize;
begin
  if (Picture.Graphic <> nil) and (Align <> alClient) then
  begin
    if not (Align in [alTop, alBottom]) then
      ClientWidth := Picture.Width + 2 * FrameWidth;
    if not (Align in [alLeft, alRight]) then
      ClientHeight := Picture.Height + 2 * FrameWidth;;
  end;
end;
{$ENDIF}