preview.pas

Print Preview Suite v4.76 很不错的 打印预览控件!

      NewStream := CreateMetafileStream;
      NewStream.CopyFrom(FDataStream, 0);
      FDataStream.Free;
      FDataStream := NewStream;
      if not FUseTempFile and FileExists(FTempFile) then
      begin
        DeleteFile(FTempFile);
        FTempFile := EmptyStr;
      end;
    end;
  end;
end;

function TMetafileList.CreateMetafileStream: TStream;
begin
  if FUseTempFile then
  begin
    FTempFile := GetTemporaryFileName;
    Result := TFileStream.Create(FTempFile, fmCreate or fmShareExclusive)
  end
  else
    Result := TMemoryStream.Create;
end;

procedure TMetafileList.MetafileChanged(Sender: TObject);
var
  Stream, RestOfStream: TMemoryStream;
  OldSize, Delta, I: Integer;
begin
  RestOfStream := nil;
  Stream := TMemoryStream.Create;
  try
    FLoadedMetafile.SaveToStream(Stream);
    if FLoadedIndex < FRecords.Count - 1 then
      OldSize := Integer(FRecords[FLoadedIndex+1]) - Integer(FRecords[FLoadedIndex])
    else
      OldSize := FDataStream.Size - Integer(FRecords[FLoadedIndex]);
    Delta := Stream.Size - OldSize;
    if (Delta <> 0) and (FLoadedIndex < FRecords.Count - 1) then
    begin
      RestOfStream := TMemoryStream.Create;
      FDataStream.Seek(Integer(FRecords[FLoadedIndex+1]), soFromBeginning);
      RestOfStream.Size := FDataStream.Size - FDataStream.Position;
      RestOfStream.CopyFrom(FDataStream, RestOfStream.Size);
    end;
    FDataStream.Seek(Integer(FRecords[FLoadedIndex]), soFromBeginning);
    FDataStream.CopyFrom(Stream, 0);
  finally
    Stream.Free;
  end;
  if RestOfStream <> nil then
  begin
    for I := FLoadedIndex + 1 to FRecords.Count - 1 do
      FRecords[I] := Pointer(Integer(FRecords[I]) + Delta);
    FDataStream.CopyFrom(RestOfStream, 0);
    RestOfStream.Free;
  end;
  if Delta < 0 then
    FDataStream.Size := FDataStream.Size + Delta;
  if Assigned(FOnCurrentChange) then
    FOnCurrentChange(Self, FLoadedIndex);
end;

{ TPaperPreview }

constructor TPaperPreview.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque];
  FOffScreen := TBitmap.Create;
  FBorderColor := clBlack;
  FBorderSize := 1;
  FPaperColor := clWhite;
  FShadowColor := clBtnShadow;
  FShadowSize := 3;
  PaperWidth := 105;
  PaperHeight := 148;
end;

destructor TPaperPreview.Destroy;
begin
  FOffScreen.Free;
  inherited Destroy;
end;

procedure TPaperPreview.Invalidate;
begin
  FOffScreenDrawn := False;
  inherited Invalidate;
end;

procedure TPaperPreview.Paint;
var
  Rect: TRect;
  ClipRgn: THandle;
begin
  if FOffScreenValid then
  begin
    if not FOffScreenPrepared then
    begin
      PrepareOffScreen;
      FOffScreenPrepared := True;
      FOffScreenDrawn := False;
    end;
    if not FOffScreenDrawn then
    begin
      GetPageRect(Rect);
      ClipRgn := CreateRectRgnIndirect(Rect);
      try
        SelectClipRgn(FOffscreen.Canvas.Handle, ClipRgn);
      finally
        DeleteObject(ClipRgn);
      end;
      FOffscreen.Canvas.Brush.Style := bsSolid;
      FOffscreen.Canvas.Brush.Color := PaperColor;
      FOffscreen.Canvas.FillRect(Rect);
      if Assigned(FOnPaint) then
        FOnPaint(Self, FOffScreen.Canvas, Rect);
      SelectClipRgn(FOffscreen.Canvas.Handle, 0);
      FOffScreenDrawn := True;
    end;
    BitBlt(Canvas.Handle, 0, 0, Width, Height, FOffScreen.Canvas.Handle, 0, 0, SRCCOPY);
  end;
end;

procedure TPaperPreview.PrepareOffScreen;
var
  Rect: TRect;
begin
  with FOffscreen.Canvas do
  begin
    Pen.Mode := pmCopy;
    if BorderSize > 0 then
    begin
      Pen.Width := BorderSize;
      Pen.Style := psInsideFrame;
      Pen.Color := BorderColor;
      Brush.Style := bsClear;
      Rectangle(0, 0, Width - ShadowSize, Height - ShadowSize);
    end;
    if ShadowSize > 0 then
    begin
      Brush.Style := bsSolid;
      Brush.Color := ShadowColor;
      SetRect(Rect, Width - ShadowSize, ShadowSize, Width, Height);
      FillRect(Rect);
      SetRect(Rect, ShadowSize, Height - ShadowSize, Width, Height);
      FillRect(Rect);
      Brush.Color := Color;
      SetRect(Rect, Width - ShadowSize, 0, Width, ShadowSize);
      FillRect(Rect);
      SetRect(Rect, 0, Height - ShadowSize, ShadowSize, Height);
      FillRect(Rect);
    end;
  end;
end;

procedure TPaperPreview.GetPageRect(var Rect: TRect);
begin
  with Rect do
  begin
    Left := BorderSize;
    Top := BorderSize;
    Right := Width - (BorderSize + ShadowSize);
    Bottom := Height - (BorderSize + ShadowSize);
  end;
end;

function TPaperPreview.ActualSize(Value: Integer): Integer;
begin
  Result := Value + 2 * FBorderSize + FShadowSize;
end;

function TPaperPreview.LogicalSize(Value: Integer): Integer;
begin
  Result := Value - 2 * FBorderSize - FShadowSize;
end;

procedure TPaperPreview.SetPaperWidth(Value: Integer);
begin
  Width := ActualSize(Value);
end;

function TPaperPreview.GetPaperWidth: Integer;
begin
  Result := LogicalSize(Width);
end;

procedure TPaperPreview.SetPaperHeight(Value: Integer);
begin
  Height := ActualSize(Value);
end;

function TPaperPreview.GetPaperHeight: Integer;
begin
  Result := LogicalSize(Height);
end;

procedure TPaperPreview.SetPaperColor(Value: TColor);
begin
  if FPaperColor <> Value then
  begin
    FPaperColor := Value;
    FOffScreenPrepared := False;
    Invalidate;
  end;
end;

procedure TPaperPreview.SetBorderColor(Value: TColor);
begin
  if FBorderColor <> Value then
  begin
    FBorderColor := Value;
    FOffScreenPrepared := False;
    Invalidate;
  end;
end;

procedure TPaperPreview.SetBorderSize(Value: TBorderWidth);
var
  PaperSize: TPoint;
begin
  if FBorderSize <> Value then
  begin
    PaperSize.X := PaperWidth;
    PaperSize.Y := PaperHeight;
    FBorderSize := Value;
    PaperWidth := PaperSize.X;
    PaperHeight := PaperSize.Y;
  end;
end;

procedure TPaperPreview.SetShadowColor(Value: TColor);
begin
  if FShadowColor <> Value then
  begin
    FShadowColor := Value;
    FOffScreenPrepared := False;
    Invalidate;
  end;
end;

procedure TPaperPreview.SetShadowSize(Value: TBorderWidth);
var
  PaperSize: TPoint;
begin
  if FShadowSize <> Value then
  begin
    PaperSize.X := PaperWidth;
    PaperSize.Y := PaperHeight;
    FShadowSize := Value;
    PaperWidth := PaperSize.X;
    PaperHeight := PaperSize.Y;
  end;
end;

procedure TPaperPreview.WMSize(var Message: TWMSize);
begin
  inherited;
  try
    FOffScreen.Width := Width;
    FOffScreen.Height := Height;
    FOffScreenValid := True;
    FOffScreenPrepared := False;
  except
    FOffScreenValid := False;
  end;
  if Assigned(FOnResize) then
    FOnResize(Self);
end;

procedure TPaperPreview.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  Message.Result := 1;
end;

{ TPaperPreviewOptions }

constructor TPaperPreviewOptions.Create;
begin
  inherited Create;
  FBorderColor := clBlack;
  FBorderWidth := 1;
  FCursor := crDefault;
  FDragCursor := crHand;
  FGrabCursor := crGrab;  //pvg
  FPaperColor := clWhite;
  FShadowColor := clBtnShadow;
  FShadowWidth := 3;
end;

procedure TPaperPreviewOptions.Assign(Source: TPersistent);
begin
  if Source is TPaperPreviewOptions then
  begin
    BorderColor := TPaperPreviewOptions(Source).BorderColor;
    BorderWidth :=  TPaperPreviewOptions(Source).BorderWidth;
    Cursor := TPaperPreviewOptions(Source).Cursor;
    DragCursor := TPaperPreviewOptions(Source).DragCursor;
    GrabCursor := TPaperPreviewOptions(Source).GrabCursor; //pvg
    PaperColor := TPaperPreviewOptions(Source).PaperColor;
    PopupMenu := TPaperPreviewOptions(Source).PopupMenu;
    ShadowColor := TPaperPreviewOptions(Source).ShadowColor;
    ShadowWidth := TPaperPreviewOptions(Source).ShadowWidth;
  end
  else
    inherited Assign(Source);
end;

procedure TPaperPreviewOptions.AssignTo(Source: TPersistent);
begin
  if Source is TPaperPreviewOptions then
    Source.Assign(Self)
  else if Source is TPaperPreview then
  begin
    TPaperPreview(Source).PaperColor := PaperColor;
    TPaperPreview(Source).BorderColor := BorderColor;
    TPaperPreview(Source).BorderSize := BorderWidth;
    TPaperPreview(Source).ShadowColor := ShadowColor;
    TPaperPreview(Source).ShadowSize := ShadowWidth;
    TPaperPreview(Source).Cursor := Cursor;
    TPaperPreview(Source).PopupMenu := PopupMenu;
  end
  else
    inherited AssignTo(Source);
end;

procedure TPaperPreviewOptions.DoChange;
begin
  if Assigned(FOnChange) then FOnChange(self);
end;

procedure TPaperPreviewOptions.SetPaperColor(Value: TColor);
begin
  if FPaperColor <> Value then
  begin
    FPaperColor := Value;
    DoChange;
  end;
end;

procedure TPaperPreviewOptions.SetBorderColor(Value: TColor);
begin
  if FBorderColor <> Value then
  begin
    FBorderColor := Value;
    DoChange;
  end;
end;

procedure TPaperPreviewOptions.SetBorderWidth(Value: TBorderWidth);
begin
  if FBorderWidth <> Value then
  begin
    FBorderWidth := Value;
    DoChange;
  end;
end;

procedure TPaperPreviewOptions.SetShadowColor(Value: TColor);