picshow.pas

免费控件PicShow的最新版本

procedure TCustomPicShow.UpdateDisplayRect;
var
  cW, cH, pW, pH: Integer;
begin
  cW := ClientWidth - 2 * FrameWidth;
  cH := ClientHeight - 2 * FrameWidth;
  pW := PicRect.Right - PicRect.Left;
  pH := PicRect.Bottom - PicRect.Top;
  if Proportional and (pW > 0) and (pH > 0) and (Stretch or (pW > cW) or (pH > cH)) then
    if (cW / pW) < (cH / pH) then
    begin
      pH := MulDiv(pH, cW, pW);
      pW := cW;
    end
    else
    begin
      pW := MulDiv(pW, cH, pH);
      pH := cH;
    end
  else if Stretch then
  begin
    pW := cW;
    pH := cH;
  end;
  SetRect(DisplayRect, 0, 0, pW, pH);
  if Center then
    OffsetRect(DisplayRect, FrameWidth + (cW - pW) div 2, FrameWidth + (cH - pH) div 2)
  else
    OffsetRect(DisplayRect, FrameWidth, FrameWidth);
  if DynamicOldPic and Assigned(OldPic) then
    UpdateOldPic;
end;

procedure TCustomPicShow.UpdateOldPic;
var
  BackImage: TBitmap;
begin
  BackImage := TBitmap.Create;
  try
    BackImage.Width := DisplayRect.Right - DisplayRect.Left;
    BackImage.Height := DisplayRect.Bottom - DisplayRect.Top;
    SetViewportOrgEx(BackImage.Canvas.Handle, -DisplayRect.Left, -DisplayRect.Top, nil);
    DrawBackground(BackImage.Canvas, ClientRect);
    SetViewportOrgEx(BackImage.Canvas.Handle, 0, 0, nil);
    OldPic.Canvas.Lock;
    try
      OldPic.Canvas.StretchDraw(PicRect, BackImage);
    finally
      OldPic.Canvas.Unlock;
    end;
    if Busy and Manual and not Stopping then
      UpdateDisplay;
  finally
    BackImage.Free;
  end;
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 Display.Empty) then
  begin
    Display.Assign(nil);
    FillChar(PicRect, SizeOf(TRect), 0);
    FillChar(DisplayRect, SizeOf(TRect), 0);
    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
  ProgressStep: Integer;
  ElapsedTime: Integer;
  ActualDelay: Integer;
  ResumeTime: DWORD;
begin
  if not Threaded then
  begin
    ProgressStep := Step;
    while UpdateProgress(ProgressStep, ElapsedTime) and not (Manual or Stopping) do
    begin
      ActualDelay := Delay - ElapsedTime;
      if ActualDelay >= 0 then
      begin
        ResumeTime := GetTickCount + DWORD(ActualDelay);
        repeat
          Application.ProcessMessages;
        until (GetTickCount >= ResumeTime) or Manual or Stopping;
        ProgressStep := Step;
      end
      else if ExactTiming then
        ProgressStep := MulDiv(Step, Delay - ActualDelay, Delay);
    end;
    if Stopping or not Manual then
      Unprepare;
  end
  else
    Thread := TAnimateThread.Create(Self);
end;

function TCustomPicShow.UpdateProgress(ProgressStep: Integer;
  out ElapsedTime: Integer): Boolean;
var
  StartTime: DWORD;
begin
  Result := True;
  StartTime := GetTickCount;
  if Reverse then
    if Progress > ProgressStep then
      Progress := Progress - ProgressStep
    else
      Progress := 0
  else
    if Progress < 100 - ProgressStep then
      Progress := Progress + ProgressStep
    else
      Progress := 100;
  if (Reverse and (Progress = 0)) or (not Reverse and (Progress = 100)) then
    Result := False;
  ElapsedTime := GetTickCount - StartTime;
end;

procedure TCustomPicShow.Prepare;
var
  Width, Height: Integer;
begin
  Width := Picture.Width;
  Height := Picture.Height;
  // Prepares old picture
  OldPic := TBitmap.Create;
  if OverDraw and not Display.Empty and
    (Width = Display.Width) and (Height = Display.Height) then
  begin
    DynamicOldPic := False;
    OldPic.Assign(Display);
  end
  else
  begin
    DynamicOldPic := True;
    OldPic.Width := Width;
    OldPic.Height := Height;
  end;
  OldPic.PixelFormat := pf32bit;
  // Prepares current picture
  Pic := TBitmap.Create;
  Pic.Canvas.Brush.Color := Color;
  Pic.Width := Width;
  Pic.Height := Height;
  Picture.OnChange := nil;
  try
    Pic.Canvas.Draw(0, 0, Picture.Graphic);
  finally
    Picture.OnChange := PictureChange;
  end;
  Pic.PixelFormat := pf32bit;
  // Prepares display
  Display.Width := Width;
  Display.Height := Height;
  Display.PixelFormat := pf32bit;
  // Prepares bounding rectangles
  SetRect(PicRect, 0, 0, Width, Height);
  UpdateDisplayRect;
  Display.Assign(OldPic);
  if Reverse then
    fProgress := 100
  else
    fProgress := 0;
  Invalidate;
  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.UpdateDisplay;
var
  X, Y: Integer;
begin
  Pic.Canvas.Lock;
  Display.Canvas.Lock;
  try
    OldPic.Canvas.Lock;
    try
      BitBlt(Display.Canvas.Handle, 0, 0, PicRect.Right, PicRect.Bottom,
             OldPic.Canvas.Handle, 0, 0, SRCCOPY);
    finally
      OldPic.Canvas.Unlock;
    end;
    if Assigned(fOnBeforeNewFrame) then
      fOnBeforeNewFrame(Self, Pic, Display);
    if Progress = 100 then
      BitBlt(Display.Canvas.Handle, 0, 0, PicRect.Right, PicRect.Bottom,
             Pic.Canvas.Handle, 0, 0, SRCCOPY)
    else if Progress <> 0 then
    begin
      if Style = 0 then
        DoCustomDraw(Pic, Display)
      else
      begin
        SetStretchBltMode(Display.Canvas.Handle, COLORONCOLOR);
        if PicRect.Right >= PicRect.Bottom then
        begin
          X := MulDiv(PicRect.Right, Progress, 100);
          Y := MulDiv(X, PicRect.Bottom, PicRect.Right);
        end
        else
        begin
          Y := MulDiv(PicRect.Bottom, Progress, 100);
          X := MulDiv(Y, PicRect.Right, PicRect.Bottom);
        end;
        PSEffects[Style].Proc(Display, Pic, PicRect.Right, PicRect.Bottom, X, Y, Progress);
      end;
    end;
    if Assigned(fOnAfterNewFrame) then
      fOnAfterNewFrame(Self, Pic, Display);
  finally
    Display.Canvas.Unlock;
    Pic.Canvas.Unlock;
  end;
end;

procedure TCustomPicShow.DefineProperties(Filer: TFiler);
begin
  inherited DefineProperties(Filer);
  Filer.DefineProperty('StretchFine', ReadStretchFine, nil, False);
end;

procedure TCustomPicShow.ReadStretchFine(Reader: TReader);
begin
  Proportional := Reader.ReadBoolean;
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 (DWORD(Stream.Size) >= (Offset + Length)) then
        if CompareMem(Pointer(DWORD(Stream.Memory) + Offset), Signature, Length) then
      begin
        Result := GraphicClass;
        Break;
      end;
  {$IFDEF GRAPHICEX}
  if not Assigned(Result) then
    Result := FileFormatList.GraphicFromContent(Stream);
  {$ENDIF}
  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.Seek(0, soFromBeginning);
            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.