picshow.pas

提供 122 种不同图形显示特效的可视构件

      else
        Result := Rgn;
      Inc(X1, 5);
    end;
  end;
end;

function CreateTriangleRgn(x1, y1, x2, y2, x3, y3: Integer): HRgn;
var
  ptArray : array[1..4] of TPoint;
begin
  ptArray[1].x := x1;
  ptArray[1].y := y1;
  ptArray[2].x := x2;
  ptArray[2].y := y2;
  ptArray[3].x := x3;
  ptArray[3].y := y3;
  ptArray[4].x := x1;
  ptArray[4].y := y1;
  Result := CreatePolygonRgn(ptArray, 4, WINDING);
end;

function ScaleImageToRect(IR, R: TRect): TRect;
var
  iW, iH: Integer;
  rW, rH: Integer;
begin
  iW := IR.Right - IR.Left;
  iH := IR.Bottom - IR.Top;
  rW := R.Right - R.Left;
  rH := R.Bottom - R.Top;
  if (rW / iW) < (rH / iH) then
  begin
    iH := MulDiv(iH, rW, iW);
    iW := MulDiv(iW, rW, iW);
  end
  else
  begin
    iW := MulDiv(iW, rH, iH);
    iH := MulDiv(iH, rH, iH);
  end;
  SetRect(Result, 0, 0, iW, iH);
  OffsetRect(Result, R.Left + (rW - iW) div 2, R.Top + (rH - iH) div 2);
end;

procedure DrawTiledImage(Canvas: TCanvas; Rect: TRect; G: TGraphic);
var
  R, Rows, C, Cols: Integer;
begin
  if (G <> nil) and (not G.Empty) then
  begin
    Rows := ((Rect.Bottom - Rect.Top) div G.Height) + 1;
    Cols := ((Rect.Right - Rect.Left) div G.Width) + 1;
    for R := 1 to Rows do
      for C := 1 to Cols do
        Canvas.Draw(Rect.Left + (C-1) * G.Width, Rect.Top + (R-1) * G.Height, G)
  end;
end;

procedure MirrorCopyRect(Canvas: TCanvas; dstRect: TRect;
  Bitmap: TBitmap; srcRect: TRect; Horz, Vert: Boolean);
var
  T: Integer;
begin
  IntersectRect(srcRect, srcRect, Rect(0, 0, Bitmap.Width, Bitmap.Height));
  if Horz then
  begin
    T := dstRect.Left;
    dstRect.Left := dstRect.Right+1;
    dstRect.Right := T-1;
  end;
  if Vert then
  begin
    T := dstRect.Top;
    dstRect.Top := dstRect.Bottom+1;
    dstRect.Bottom := T-1;
  end;
  StretchBlt(Canvas.Handle, dstRect.Left, dstRect.Top,
     dstRect.Right - dstRect.Left, dstRect.Bottom - dstRect.Top,
     Bitmap.Canvas.Handle, srcRect.Left, srcRect.Top,
     srcRect.Right - srcRect.Left, srcRect.Bottom - srcRect.Top, SRCCOPY);
end;

// Both bitmaps must be equal size and 24 bit format.
procedure MergeTransparent(dstBitmap, srcBitmap: TBitmap; Transparency: TPercent);
var
  dstRow, srcRow: PRGBTripleArray;
  x, y: Integer;
begin
  for y := 0 to srcBitmap.Height-1 do
  begin
    srcRow := srcBitmap.ScanLine[y];
    dstRow := dstBitmap.ScanLine[y];
    for x := 0 to srcBitmap.Width-1 do
    begin
      dstRow[x].rgbtRed := ((100-Transparency) * dstRow[X].rgbtRed) div 100 +
                            (Transparency * srcRow[X].rgbtRed) div 100;
      dstRow[x].rgbtGreen := ((100-Transparency) * dstRow[X].rgbtGreen) div 100 +
                            (Transparency * srcRow[X].rgbtGreen) div 100;
      dstRow[x].rgbtBlue := ((100-Transparency) * dstRow[X].rgbtBlue) div 100 +
                            (Transparency * srcRow[X].rgbtBlue) div 100;
    end;
  end;
end;

// Both bitmaps must be equal size and 24 bit format.
procedure MergeRotate(dstBitmap, srcBitmap: TBitmap; xOrg, yOrg: Integer;
  Angle: Double);
var
  cosTheta: Extended;
  sinTheta: Extended;
  xSrc, ySrc: Integer;
  xDst, yDst: Integer;
  xPrime, yPrime: Integer;
  srcRow, dstRow: PRGBTripleArray;
begin
  SinCos(Angle, sinTheta, cosTheta);
  for ySrc := 0 to srcBitmap.Height-1 do
  begin
    dstRow := dstBitmap.ScanLine[ySrc];
    yPrime := ySrc - yOrg;
    for xSrc := 0 to srcBitmap.Width-1 do
    begin
      xPrime := xSrc - xOrg;
      xDst := xOrg + Round(xPrime * CosTheta - yPrime * sinTheta);
      yDst := yOrg + Round(xPrime * sinTheta + yPrime * cosTheta);
      if (xDst >= 0) and (xDst < dstBitmap.Width) and
         (yDst >= 0) and (yDst < dstBitmap.Height)
      then
      begin
        srcRow := srcBitmap.Scanline[yDst];
        dstRow[xSrc] := srcRow[xDst]
      end;
    end;
  end;
end;

{ TAnimateThread }

constructor TAnimateThread.Create(APicShow: TCustomPicShow);
begin
  PicShow := APicShow;
  Priority := PicShow.ThreadPriority;
  OnTerminate := PicShow.AnimationComplete;
  FreeOnTerminate := True;
  inherited Create(False);
end;

procedure TAnimateThread.Execute;
var
  Elapsed: DWord;
begin
  while not (Terminated or PicShow.Manual or PicShow.Stopping) do
  begin
    Elapsed := GetTickCount;
    Synchronize(Update);
    Elapsed := GetTickCount - Elapsed;
    if (PicShow.Reverse and (PicShow.Progress = Low(TPercent))) or
       (not PicShow.Reverse and (PicShow.Progress = High(TPercent))) then
      Terminate
    else if PicShow.Delay > Elapsed then
      Sleep(PicShow.Delay - Elapsed);
  end;
end;

procedure TAnimateThread.Update;
begin
  if PicShow.Reverse then
    if PicShow.Progress >= PicShow.Step then
      PicShow.Progress := PicShow.Progress - PicShow.Step
    else
      PicShow.Progress := Low(TPercent)
  else
    PicShow.Progress := PicShow.Progress + PicShow.Step;
end;

{ TCustomPicShow }

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

destructor TCustomPicShow.Destroy;
begin
  if Assigned(Thread) then
  begin
    Thread.Terminate;
    if Thread.Suspended then
      Thread.Resume;
    {$IFDEF PS_D4orHigher}
    Thread.WaitFor;
    {$ENDIF}
  end;
  Media.Free;
  fPicture.Free;
  OffScreen.Free;
  inherited Destroy;
end;

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

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

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

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

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

procedure TCustomPicShow.SetStretchFine(Value: Boolean);
begin
  if fStretchFine <> 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 Value := 1;
  if Value > High(TPercent) then Value := High(TPercent);
  fStep := Value;
end;

function TCustomPicShow.GetEmpty: Boolean;
begin
  Result := not Assigned(fPicture.Graphic) or fPicture.Graphic.Empty;
end;

procedure TCustomPicShow.PictureChange(Sender: TObject);
begin
  if not (csDestroying in ComponentState) then
  begin
    if Assigned(fPicture.Graphic) and fAutoSize then
      AdjustClientSize;
    if Assigned(fOnChange) then
      fOnChange(Self);
  end;
end;

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

procedure TCustomPicShow.SetProgress(Value: TPercent);
begin
  if Value < Low(TPercent) then Value := Low(TPercent);
  if Value > High(TPercent) then Value := High(TPercent);
  if fBusy and (fProgress <> Value) then
  begin
    if (fProgress > Value) and not Drawing then
      InvalidateArea(Rect(0, 0, Media.Width, Media.Height));
    fProgress := Value;
    UpdateDisplay;
    if Assigned(fOnProgress) and not (csDestroying in ComponentState) then
      fOnProgress(Self);
  end;
end;

procedure TCustomPicShow.SetManual(Value: Boolean);
begin
  if fManual <> Value then
  begin
    fManual := Value;
    if not fBusy then
      if fReverse then
        fProgress := High(TPercent)
      else
        fProgress := Low(TPercent)
    else if not fManual then
      Animate;
  end;
end;

procedure TCustomPicShow.AnimationComplete(Sender: TObject);
begin
  Thread := nil;
  if Stopping or not fManual then
  begin
    fBusy := False;
    if Assigned(Pic) then Pic.Free;
    if Assigned(OldPic) then OldPic.Free;
    Pic := nil;
    OldPic := nil;
    if Assigned(FOnComplete) and not (csDestroying in ComponentState) and
      not Stopping then FOnComplete(Self);
  end;
end;

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

procedure TCustomPicShow.WMPaint(var Msg: TWMPaint);
begin
  if not Drawing and (GetCurrentThreadID = MainThreadID) then
  begin
    Drawing := True;
    try
      inherited;
    finally
      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.SetAutoSize(Value: Boolean);
begin
  if fAutoSize <> Value then
  begin
    fAutoSize := Value;
    if fAutoSize then AdjustClientSize;
  end;
end;

procedure TCustomPicShow.AdjustClientSize;
begin
  if Assigned(fPicture.Graphic) and (Align = alNone) then
  begin
    ClientWidth := fPicture.Width;
    ClientHeight := fPicture.Height;
  end;
end;

procedure TCustomPicShow.WMSize(var Msg: TWMSize);
begin
  inherited;
  if Assigned(fPicture.Graphic) then
  begin
    CalculatePicRect;
    if not (Media.Empty or Drawing) then Invalidate;
  end;
end;

procedure TCustomPicShow.Paint;
var
  R: TRect;
  C: TCanvas;
begin
  OffScreen.Width := ClientWidth;
  OffScreen.Height := ClientHeight;
  C := OffScreen.Canvas;
  C.Lock;
  try
    R := ClientRect;
    C.Brush.Color := Color;
    C.FillRect(R);
    if Assigned(fBgPicture.Graphic) then
      case fBgMode of
        bmTiled: DrawTiledImage(C, R, fBgPicture.Graphic);
        bmStretched: C.StretchDraw(R, fBgPicture.Graphic);
        bmCentered: C.Draw((R.Right - R.Left - fBgPicture.Width) div 2,
                           (R.Bottom - R.Top - fBgPicture.Height) div 2,
                            fBgPicture.Graphic);
      end;
    if not Media.Empty then
    begin
      if fStretch then
        if fStretchFine then
          C.StretchDraw(ScaleImageToRect(PicRect, R), Media)
        else
          C.StretchDraw(R, Media)
      else
        C.Draw(PicRect.Left, PicRect.Top, Media);
    end;
    if csDesigning in ComponentState then
    begin
      C.Pen.Style := psDash;
      C.Brush.Style := bsClear;
      C.Rectangle(0, 0, Width, Height);
    end;
  finally
    C.Unlock;
  end;
  Canvas.Lock;
  try
    Canvas.Draw(0, 0, OffScreen);
  finally
    Canvas.Unlock;
  end;
end;

procedure TCustomPicShow.CalculatePicRect;
begin
  if not Media.Empty then
  begin
    SetRect(PicRect, 0, 0, Media.Width, Media.Height);
    if fCenter 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 fStretch then
  begin
    if fStretchFine then
      R := ScaleImageToRect(PicRect, ClientRect)