picshow.pas

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

  begin
    if Center then OffsetRect(Area, PicRect.Left, PicRect.Top);
    if Area.Left < PicRect.Left then Area.Left := PicRect.Left;
    if Area.Right > PicRect.Right then Area.Right := PicRect.Right;
    if Area.Top < PicRect.Top then Area.Top := PicRect.Top;
    if Area.Bottom > PicRect.Bottom then Area.Bottom := PicRect.Bottom;
  end;
  if WindowHandle <> 0 then
    InvalidateRect(WindowHandle, @Area, False);
end;

procedure TCustomPicShow.DoChange;
begin
  if Assigned(fOnChange) then
    fOnChange(Self);
end;

procedure TCustomPicShow.DoProgress;
begin
  if Assigned(fOnProgress) then
    fOnProgress(Self);
end;

procedure TCustomPicShow.DoCustomDraw(Picture, Screen: TBitmap);
begin
  if Assigned(fOnCustomDraw) then
    fOnCustomDraw(Self, Picture, Screen);
end;

procedure TCustomPicShow.DoBeforeNewFrame(Picture, Screen: TBitmap);
begin
  if Assigned(fOnBeforeNewFrame) then
    fOnBeforeNewFrame(Self, Picture, Screen);
end;

procedure TCustomPicShow.DoAfterNewFrame(Picture, Screen: TBitmap);
begin
  if Assigned(fOnAfterNewFrame) then
    fOnAfterNewFrame(Self, Picture, Screen);
end;

procedure TCustomPicShow.DoComplete;
begin
  if Assigned(fOnComplete) then
    fOnComplete(Self);
end;

procedure TCustomPicShow.DoStart(NewPicture, OldPicture: TBitmap);
begin
  if Assigned(fOnStart) then
    fOnStart(Self, NewPicture, OldPicture);
end;

procedure TCustomPicShow.DoStop;
begin
  if Assigned(fOnStop) then
    fOnStop(Self);
end;

Procedure TCustomPicShow.Clear;
begin
  if not (Busy or Media.Empty) then
  begin
    Media.Free;
    Media := TBitmap.Create;
    Invalidate;
  end;
end;

procedure TCustomPicShow.Stop;
begin
  if Busy and not Stopping then
  begin
    Stopping := True;
    try
      if Manual or not WaitForThread then
        Unprepare;
    finally
      Stopping := False;
    end;
  end;
end;

procedure TCustomPicShow.Execute;
begin
  if (Picture.Graphic <> nil) and not Busy then
  begin
    fBusy := True;
    try
      HandleNeeded;
      Prepare;
      if not (Manual or Stopping) then Animate;
    except
      if Pic <> nil then FreeAndNil(Pic);
      if OldPic <> nil then FreeAndNil(OldPic);
      fBusy := False;
      raise;
    end;
  end;
end;

procedure TCustomPicShow.Animate;
var
  StartTime: DWord;
  Done: Boolean;
begin
  if Threaded then
    Thread := TAnimateThread.Create(Self)
  else
  begin
    Done := False;
    repeat
      StartTime := GetTickCount;
      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
        Done := not fManual
      else
        repeat
          Application.ProcessMessages;
        until ((GetTickCount - StartTime) > Delay) or Manual or Stopping;
    until Done or Manual or Stopping;
    if Stopping or not Manual then
      Unprepare;
  end;
end;

procedure TCustomPicShow.Prepare;
var
  OldPicRect: TRect;
begin
  PicWidth := Picture.Width;
  PicHeight := Picture.Height;
  Media.Width := PicWidth;
  Media.Height := PicHeight;
  CalculatePicRect;
  if Stretch then
    if StretchFine then
      OldPicRect := ScaleImageToRect(PicRect, ClientRect)
    else
      OldPicRect := ClientRect
  else
    OldPicRect := PicRect;
  OldPic := TBitmap.Create;
  OldPic.Canvas.Brush.Color := Color;
  OldPic.Width := PicWidth;
  OldPic.Height := PicHeight;
  if NeverDrawn or not OverDraw then
    PaintBackground(OffScreen.Canvas, ClientRect);
  SetStretchBltMode(OldPic.Canvas.Handle, COLORONCOLOR);
  OldPic.Canvas.CopyRect(Rect(0, 0, PicWidth, PicHeight),
    OffScreen.Canvas, OldPicRect);
  Pic := TBitmap.Create;
  try
    Pic.Assign(Picture.Graphic);
  except
    Pic.Width := PicWidth;
    Pic.Height := PicHeight;
    Pic.Canvas.Draw(0, 0, Picture.Graphic);
  end;
  if Style in Bmp32Styles then
  begin
    Pic.PixelFormat := pf32bit;
    Media.PixelFormat := pf32bit;
  end
  else
    Media.HandleType := bmDDB;
  if Reverse then
    fProgress := 100
  else
    fProgress := 0;
  DoStart(Pic, OldPic);
end;

procedure TCustomPicShow.Unprepare;
begin
  fBusy := False;
  if Pic <> nil then FreeAndNil(Pic);
  if OldPic <> nil then FreeAndNil(OldPic);
  if not (csDestroying in ComponentState) then
  begin
    if not Stopping then DoComplete;
    DoStop;
  end;
end;

procedure TCustomPicShow.UpdateMedia;
var
  R: TRect;
begin
  Pic.Canvas.Lock;
  Media.Canvas.Lock;
  try
    OldPic.Canvas.Lock;
    try
      Media.Canvas.Draw(0, 0, OldPic);
    finally
      OldPic.Canvas.Unlock;
    end;
    if Assigned(fOnBeforeNewFrame) then
      fOnBeforeNewFrame(Self, Pic, Media);
    SetRect(R, 0, 0, PicWidth, PicHeight);
    if Progress = 100 then
      Media.Canvas.Draw(0, 0, Pic)
    else if Progress <> 0 then
    begin
      if Style = 0 then
        DoCustomDraw(Pic, Media)
      else
        PSEffects[Style].Proc(Media, Pic, R, Step, Progress);
    end;
    InvalidateArea(R);
    if Assigned(fOnAfterNewFrame) then
      fOnAfterNewFrame(Self, Pic, Media);
  finally
    Media.Canvas.Unlock;
    Pic.Canvas.Unlock;
  end;
end;

{ TDBPicShow }

constructor TDBPicShow.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  fAutoDisplay := True;
  fDataLink := TFieldDataLink.Create;
  fDataLink.Control := Self;
  fDataLink.OnDataChange := DataChange;
  fDataLink.OnUpdateData := UpdateData;
  fDataLink.OnEditingChange := EditingChange;
end;

destructor TDBPicShow.Destroy;
begin
  fDataLink.Free;
  fDataLink := nil;
  inherited Destroy;
end;

function TDBPicShow.GetDataSource: TDataSource;
begin
  Result := fDataLink.DataSource;
end;

procedure TDBPicShow.SetDataSource(Value: TDataSource);
begin
  if not (fDataLink.DataSourceFixed and (csLoading in ComponentState)) then
    fDataLink.DataSource := Value;
  if fDataLink.DataSource <> nil then
    fDataLink.DataSource.FreeNotification(Self);
end;

function TDBPicShow.GetDataField: string;
begin
  Result := fDataLink.FieldName;
end;

procedure TDBPicShow.SetDataField(const Value: string);
begin
  fDataLink.FieldName := Value;
end;

function TDBPicShow.GetReadOnly: Boolean;
begin
  Result := fDataLink.ReadOnly;
end;

procedure TDBPicShow.SetReadOnly(Value: Boolean);
begin
  fDataLink.ReadOnly := Value;
end;

function TDBPicShow.GetField: TField;
begin
  Result := fDataLink.Field;
end;

procedure TDBPicShow.SetAutoDisplay(Value: Boolean);
begin
  if AutoDisplay <> Value then
  begin
    fAutoDisplay := Value;
    if AutoDisplay and not fDataLink.Editing then LoadPicture;
  end;
end;

procedure TDBPicShow.DoChange;
begin
  inherited DoChange;
  if fLoaded and fDataLink.Editing then
  begin
    fDataLink.Modified;
    fModified := True;
    if Busy then
      Stop;
    if (Picture.Graphic = nil) or Picture.Graphic.Empty then
      Clear
    else
      Execute;
  end;
end;

procedure TDBPicShow.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (fDataLink <> nil) and (AComponent = DataSource) then
    DataSource := nil;
end;

function TDBPicShow.FindGraphicClass(Stream: TMemoryStream): TGraphicClass;
var
  I: Integer;
begin
  Result := nil;
  for I := Low(GraphicSigns) to High(GraphicSigns) do
    with GraphicSigns[I] do
      if (Stream.Size >= (Offset + Length)) and
         CompareMem(Pointer(DWORD(Stream.Memory) + Offset), Signature, Length) then
      begin
        Result := GraphicClass;
        Break;
      end;
  if Assigned(fOnGetGraphicClass) then
    fOnGetGraphicClass(Self, Result);
end;

procedure TDBPicShow.LoadPictureFromStream(Stream: TMemoryStream;
  GraphicClass: TGraphicClass);
var
  Graphic: TGraphic;
begin
  if GraphicClass = nil then
  begin
    Picture.Graphic := nil;
    raise EInvalidGraphic.Create('Unknown picture format');
  end
  else if GraphicClass = TBitmap then
    Picture.Bitmap.LoadFromStream(Stream)
  else if GraphicClass = TMetafile then
    Picture.Metafile.LoadFromStream(Stream)
  else if GraphicClass = TIcon then
    Picture.Icon.LoadFromStream(Stream)
  else
  begin
    Graphic := GraphicClass.Create;
    try
      Graphic.LoadFromStream(Stream);
      Picture.Assign(Graphic);
    finally
      Graphic.Free;
    end;
  end;
end;

procedure TDBPicShow.LoadPicture;
var
  Stream: TMemoryStream;
begin
  if not fLoaded and (fDataLink.Field <> nil) and (fDataLink.Field is TBlobField) then
  begin
    if Busy then Stop;
    try
      if not fDataLink.Field.IsNull then
      begin
        if Assigned(fOnBeforeLoadPicture) then
          fOnBeforeLoadPicture(Self);
        Stream := TMemoryStream.Create;
        try
          TBlobField(fDataLink.Field).SaveToStream(Stream);
          if Stream.Size > 0 then
          begin
            Stream.Position := 0;
            LoadPictureFromStream(Stream, FindGraphicClass(Stream));
          end;
        finally
          Stream.Free;
        end;
        if Assigned(fOnAfterLoadPicture) then
          fOnAfterLoadPicture(Self);
      end;
    finally
      fLoaded := True;
      if (Picture.Graphic = nil) or Picture.Graphic.Empty then
        Clear
      else
        Execute;
    end;
  end;
end;

procedure TDBPicShow.DataChange(Sender: TObject);
begin
  if not fSkipLoading then
  begin
    fLoaded := False;
    fModified := False;
    Picture.Graphic := nil;
    if AutoDisplay then LoadPicture;
  end;
  fSkipLoading := False;
end;

procedure TDBPicShow.EditingChange(Sender: TObject);
begin
  if fDataLink.Editing then
    fSkipLoading := (fDataLink.DataSet.State <> dsInsert)
  else
    fSkipLoading := not fModified;
end;

procedure TDBPicShow.UpdateData(Sender: TObject);
var
  Stream: TMemoryStream;
begin
  fModified := False;
  fDataLink.Field.Clear;
  if (Picture.Graphic <> nil) and not Picture.Graphic.Empty and
     (fDataLink.Field is TBlobField) then
  begin
    Stream := TMemoryStream.Create;
    try
      Picture.Graphic.SaveToStream(Stream);
      Stream.Seek(0, soFromBeginning);
      TBlobField(fDataLink.Field).LoadFromStream(Stream);
    finally
      Stream.Free;
    end;
  end;
end;

procedure TDBPicShow.CMGetDataLink(var Message: TMessage);
begin
  Message.Result := Integer(fDataLink);
end;

end.