preview.pas

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

      finally
        FreeMem(memInfo);
      end;
    finally
      DeleteObject(MemBmp);
    end;
  finally
    DeleteDC(MemDC);
  end;
end;
{$ENDIF}

procedure DrawBitmapAsDIB(DC: HDC; Bitmap: TBitmap; const Rect: TRect);
var
  BitmapHeader: pBitmapInfo;
  BitmapImage: Pointer;
  HeaderSize: DWORD;
  ImageSize: DWORD;
  {$IFDEF IMAGE_TRANSPARENCY}
  MaskBitmapHeader: pBitmapInfo;
  MaskBitmapImage: Pointer;
  maskHeaderSize: DWORD;
  MaskImageSize: DWORD;
  {$ENDIF}
begin
  GetDIBSizes(Bitmap.Handle, HeaderSize, ImageSize);
  GetMem(BitmapHeader, HeaderSize);
  try
    GetMem(BitmapImage, ImageSize);
    try
      GetDIB(Bitmap.Handle, Bitmap.Palette, BitmapHeader^, BitmapImage^);
      {$IFDEF IMAGE_TRANSPARENCY}
      if Bitmap.Transparent then
      begin
        GetDIBSizes(Bitmap.MaskHandle, MaskHeaderSize, MaskImageSize);
        GetMem(MaskBitmapHeader, MaskHeaderSize);
        try
          GetMem(MaskBitmapImage, MaskImageSize);
          try
            GetDIB(Bitmap.MaskHandle, 0, MaskBitmapHeader^, MaskBitmapImage^);
            TransparentStretchDIBits(
              DC,                              // handle of destination device context
              Rect.Left, Rect.Top,             // upper-left corner of destination rectagle
              Rect.Right - Rect.Left,          // width of destination rectagle
              Rect.Bottom - Rect.Top,          // height of destination rectagle
              0, 0,                            // upper-left corner of source rectangle
              Bitmap.Width, Bitmap.Height,     // width and height of source rectangle
              BitmapImage,                     // address of bitmap bits
              BitmapHeader^,                   // bitmap data
              MaskBitmapImage,                 // address of mask bitmap bits
              MaskBitmapHeader^,               // mask bitmap data
              DIB_RGB_COLORS                   // usage: the color table contains literal RGB values
            );
          finally
            FreeMem(MaskBitmapImage)
          end;
        finally
          FreeMem(MaskBitmapHeader);
        end;
      end
      else
      {$ENDIF}
      begin
        SetStretchBltMode(DC, ColorOnColor);
        StretchDIBits(
          DC,                                  // handle of destination device context
          Rect.Left, Rect.Top,                 // upper-left corner of destination rectagle
          Rect.Right - Rect.Left,              // width of destination rectagle
          Rect.Bottom - Rect.Top,              // height of destination rectagle
          0, 0,                                // upper-left corner of source rectangle
          Bitmap.Width, Bitmap.Height,         // width and height of source rectangle
          BitmapImage,                         // address of bitmap bits
          BitmapHeader^,                       // bitmap data
          DIB_RGB_COLORS,                      // usage: the color table contains literal RGB values
          SrcCopy                              // raster operation code: copy source pixels
        );
      end;
    finally
      FreeMem(BitmapImage)
    end;
  finally
    FreeMem(BitmapHeader);
  end;
end;

procedure StretchDrawGraphic(Canvas: TCanvas; const Rect: TRect; Graphic: TGraphic);
var
  Bitmap: TBitmap;
begin
  if Graphic is TBitmap then
    DrawBitmapAsDIB(Canvas.Handle, TBitmap(Graphic), Rect)
  else if Graphic is TMetafile then
    Canvas.StretchDraw(Rect, Graphic)
  else if Graphic is TIcon then
    DrawIconEx(Canvas.Handle, Rect.Left, Rect.Top, TIcon(Graphic).Handle,
      Rect.Right - Rect.Left, Rect.Bottom - Rect.Top, 0, 0, DI_NORMAL)
  else
  begin
    Bitmap := TBitmap.Create;
    try
      Bitmap.Canvas.Brush.Color := clFuchsia;
      Bitmap.Width := Graphic.Width;
      Bitmap.Height := Graphic.Height;
      Bitmap.Canvas.Draw(0, 0, Graphic);
      Bitmap.Transparent := Graphic.Transparent;
      DrawBitmapAsDIB(Canvas.Handle, Bitmap, Rect)
    finally
      Bitmap.Free;
    end;
  end;
end;

procedure DrawGraphic(Canvas: TCanvas; X, Y: Integer; Graphic: TGraphic);
var
  Rect: TRect;
begin
  Rect.Left := X;
  Rect.Top := Y;
  Rect.Right := X + Graphic.Width;
  Rect.Bottom := Y + Graphic.Height;
  StretchDrawGraphic(Canvas, Rect, Graphic);
end;

procedure StretchDrawGrayscale(Canvas: TCanvas; const Rect: TRect; Graphic: TGraphic);
var
  Bitmap: TBitmap;
  R: TRect;
begin
  Bitmap := TBitmap.Create;
  try
    Bitmap.Width := Rect.Right - Rect.Left;
    Bitmap.Height := Rect.Bottom - Rect.Top;
    SetRect(R, 0, 0, Bitmap.Width, Bitmap.Height);
    Bitmap.Canvas.StretchDraw(R, Graphic);
    ConvertBitmapToGrayscale(Bitmap);
    DrawBitmapAsDIB(Canvas.Handle, Bitmap, Rect);
  finally
    Bitmap.Free;
  end;
end;

procedure DrawGrayscale(Canvas: TCanvas; X, Y: Integer; Graphic: TGraphic);
var
  Rect: TRect;
begin
  Rect.Left := X;
  Rect.Top := Y;
  Rect.Right := X + Graphic.Width;
  Rect.Bottom := Y + Graphic.Height;
  StretchDrawGrayscale(Canvas, Rect, Graphic);
end;

procedure ConvertBitmapToGrayscale(Bitmap: TBitmap);
var
  LogPalette: PLogPalette;
  NumEntries: Word;
  Intensity: Byte;
  I: Integer;
  GrayPalette: HPALETTE;
begin
  Bitmap.PixelFormat := pf8bit;
  GetObject(Bitmap.Palette, SizeOf(NumEntries), @NumEntries);
  GetMem(LogPalette, SizeOf(TLogPalette) + NumEntries * SizeOf(TPaletteEntry));
  try
    with LogPalette^ do
    begin
      palVersion := $300;
      palNumEntries := NumEntries;
      GetPaletteEntries(Bitmap.Palette, 0, NumEntries, palPalEntry[0]);
    end;
    for I := 0 to NumEntries - 1 do
      with LogPalette^.palPalEntry[I] do
      begin
        Intensity := (peRed * 30 + peGreen * 59 + peBlue * 11) div 100;
        peRed := Intensity;
        peGreen := Intensity;
        peBlue := Intensity;
        peFlags := 0;
      end;
      GrayPalette := CreatePalette(LogPalette^);
      try
        Bitmap.Palette := GrayPalette;
      finally
        DeleteObject(GrayPalette);
      end;
  finally
    FreeMem(LogPalette);
  end;
end;

{ TMetafileList }

constructor TMetafileList.Create;
begin
  inherited Create;
  FRecords := TList.Create;
  FLoadedMetafile := TMetafile.Create;
  FLoadedIndex := -1;
end;

destructor TMetafileList.Destroy;
begin
  Cleanup;
  FLoadedMetafile.Free;
  FRecords.Free;
  inherited Destroy;
end;

procedure TMetafileList.Cleanup;
begin
  FLoadedMetafile.OnChange := nil;
  FLoadedMetafile.Clear;
  FRecords.Clear;
  FLoadedIndex := -1;
  if Assigned(FDataStream) then
  begin
    FDataStream.Free;
    FDataStream := nil;
    if FUseTempFile and FileExists(FTempFile) then
      DeleteFile(FTempFile);
  end;
end;

procedure TMetafileList.Clear;
begin
  Cleanup;
  if Assigned(FOnChange) then
    FOnChange(Self);
end;

function TMetafileList.Add(AMetafile: TMetafile): Integer;
var
  Offset: Integer;
begin
  if not Assigned(FDataStream) then
    FDataStream := CreateMetafileStream;
  FDataStream.Seek(0, soFromEnd);
  Offset := FDataStream.Position;
  AMetafile.SaveToStream(FDataStream);
  Result := FRecords.Add(Pointer(Offset));
  if Assigned(FOnChange) then
    FOnChange(Self);
end;

procedure TMetafileList.LoadFromStream(Stream: TStream);
var
  I: Integer;
  Data: Integer;
  ReadBytes: Integer;
  Buffer: array[1..$F000] of Byte;
begin
  Stream.Read(Data, SizeOf(Data));
  if MetafilesSignature <> Data then
    raise EInvalidPreviewData.Create(SInvalidPreviewData);
  Clear;
  Stream.Read(Data, SizeOf(Data));
  FRecords.Capacity := Data;
  for I := Data downto 1 do
  begin
    Stream.Read(Data, SizeOf(Data));
    FRecords.Add(Pointer(Data));
  end;
  FDataStream := CreateMetafileStream;
  ReadBytes := Stream.Read(Buffer, SizeOf(Buffer));
  while ReadBytes > 0 do
  begin
    FDataStream.Write(Buffer, ReadBytes);
    ReadBytes := Stream.Read(Buffer, SizeOf(Buffer));
  end;
  if Assigned(FOnChange) then
    FOnChange(Self);
end;

procedure TMetafileList.SaveToStream(Stream: TStream);
var
  I: Integer;
  Data: Integer;
  ReadBytes: Integer;
  Buffer: array[1..$F000] of Byte;
begin
  Data := MetafilesSignature;
  Stream.Write(Data, SizeOf(Data));
  Data := FRecords.Count;
  Stream.Write(Data, SizeOf(Data));
  for I := 0 to FRecords.Count - 1 do
  begin
    Data := Integer(FRecords[I]);
    Stream.Write(Data, SizeOf(Data));
  end;
  if Assigned(FDataStream) then
  begin
    FDataStream.Position := 0;
    ReadBytes := FDataStream.Read(Buffer, SizeOf(Buffer));
    while ReadBytes > 0 do
    begin
      Stream.Write(Buffer, ReadBytes);
      ReadBytes := FDataStream.Read(Buffer, SizeOf(Buffer));
    end;
  end;
end;

procedure TMetafileList.LoadFromFile(const FileName: String);
var
  FileStream: TFileStream;
begin
  FileStream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  try
    LoadFromStream(FileStream);
  finally
    FileStream.Free;
  end;
end;

procedure TMetafileList.SaveToFile(const FileName: String);
var
  FileStream: TFileStream;
begin
  FileStream := TFileStream.Create(FileName, fmCreate or fmShareExclusive);
  try
    SaveToStream(FileStream);
  finally
    FileStream.Free;
  end;
end;

function TMetafileList.GetCount: Integer;
begin
  Result := FRecords.Count;
end;

function TMetafileList.GetItems(Index: Integer): TMetafile;
begin
  LoadedIndex := Index;
  Result := FLoadedMetafile;
end;

procedure TMetafileList.SetLoadedIndex(Value: Integer);
begin
  if FLoadedIndex <> Value then
  begin
    FLoadedMetafile.OnChange := nil;
    try
      FDataStream.Seek(Integer(FRecords[Value]), soFromBeginning);
      FLoadedMetafile.LoadFromStream(FDataStream);
      FLoadedIndex := Value;
    finally
      FLoadedMetafile.OnChange := MetafileChanged;
    end;
  end;
end;

procedure TMetafileList.SetUseTempFile(Value: Boolean);
var
  NewStream: TStream;
begin
  if FUseTempFile <> Value then
  begin
    FUseTempFile := Value;
    if Assigned(FDataStream) then
    begin