picshow.pas

TPicShow是一套图形平滑特效控制组件

      if not Terminated then
      begin
        Delay := PicShow.Delay - Integer(GetTickCount - StartTime);
        if Delay >= 0 then Sleep(Delay);
      end;
    end;
  finally
    PostMessage(PicShow.Handle, PS_THREADTERMINATED, 0, 0);
  end;
end;

procedure TAnimateThread.UpdateProgress;
begin
  with PicShow do
  begin
    WaitForSingleObject(UpdateEvent, INFINITE);
    if not Terminated then
    begin
      ResetEvent(UpdateEvent);
      if Reverse then
        if Progress > Step then
          Progress := Progress - Step
        else
          Progress := 0
      else
        if Progress < 100 - Step then
          Progress := Progress + Step
        else
          Progress := 100;
      if (Reverse and (Progress = 0)) or (not Reverse and (Progress = 100)) then
        Terminate;
    end;
  end;
end;

{ TCustomPicShow }

constructor TCustomPicShow.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque];
  InitializeCriticalSection(CS);
  UpdateEvent := CreateEvent(nil, True, True, nil);
  Media := TBitmap.Create;
  fStep := 4;
  fDelay := 40;
  fStyle := 51;
  fReverse := False;
  fCenter := False;
  fStretch := False;
  fStretchFine := False;
  fAutoSize := True;
  fThreaded := True;
  fThreadPriority := tpNormal;
  fManual := False;
  fOverDraw := True;
  fProgress := 0;
  fBusy := False;
  fPicture := TPicture.Create;
  fPicture.OnChange := PictureChange;
  fBgPicture := TPicture.Create;
  fBgPicture.OnChange := BgPictureChange;
  fBgMode := bmTiled;
  NeverDrawn := True;
  OffScreen := TBitmap.Create;
  Width := 100;
  Height := 100;
  Thread := nil;
  Stopping := False;
  Drawing := False;
end;

destructor TCustomPicShow.Destroy;
begin
  Stop;
  Media.Free;
  Picture.Free;
  BgPicture.Free;
  OffScreen.Free;
  CloseHandle(UpdateEvent);
  DeleteCriticalSection(CS);
  inherited Destroy;
end;

procedure TCustomPicShow.SetPicture(Value: TPicture);
begin
  if Assigned(Value) then
    Picture.Assign(Value)
  else
    Picture.Graphic := nil;
end;

procedure TCustomPicShow.SetBgPicture(Value: TPicture);
begin
  if Assigned(Value) then
    BgPicture.Assign(Value)
  else
    BgPicture.Graphic := nil;
end;

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

procedure TCustomPicShow.SetCenter(Value: Boolean);
begin
  if Center <> Value then
  begin
    fCenter := Value;
    if (Picture.Graphic <> nil) then
    begin
      CalculatePicRect;
      if not (Media.Empty or Drawing) then Invalidate;
    end;
  end;
end;

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

procedure TCustomPicShow.SetStretchFine(Value: Boolean);
begin
  if StretchFine <> Value then
  begin
    fStretchFine := Value;
    if not (Media.Empty or Drawing) 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
    if Busy then
    begin
      if (Value in Bmp32Styles) and not (Style in Bmp32Styles) then
      begin
        Pic.Canvas.Lock;
        try
          Pic.PixelFormat := pf32bit;
        finally
          Pic.Canvas.Unlock;
        end;
        Media.Canvas.Lock;
        try
          Media.PixelFormat := pf32bit;
        finally
          Media.Canvas.Unlock;
        end;
      end;
    end;
    fStyle := Value;
  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
      AdjustClientSize;
    DoChange;
  end;
end;

procedure TCustomPicShow.BgPictureChange(Sender: TObject);
begin
  if (BgMode <> bmNone) and not Drawing then Invalidate;
end;

// The prototype of GetUpdateRect in Windows.pas is not correct and does not
// let we pass nil for lpRect parameter.
function GetUpdateRectPS(hWnd: HWND; lpRect: PRect;
  bErase: BOOL): BOOL; stdcall; external user32 name 'GetUpdateRect';

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;
      UpdateMedia;
    finally
      LeaveCriticalSection(CS);
    end;
    if GetUpdateRectPS(WindowHandle, nil, False) then
      Update
    else
      SetEvent(UpdateEvent);
    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;

procedure TCustomPicShow.SetAutoSize_(Value: Boolean);
begin
  if AutoSize <> Value then
  begin
    fAutoSize := Value;
    if AutoSize then AdjustClientSize;
  end;
end;

function TCustomPicShow.WaitForThread: Boolean;
var
  Msg: TMsg;
begin
  Result := False;
  if Thread <> nil then
  begin
    Thread.Terminate;
    SetEvent(UpdateEvent);
    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.WMDestroy(var Msg: TMessage);
begin
  Stop;
  inherited;
end;

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

procedure TCustomPicShow.WMPaint(var Msg: TWMPaint);
begin
  if not Drawing then
  begin
    Drawing := True;
    try
      inherited;
    finally
      SetEvent(UpdateEvent);
      Drawing := False;
    end;
  end;
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;
  OffScreen.Width := ClientWidth;
  OffScreen.Height := ClientHeight;
  if Picture.Graphic <> nil then
  begin
    CalculatePicRect;
    if not (Media.Empty or Drawing) then Invalidate;
  end;
end;

procedure TCustomPicShow.PaintBackground(Canvas: TCanvas; const Rect: TRect);
begin
  Canvas.Brush.Color := Color;
  Canvas.FillRect(Rect);
  if BgPicture.Graphic <> nil then
  begin
    case BgMode of
      bmTiled: DrawTiledImage(Canvas, Rect, BgPicture.Graphic);
      bmStretched: Canvas.StretchDraw(Rect, BgPicture.Graphic);
      bmCentered: Canvas.Draw((Rect.Right - Rect.Left - BgPicture.Width) div 2,
                              (Rect.Bottom - Rect.Top - BgPicture.Height) div 2,
                               BgPicture.Graphic);
    end;
  end;
end;

procedure TCustomPicShow.Paint;
var
  R: TRect;
  C: TCanvas;
begin
  R := ClientRect;
  C := OffScreen.Canvas;
  C.Lock;
  try
    PaintBackground(C, R);
    Media.Canvas.Lock;
    try
      if not Media.Empty then
      begin
        if Stretch then
          if StretchFine then
            C.StretchDraw(ScaleImageToRect(PicRect, R), Media)
          else
            C.StretchDraw(R, Media)
        else
          C.Draw(PicRect.Left, PicRect.Top, Media);
        end;
    finally
      Media.Canvas.Unlock;
    end;
    if csDesigning in ComponentState then
    begin
      C.Pen.Style := psDash;
      C.Brush.Style := bsClear;
      C.Rectangle(0, 0, Width, Height);
    end;
    Canvas.Draw(0, 0, OffScreen);
  finally
    C.Unlock;
  end;
  NeverDrawn := False;
end;

procedure TCustomPicShow.AdjustClientSize;
begin
  if (Picture.Graphic <> nil) and (Align <> alClient) then
  begin
    if not (Align in [alTop, alBottom]) then
      ClientWidth := Picture.Width;
    if not (Align in [alLeft, alRight]) then
      ClientHeight := Picture.Height;
  end;
end;

procedure TCustomPicShow.CalculatePicRect;
begin
  if not Media.Empty then
  begin
    SetRect(PicRect, 0, 0, Media.Width, Media.Height);
    if Center then
      OffsetRect(PicRect, (ClientWidth - Media.Width) div 2,
                          (ClientHeight - Media.Height) div 2);
  end;
end;

procedure TCustomPicShow.InvalidateArea(Area: TRect);
var
  R: TRect;
begin
  if Stretch then
  begin
    if StretchFine then
      R := ScaleImageToRect(PicRect, ClientRect)
    else
      R := ClientRect;
    Area.Left := R.Left + MulDiv(Area.Left, R.Right - R.Left, PicRect.Right - PicRect.Left);
    Area.Right := R.Left + MulDiv(Area.Right, R.Right - R.Left, PicRect.Right - PicRect.Left);
    Area.Top := R.Top + MulDiv(Area.Top, R.Bottom - R.Top, PicRect.Bottom - PicRect.Top);
    Area.Bottom := R.Top + MulDiv(Area.Bottom, R.Bottom - R.Top, PicRect.Bottom - PicRect.Top);
  end
  else