Масштабирование через StrechDraw

[AnTe]

Здравствуйте. Мне понадобилось вывести изображение и подписанный внизу текст (а может потом ещё что-нибудь, из инструментария Tcanvas) - на экран, а, затем на принтер.

Я написал абстрактную процедуру, которая выводит на канву, исходя из размеров 21000*29700 (формат А4 в сотых долях миллиметра), она мне рисует всё, что нужно.

На форму положил Timage, процедурой рисую на канву созданного метафайла, его растягиваю на Timage - результат ужасный!

Для вывода на принтер - отдельная процедура, в ней изменяются параметры системы координат, и всё выводится прекрасно.

procedure TfmTest.btnGoClick(Sender: TObject);
var
  MF: TMetafile;
  MC: TMetafileCanvas;
begin
  MF := TMetafile.Create;
  try
    MF.Width := 21000;
    MF.Height := 29700;
    MC := TMetafileCanvas.Create(MF, 0);
    try
      {DrawToCanvas(MC); ** процедура вывода заменена, для теста, строками вывода текста}
      MC.Font.Height := 8000;
      MC.TextOut(1000, 1000, 'Test');
    finally
      MC.Free;
    end;

{********* вывод на экран, растягиванием на image}
    image1.Canvas.StretchDraw(image1.ClientRect, MF);
    
{********* вывод на принтер - процедура в следующем посте}
MetafilePrint(MF);

  finally
    MF.Free;
  end;
end;

Результат вывода в TImage ужасен ! Почему? Можно ли это побороть?

[AnTe]

Процедура для вывода на принтер:

procedure TMainForm.MetafilePrint(MF: TMetafile);
var
  pagewidth, pageheight: Double; {printer page dimension in inch}
  pagewidthPix, pageheightPix: Double; {printer page dimension in Pix}
  printerResX, printerResY: Integer; {printer resolution in dots/inch}
  minmarginX, minmarginY: Double; {nonprintable margin in inch}
  minmarginXpix, minmarginYpix: integer; {nonprintable margin in inch}
  outputarea: TRect; {print area in 1/1000 inches}
begin
  Printer.Orientation := poPortrait;
  {Printer.Orientation := poLandscape; }

  printerResX := GetDeviceCaps(printer.handle, LOGPIXELSX);
  printerResY := GetDeviceCaps(printer.handle, LOGPIXELSY);
  pagewidth := GetDeviceCaps(printer.handle, PHYSICALWIDTH) / printerResX;
  pageheight := GetDeviceCaps(printer.handle, PHYSICALHEIGHT) / printerResY;
  pagewidthPix := GetDeviceCaps(printer.handle, PHYSICALWIDTH);
  pageheightPix := GetDeviceCaps(printer.handle, PHYSICALHEIGHT);
  minmarginX := GetDeviceCaps(printer.handle, PHYSICALOFFSETX) / printerResX;
  minmarginY := GetDeviceCaps(printer.handle, PHYSICALOFFSETY) / printerResY;
  minmarginXpix := GetDeviceCaps(printer.handle, PHYSICALOFFSETX);
  minmarginYpix := GetDeviceCaps(printer.handle, PHYSICALOFFSETY);


  outputarea.Left := -minmarginXpix;
  outputarea.Top := -minmarginYpix;
  outputarea.Right := round(pagewidthPix) + minmarginXpix;
  outputarea.Bottom := round(pageheightPix) + minmarginXpix;

  with Printer do
  begin
    BeginDoc;
    try
      Canvas.StretchDraw(outputarea, MF);
    finally
      Enddoc
    end;
  end;
end;

Здесь изменяется система координат, посредством АПИ, пример содран из кода для предпросмотра.

Но я уже напарывался на то, что изменяя систему координат для делфёвых компонент - можно огрести кучу проблем. Или другого пути нет?

[BOBAH13]

Я бы использовал GDI+.... выводим текст с антиалиасингом, а так же если скорость не важна, можно еще и картинку с бикубическом интерполяцией вывести. Тогда результат просто удивит вас ну и порадует. Могу привести пример

[AnTe]

Сообщение от BOBAH13

Я бы использовал GDI+.... выводим текст с антиалиасингом, а так же если скорость не важна, можно еще и картинку с бикубическом интерполяцией вывести. Тогда результат просто удивит вас ну и порадует. Могу привести пример

Если не затруднит, приведите, пожалуйста! Вся логика моей программы заведена на этих процедурах вывода на канву с огромным разрешением, и тут такой затык....

[mutabor]

Попробуйте вин апи функцию StretchBlt, она дает лучший результат, чем Дельфи функции. Смотрите в этой теме
http://www.programmersforum.ru/showt...ht=StretchDraw

[BOBAH13]

Ну как ? Мне кажется допустимо :D
p.s. mutabor: врятли GDI сравнится с GDI+

var
 { MF: TMetafile;
  MC: TMetafileCanvas;   }
  Bmp: GpBitmap;
  w, h: Integer;
  Context: GpGraphics;
  FontFamily: GpFontFamily;
  Font: GpFont;
  StringAttr: GpStringFormat;
  Brush: GpBrush;
  S: String;
  r: TGPRectF;
  k: Double;
begin
  //MF := TMetafile.Create;
 // try
    //MF.Width := 21000;
    //MF.Height := 29700;

    // пропорционально вашим размерам создадим допустимый образец
    // незнаю почему, но у меня ограничевается разрешением экрана
    k := Screen.Width / 21000;
    if (Screen.Height / 29700 < k) then
      k := Screen.Height / 29700;
    w := Round(21000 * k);
    h := Round(29700 * k);

    // Создадим образец в памяти
    GdipCreateBitmapFromScan0(w, h, w * 3, PixelFormat24bppRGB, NIL, Bmp);

    //MC := TMetafileCanvas.Create(MF, 0);

   // try
      {DrawToCanvas(MC); ** процедура вывода заменена, для теста, строками вывода текста}
     {MC.Font.Height := 8000;
      MC.TextOut(1000, 1000, 'Test');}
      // расчитаем область вывода
      r.X := 0;
      r.Y := 0;
      r.Width := w;
      r.Height := h;

      // получим контекст образца
      GdipGetImageGraphicsContext(Bmp, Context);
      // создадим белый цвет заливки
      GdipCreateSolidFill(ARGBMake($FF, $FF, $FF), Brush);
      // установим антиалиасинг для текста
      GdipSetTextRenderingHint(Context, TextRenderingHintAntiAlias);
      // создадим шрифт по имени
      GdipCreateFontFamilyFromName('Arial', NIL, FontFamily);
      // создадим непосредственно шрифт по имени FontFamily
      // высота будет половина от листа, UnitPixel, аналог для TForn - UnitPoint
      GdipCreateFont(FontFamily, h div 2, FontStyleRegular, Integer(UnitPixel), Font);
      // создадим формат отображения текста
      GdipCreateStringFormat(0, LANG_NEUTRAL, StringAttr);
      // установим выравнивание по середине, горизонталь
      GdipSetStringFormatAlign(StringAttr, StringAlignmentCenter);
      // установим выравнивание по середине, вертикаль
      GdipSetStringFormatLineAlign(StringAttr, StringAlignmentCenter);
      // наш текст S
      S := 'S';
      // зальем нашим цветом нашу поверхность
      GdipFillRectangle(Context, Brush, r.X, r.Y, r.Width, r.Height);
      // установим черный цвет для вывода текста
      GdipSetSolidFillColor(Brush, ARGBMake(0, 0, 0));
      // выведим текст
      GdipDrawString(Context, PWCHAR(WideString(S)), Length(S), Font, @r, StringAttr, Brush);
      // Освободим все ресурсы
      GdipDeleteStringFormat(StringAttr);
      GdipDeleteFont(Font);
      GdipDeleteFontFamily(FontFamily);
      GdipDeleteBrush(Brush);
      GdipDeleteGraphics(Context);
   // finally
      //MC.Free;
   // end;

{********* вывод на экран, растягиванием на image}
    //image1.Canvas.StretchDraw(image1.ClientRect, MF);

  // свяжим контекст image1.Canvas.Handle: HDC с GDI+
  GdipCreateFromHDC(Image1.Canvas.Handle, Context);
  // установим антиалиасинг для изображений
  GdipSetSmoothingMode(Context, SmoothingModeAntiAlias);
  // установим сжатие по бикубическому алгоритму
  GdipSetInterpolationMode(Context, InterpolationModeHighQualityBicubic);
  // выведим изображения исходя из нашей области
  GdipDrawImageRectRect(Context, Bmp,
    0, 0, Image1.Width, Image1.Height,
    0, 0, w, h,
    UnitPixel, NIL, NIL, NIL);
  // освободим все ресурсы
  GdipDeleteGraphics(Context);
  GdipDisposeImage(Bmp);   
    
{********* вывод на принтер - процедура в следующем посте}
// MetafilePrint(MF);

  //finally
    //MF.Free;
  //end;
end;

[AnTe]

прошу прощения за запоздалый ответ - сначала сдох комп, затем подвалила другая работа.. Вот, вернулся к проблеме.

После полудня попытки понять, что происходит моя ошибка была найдена, она оказалась совсем не те в том, что я предполагал. Смешно, конечно, но ведь в коде

      {DrawToCanvas(MC); ** процедура вывода заменена, для теста, строками вывода текста}
      MC.Font.Height := 8000;
      MC.TextOut(1000, 1000, 'Test');

отсутствует определение шрифта!

Дык, теперь вот что получается: когда я растягиваю метафайл на принтер - у принтера, оказывается, по умолчанию Arial, т.е. векторный, посему качество отменное.
Вывожу в Timage - у того ms san serif - вот "кубики" и вылазят!!! StrechDraw тут ни при чём - они есть и при банальном увеличении размера шрифта. :D

Но, не было бы счастья, так несчастье помогло: спасибо mutabor, отправившего меня по нужному адресу, и за код: действительно, StrechBlt намного лучше мастшабирует выводимые рисунки, чем делфёвый StrechDraw!!!

Вариант с использованием GDI+ мне не подходит: как я уже писал, процедуры вывода на Canvas у меня уже написаны, на них вся логика программы. Судя по примеру, для использования GDI+, мне придётся всё переделывать, а это невозможно

[AnTe]

Важное замечание. К сожалению, винапишная StrechBlt не выводит метафайлы, при попытке растянуть метафайл, на Timage, получаю белый лист

procedure TfmTest.btnGoClick(Sender: TObject);
var
  MF: TMetafile;
  MC: TMetafileCanvas;
begin
  MF := TMetafile.Create;
  try
    MF.Width := 21000;
    MF.Height := 29700;
    MC := TMetafileCanvas.Create(MF, 0);
    try
      MC.Font.Name := 'Arial';
      MC.Font.Height := 8000;
      MC.TextOut(1000, 20000, 'Test');
    finally
      MC.Free;
    end;

{********* вывод на экран, растягиванием на image}
//    image1.Canvas.StretchDraw(image1.ClientRect, MF); - заменил на StrechBlt, и пример перестал работать :(

     SetStretchBltMode(image1.Canvas.handle, HALFTONE);
      StretchBlt(image1.Canvas.handle, 0, 0, image1.ClientWidth , image1.ClientHeight, MF.handle, 0, 0, 21000, 29700, SRCCOPY);
{*********}

  finally
    MF.Free;
  end;
end;

[BOBAH13]

Какие же мы не внимательные... почему вы не читаите комменты в коде который я привел ?

// пропорционально вашим размерам создадим допустимый образец
// незнаю почему, но у меня ограничевается разрешением экрана

Поэтому белый лист.... ВНИМАТЕЛЬНО ЧИТАЙТЕ, и сначала 100 раз попробоуйте а потом пишите что не выходит

[AnTe]

Сообщение от BOBAH13

Какие же мы не внимательные... почему вы не читаите комменты в коде который я привел ?

..

Поэтому белый лист.... ВНИМАТЕЛЬНО ЧИТАЙТЕ, и сначала 100 раз попробоуйте а потом пишите что не выходит

Вова, внимательно читайте я не использовал Ваш пример, т.к. он мне, к сожалению, не подходит изначально

у меня уже написаны процедуры, которые выводят нужный рисунок на делфёвый Canvas, более того, все координаты выводе в хайметриках, т.е. сотых долях миллиметра.