Валентин Озеров - Советы по Delphi. Версия 1.4.3 от 1.1.2001

  begin

   if Picture.Bitmap<>nil then begin

    with Printer, Canvas do begin

     Bits := Picture.Bitmap.Handle;

     GetDIBSizes(Bits, InfoSize, ImageSize);

     Info := AllocMem(InfoSize);

     try

      Image := AllocMem(ImageSize);

      try

       GetDIB(Bits, 0, Info^, Image^);

       with Info^.bmiHeader do begin

        DIBWidth := biWidth;

        DIBHeight := biHeight;

       end;

       PrintWidth := DIBWidth;

       PrintHeight := DIBHeight;

       StretchDIBits(Canvas.Handle, aLeft, aTop, PrintWidth, PrintHeight, 0, 0, DIBWidth, DIBHeight, Image, Info^, DIB_RGB_COLORS, SRCCOPY);

      finally

       FreeMem(Image, ImageSize);

      end;

     finally

      FreeMem(Info, InfoSize);

     end;

    end;

   end;

  end;

 end;

В чем заключается идея PreView? Остается имея на руках Metafila, Bmp – отрисовать с пересчетом внешний вид изобpажения (надо высчитать левый верхний угол и размеpы «предварительно просматриваемого» изображения. Для показа изобpажения достаточно использовать StretchDraw.

После того, как удалось вывести объекты на печать, проблему создания PreView решили как «домашнее задание».

Кстати, когда мы работаем с Bmp, то для просмотра используем следующий хинт – записываем битовый образ через такую процедуру:

w:=MulDiv(Bmp.Width, GetDeviceCaps(Printer.Handle,LOGPIXELSX), Screen.PixelsPerInch);

h:=MulDiv(Bmp.Height, GetDeviceCaps(Printer.Handle,LOGPIXELSY), Screen.PixelsPerInch);

PrevBmp.Width:=w;

PrevBmp.Height:=h;

PrevBmp.Canvas.StretchDraw(Rect(0, 0, w, h),Bmp);

aPicture.Assign(PrevBmp);

Пpи этом масштабируется битовый образ с минимальными искажениями, а вот при печати – приходится bmp печатать именно так, как описано выше. Итог – наша bmp при печати чуть меньше, чем печатать ее через WinWord, но при этом – внешне – без каких-либо искажений и пр.

Imho, я для себя пpоблему печати pешил. Hа основе вышесказанного, сделал PreView для myStringGrid, где вывожу сложные многостpочные заголовки и пр. на несколько листов, осталось кое-что допилить, но с принтером у меня проблем не будет уже точно :)

PS. Кстати, Андрей Аристов на основе своей наработки сделал сложные геокарты, которые по качеству не хуже, а может, и лучше, чем выдает Surfer (специалисты поймут). Hа ватмат.

PPS. Прошу прощения за возможные стилистические неточности – время вышло, охрана уже ругается. Но код – выдран из работающих исходников.

Serj Kolesnikov рекомендует:

=== Cut ===

 mov ax,5301h

 sub bx,bx

 int 15h

 jc @@finish

 mov ax,530Eh

 sub bx,bx

 mov cx,102h

 int 15h

 jc @@finish

 mov ax,5307h

 mov bx,1

 mov cx,3

 int 15h

@@finish:

 int 20h

=== Cut ===

Из советов Nomadic'a:

Используя потоки —

unit ClipStrm;

{

 This unit is Copyright (c) Alexey Mahotkin 1997-1998

 and may be used freely for any purpose. Please mail

 your comments to

 E-Mail: [email protected]

 FidoNet: Alexey Mahotkin, 2:5020/433

 This unit was developed during incorporating of TP Lex/Yacc

 into my project. Please visit ftp://ftp.nf.ru/pub/alexm

 or FREQ FILES from 2:5020/433 or mail me to get hacked

 version of TP Lex/Yacc which works under Delphi 2.0+.

}

interface uses Classes, Windows;

type TClipboardStream = class(TStream)

private

 FMemory : pointer;

 FSize : longint;

 FPosition : longint;

 FFormat : word;

public

 constructor Create(fmt : word);

 destructor Destroy; override;

 function Read(var Buffer; Count : Longint) : Longint; override;

 function Write(const Buffer; Count : Longint) : Longint; override;

 function Seek(Offset : Longint; Origin : Word) : Longint; override;

end;

implementation uses SysUtils;

constructor TClipboardStream.Create(fmt : word);

var

 tmp : pointer;

 FHandle : THandle;

begin

 FFormat := fmt;

 OpenClipboard(0);

 FHandle := GetClipboardData(FFormat);

 FSize := GlobalSize(FHandle);

 FMemory := AllocMem(FSize);

 tmp := GlobalLock(FHandle);

 MoveMemory(FMemory, tmp, FSize);

 GlobalUnlock(FHandle);

 FPosition := 0;

 CloseClipboard;

end;

destructor TClipboardStream.Destroy;

begin

 FreeMem(FMemory);

end;

function TClipboardStream.Read(var Buffer; Count : longint) : longint;

begin

 if FPosition + Count > FSize then Result := FSize - FPosition

 else Result := Count;

 MoveMemory(@Buffer, PChar(FMemory) + FPosition, Result);

 Inc(FPosition, Result);

end;

function TClipboardStream.Write(const Buffer; Count : longint) : longint;

var

 FHandle : HGlobal;

 tmp : pointer;

begin

 ReallocMem(FMemory, FPosition + Count);

 MoveMemory(PChar(FMemory) + FPosition, @Buffer, Count);

 FPosition := FPosition + Count;

 FSize := FPosition;

 FHandle := GlobalAlloc(GMEM_MOVEABLE or GMEM_SHARE or GMEM_ZEROINIT, FSize);

 try

  tmp := GlobalLock(FHandle);

  try

   MoveMemory(tmp, FMemory, FSize);

   OpenClipboard(0);

   SetClipboardData(FFormat, FHandle);

  finally

   GlobalUnlock(FHandle);

  end;

  CloseClipboard;

 except

  GlobalFree(FHandle);

 end;

 Result := Count;

end;

function TClipboardStream.Seek(Offset : Longint; Origin : Word) : Longint;

begin

 case Origin of

 0 : FPosition := Offset;

 1 : Inc(FPosition, Offset);

 2 : FPosition := FSize + Offset;

 end;

 Result := FPosition;

end;

end. 

Как мне сохранить свойство шрифта Style, ведь он же набор?

Вы можете получать и устанавливать FontStyle через его преобразование к типу byte.

Для примера,

Var Style: TFontStyles;

begin

 { Сохраняем стиль шрифта в байте }

 Style := Canvas.Font.Style; {необходимо, поскольку Font.Style – свойство}

 ByteValue := Byte(Style);

 { Преобразуем значение byte в TFontStyles }

 Canvas.Font.Style := TFontStyles(ByteValue);

end;

Для восстановления шрифта, вам необходимо сохранить параметры Color, Name, Pitch, Style и Size в базе данных и назначить их соответствующим свойствам при загрузке.

– Robert Wittig

{

 Данный код изменяет стиль шрифта поля редактирования,

 если оно выбрано. Может быть адаприрован для управления

 шрифтами в других объектах.

 Расположите на форме Edit(Edit1) и ListBox(ListBox1).

 Добавьте следующие элементы (Items) к ListBox:

  fsBold

  fsItalic

  fsUnderLine

  fsStrikeOut

}

procedure TForm1.ListBox1Click(Sender: TObject);

var X: Integer;

type TLookUpRec = record

 Name: String;

 Data: TFontStyle;

end;

const LookUpTable: array[1..4] of TLookUpRec = (

 (Name: 'fsBold'; Data: fsBold),

 (Name: 'fsItalic'; Data: fsItalic),

 (Name: 'fsUnderline'; Data: fsUnderline),

 (Name: 'fsStrikeOut'; Data: fsStrikeOut));

begin

 X := ListBox1.ItemIndex;

 Edit1.Text := ListBox1.Items[X];

 Edit1.Font.Style := [LookUpTable[ListBox1.ItemIndex+1].Data];

end;

Из советов Nomadic'a:

Развлекался когда-то — вот, осталось:

unit Unit1;

interface

uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ShellAPI, Grids, StdCtrls;

Похожие книги на "Советы по Delphi. Версия 1.4.3 от 1.1.2001", Валентин Озеров читать полностью, без сокращений.

C. Бочков - Язык

Михаил Шохирев - Язык

Роман Сузи - Язык

Нейл Мэтью - Основы

Мюррей Хилл - C++