Растягивание изображения

Материал из DRKB


Я пишу программу, которая печатает изображение на принтере с помощью объекта TPrinter. Проблема происходит когда я пытаюсь "растянуть" изображение до требуемого размера на бумаге. Мой метод растяжения (BitBlts и принтерном DC) приводит к белым кляксам, а само изображение получается практически серым. Конечно это не то, что мне хотелось. Кто-нибудь может мне помочь?

Попробуй это:

procedure DrawImage(Canvas: TCanvas; DestRect: TRect; ABitmap: TBitmap);
var
  Header, Bits: Pointer;
  HeaderSize: Integer;
  BitsSize: Longint;
begin
  GetDIBSizes(ABitmap.Handle, HeaderSize, BitsSize);
  Header := MemAlloc(HeaderSize);
  Bits := MemAlloc(BitsSize);
  try
    GetDIB(ABitmap.Handle, ABitmap.Palette, Header^, Bits^);
    StretchDIBits(Canvas.Handle, DestRect.Left, DestRect.Top,
      DestRect.Right, DestRect.Bottom,
      0, 0, ABitmap.Width, ABitmap.Height, Bits, TBitmapInfo(Header^),
      DIB_RGB_COLORS, SRCCOPY);
    { вам может понадобиться цветовой стандарт DIB_PAL_COLORS,
      но это уже выходит за рамки моих знаний. }
  finally
    MemFree(Header, HeaderSize);
    MemFree(Bits, BitsSize);
  end;
end;

{ Печатаем изображение, растягивая его до целого листа }
procedure PrintBitmap(ABitmap: TBitmap);
var
  RelHeight, RelWidth: Integer;
begin
  Screen.Cursor := crHourglass;
  Printer.BeginDoc;
  if ((ABitmap.width / ABitmap.height) > (Printer.PageWidth / Printer.PageHeight)) then
  begin
    { Растягиваем ширину изображения до ширины бумаги }
    RelWidth := Printer.PageWidth;
    RelHeight := MulDiv(ABitmap.Height, Printer.PageWidth, ABitmap.Width);
  end
  else
  begin
    { Растягиваем высоту изображения до высоты бумаги }
    RelWidth := MulDiv(ABitmap.Width, Printer.PageHeight, ABitmap.Height);
    RelHeight := Printer.PageHeight;
  end;
  DrawImage(Printer.Canvas, Rect(0, 0, RelWidth, RelHeight), ABitmap);
  Printer.EndDoc;
  Screen.Cursor := crDefault;
end;


Source: Взято из Советов по Delphi от Валентина Озерова
ID: 03237


См. также[править | править код]