Первый вариант: (http://www.swissdelphicenter.ch)
| Код |
{
Dieser Code druckt den Inhalt einer Form aus.
Jedoch ohne Rand und Titelleiste.
This code prints out form1. Without border and caption bar.
Print uses the GetFormImage method to obtain a bitmap of the form and
draws that to the printer’s HDC.
}
procedure TForm1.Button1Click(Sender: TObject);
begin
Form1.Print;
end;
{
The following TI details a better way to print the contents of
a form, by getting the device independent bits in 256 colors
from the form, and using those bits to print the form to the
printer.
In addition, a check is made to see if the screen or printer
is a palette device, and if so, palette handling for the device
is enabled. If the screen device is a palette device, an additional
step is taken to fill the bitmap's palette from the system palette,
overcoming some buggy video drivers who don't fill the palette in.
Note: Since this code does a screen shot of the form, the form must
be the topmost window and the whole from must be viewable when the
form shot is made.
Copyright by SWAG SUPPORT TEAM
http://gdsoft.com/swag/swag.html
}
procedure PrintForm(AForm: TForm; BorderWidth: Integer);
var
dc: HDC;
isDcPalDevice: BOOL;
MemDc: hdc;
MemBitmap: hBitmap;
OldMemBitmap: hBitmap;
hDibHeader: THandle;
pDibHeader: Pointer;
hBits: THandle;
pBits: Pointer;
ScaleX: Double;
ScaleY: Double;
ppal: PLOGPALETTE;
pal: hPalette;
Oldpal: hPalette;
i: Integer;
begin
{Get the screen dc}
dc := GetDc(0);
{Create a compatible dc}
MemDc := CreateCompatibleDc(dc);
{create a bitmap}
MemBitmap := CreateCompatibleBitmap(Dc,
AForm.Width,
AForm.Height);
{select the bitmap into the dc}
OldMemBitmap := SelectObject(MemDc, MemBitmap);
{Lets prepare to try a fixup for broken video drivers}
isDcPalDevice := False;
if GetDeviceCaps(dc, RASTERCAPS) and
RC_PALETTE = RC_PALETTE then
begin
GetMem(pPal, SizeOf(TLOGPALETTE) +
(255 * SizeOf(TPALETTEENTRY)));
FillChar(pPal^, SizeOf(TLOGPALETTE) +
(255 * SizeOf(TPALETTEENTRY)), #0);
pPal^.palVersion := $300;
pPal^.palNumEntries :=
GetSystemPaletteEntries(dc,
0,
256,
pPal^.palPalEntry);
if pPal^.PalNumEntries <> 0 then
begin
pal := CreatePalette(pPal^);
oldPal := SelectPalette(MemDc, Pal, False);
isDcPalDevice := True
end
else
FreeMem(pPal, SizeOf(TLOGPALETTE) +
(255 * SizeOf(TPALETTEENTRY)));
end;
{copy from the screen to the memdc/bitmap}
BitBlt(MemDc,
0, 0,
AForm.Width, AForm.Height,
Dc,
AForm.Left, AForm.Top,
SrcCopy);
if isDcPalDevice = True then
begin
SelectPalette(MemDc, OldPal, False);
DeleteObject(Pal);
end;
{unselect the bitmap}
SelectObject(MemDc, OldMemBitmap);
{delete the memory dc}
DeleteDc(MemDc);
{Allocate memory for a DIB structure}
hDibHeader := GlobalAlloc(GHND,
SizeOf(TBITMAPINFO) +
(SizeOf(TRGBQUAD) * 256));
{get a pointer to the alloced memory}
pDibHeader := GlobalLock(hDibHeader);
{fill in the dib structure with info on the way we want the DIB}
FillChar(pDibHeader^,
SizeOf(TBITMAPINFO) + (SizeOf(TRGBQUAD) * 256),
#0);
PBITMAPINFOHEADER(pDibHeader)^.biSize :=
SizeOf(TBITMAPINFOHEADER);
PBITMAPINFOHEADER(pDibHeader)^.biPlanes := 1;
PBITMAPINFOHEADER(pDibHeader)^.biBitCount := 8;
PBITMAPINFOHEADER(pDibHeader)^.biWidth := AForm.Width;
PBITMAPINFOHEADER(pDibHeader)^.biHeight := AForm.Height;
PBITMAPINFOHEADER(pDibHeader)^.biCompression := BI_RGB;
{find out how much memory for the bits}
GetDIBits(dc,
MemBitmap,
0,
AForm.Height,
nil,
TBitmapInfo(pDibHeader^),
DIB_RGB_COLORS);
{Alloc memory for the bits}
hBits := GlobalAlloc(GHND,
PBitmapInfoHeader(pDibHeader)^.BiSizeImage);
{Get a pointer to the bits}
pBits := GlobalLock(hBits);
{Call fn again, but this time give us the bits!}
GetDIBits(dc,
MemBitmap,
0,
AForm.Height,
pBits,
PBitmapInfo(pDibHeader)^,
DIB_RGB_COLORS);
{Lets try a fixup for broken video drivers}
if isDcPalDevice = True then
begin
for i := 0 to (pPal^.PalNumEntries - 1) do
begin
PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed :=
pPal^.palPalEntry[i].peRed;
PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen :=
pPal^.palPalEntry[i].peGreen;
PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue :=
pPal^.palPalEntry[i].peBlue;
end;
FreeMem(pPal, SizeOf(TLOGPALETTE) +
(255 * SizeOf(TPALETTEENTRY)));
end;
{Release the screen dc}
ReleaseDc(0, dc);
{Delete the bitmap}
DeleteObject(MemBitmap);
{Start print job}
Printer.BeginDoc;
{Scale print size}
if Printer.PageWidth < Printer.PageHeight then
begin
ScaleX := Printer.PageWidth;
ScaleY := AForm.Height * (Printer.PageWidth / AForm.Width);
end
else
begin
ScaleX := AForm.Width * (Printer.PageHeight / AForm.Height);
ScaleY := Printer.PageHeight;
end;
{Just incase the printer drver is a palette device}
isDcPalDevice := False;
if GetDeviceCaps(Printer.Canvas.Handle, RASTERCAPS) and
RC_PALETTE = RC_PALETTE then
begin
{Create palette from dib}
GetMem(pPal, SizeOf(TLOGPALETTE) +
(255 * SizeOf(TPALETTEENTRY)));
FillChar(pPal^, SizeOf(TLOGPALETTE) +
(255 * SizeOf(TPALETTEENTRY)), #0);
pPal^.palVersion := $300;
pPal^.palNumEntries := 256;
for i := 0 to (pPal^.PalNumEntries - 1) do
begin
pPal^.palPalEntry[i].peRed :=
PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed;
pPal^.palPalEntry[i].peGreen :=
PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen;
pPal^.palPalEntry[i].peBlue :=
PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue;
end;
pal := CreatePalette(pPal^);
FreeMem(pPal, SizeOf(TLOGPALETTE) +
(255 * SizeOf(TPALETTEENTRY)));
oldPal := SelectPalette(Printer.Canvas.Handle, Pal, False);
isDcPalDevice := True
end;
{send the bits to the printer}
StretchDiBits(Printer.Canvas.Handle,
BorderWidth, BorderWidth,
Round(scaleX)-BorderWidth, Round(scaleY)-BorderWidth,
0, 0,
AForm.Width, AForm.Height,
pBits,
PBitmapInfo(pDibHeader)^,
DIB_RGB_COLORS,
SRCCOPY);
RotateBitmap(var hDIB: HGlobal; 180; clWhite);
{Just incase you printer drver is a palette device}
if isDcPalDevice = True then
begin
SelectPalette(Printer.Canvas.Handle, oldPal, False);
DeleteObject(Pal);
end;
{Clean up allocated memory}
GlobalUnlock(hBits);
GlobalFree(hBits);
GlobalUnlock(hDibHeader);
GlobalFree(hDibHeader);
{End the print job}
Printer.EndDoc;
end;
|
Второй вариант:
| Код |
unit PrintF;
{Печатает TLabel, TEdit, TMemo, TStringGrid, TShape и др. DB-компоненты.
Установите Form H & V ScrollBar.Ranges на 768X1008 для страницы 8X10.5.
Примечание: это не компонент. Успехов. Bill}
interface
uses
SysUtils, WinTypes, WinProcs, Classes, Graphics, Controls,
Forms, Grids, Printers, StdCtrls, ExtCtrls, Mask;
function PrintForm(AForm: TForm; ATag: Longint): integer;
{используйте: PrintForm(Form2, 0);
AForm - форма, которую необходимо напечатать. Если вы, к примеру,
печатаете Form2 из обработчика события Form1, то используйте Unit2
в списке используемых модулей в секции implementation молуля Unit1.
ATag - поле Tag компонента, который необходимо печатать или 0 для всех.
Если Tag компонента равен 14 (2+4+8), он буден напечатан в случае,
когда ATag равен 0, 2, 4 или 8.
Функция возвращает количество напечатанных компонентов. }
implementation
var
ScaleX, ScaleY, I, Count: integer;
DC: HDC;
F: TForm;
function ScaleToPrinter(R: TRect): TRect;
begin
R.Top := (R.Top + F.VertScrollBar.Position) * ScaleY;
R.Left := (R.Left + F.HorzScrollBar.Position) * ScaleX;
R.Bottom := (R.Bottom + F.VertScrollBar.Position) * ScaleY;
R.Right := (R.Right + F.HorzScrollBar.Position) * ScaleY;
Result := R;
end;
procedure PrintMComponent(MC: TMemo);
var
C: array[0..255] of char;
CLen: integer;
Format: Word;
R: TRect;
begin
Printer.Canvas.Font := MC.Font;
DC := Printer.Canvas.Handle; {так DrawText знает о шрифте}
R := ScaleToPrinter(MC.BoundsRect);
if (not (F.Components[I] is TCustomLabel)) and (MC.BorderStyle = bsSingle)
then
Printer.Canvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);
Format := DT_LEFT;
if (F.Components[I] is TEdit) or (F.Components[I] is TCustomMaskEdit) then
Format := Format or DT_SINGLELINE or DT_VCENTER
else
begin
if MC.WordWrap then
Format := DT_WORDBREAK;
if MC.Alignment = taCenter then
Format := Format or DT_CENTER;
if MC.Alignment = taRightJustify then
Format := Format or DT_RIGHT;
R.Bottom := R.Bottom + Printer.Canvas.Font.Height;
end;
CLen := MC.GetTextBuf(C, 255);
R.Left := R.Left + ScaleX + ScaleX;
WinProcs.DrawText(DC, C, CLen, R, Format);
inc(Count);
end;
procedure PrintShape(SC: TShape);
var
H, W, S: integer;
R: TRect;
begin {PrintShape}
Printer.Canvas.Pen := SC.Pen;
Printer.Canvas.Pen.Width := Printer.Canvas.Pen.Width * ScaleX;
Printer.Canvas.Brush := SC.Brush;
R := ScaleToPrinter(SC.BoundsRect);
W := R.Right - R.Left;
H := R.Bottom - R.Top;
if W < H then
S := W
else
S := H;
if SC.Shape in [stSquare, stRoundSquare, stCircle] then
begin
Inc(R.Left, (W - S) div 2);
Inc(R.Top, (H - S) div 2);
W := S;
H := S;
end;
case SC.Shape of
stRectangle, stSquare:
Printer.Canvas.Rectangle(R.Left, R.Top, R.Left + W, R.Top + H);
stRoundRect, stRoundSquare:
Printer.Canvas.RoundRect(R.Left, R.Top, R.Left + W, R.Top + H, S div 4, S
div 4);
stCircle, stEllipse:
Printer.Canvas.Ellipse(R.Left, R.Top, R.Left + W, R.Top + H);
end;
Printer.Canvas.Pen.Width := ScaleX;
Printer.Canvas.Brush.Style := bsClear;
inc(Count);
end; {PrintShape}
procedure PrintSGrid(SGC: TStringGrid);
var
J, K: integer;
Q, R: TRect;
Format: Word;
C: array[0..255] of char;
CLen: integer;
begin
Printer.Canvas.Font := SGC.Font;
DC := Printer.Canvas.Handle; {так DrawText знает о шрифте}
Format := DT_SINGLELINE or DT_VCENTER;
Q := SGC.BoundsRect;
Printer.Canvas.Pen.Width := SGC.GridLineWidth * ScaleX;
for J := 0 to SGC.ColCount - 1 do
for K := 0 to SGC.RowCount - 1 do
begin
R := SGC.CellRect(J, K);
if R.Right > R.Left then
begin
R.Left := R.Left + Q.Left;
R.Right := R.Right + Q.Left + SGC.GridLineWidth;
R.Top := R.Top + Q.Top;
R.Bottom := R.Bottom + Q.Top + SGC.GridLineWidth;
R := ScaleToPrinter(R);
if (J < SGC.FixedCols) or (K < SGC.FixedRows) then
Printer.Canvas.Brush.Color := SGC.FixedColor
else
Printer.Canvas.Brush.Style := bsClear;
if SGC.GridLineWidth > 0 then
Printer.Canvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);
StrPCopy(C, SGC.Cells[J, K]);
R.Left := R.Left + ScaleX + ScaleX;
WinProcs.DrawText(DC, C, StrLen(C), R, Format);
end;
end;
Printer.Canvas.Pen.Width := ScaleX;
inc(Count);
end;
function PrintForm(AForm: TForm; ATag: Longint): integer;
begin {PrintForm}
Count := 0;
F := AForm;
Printer.BeginDoc;
try
DC := Printer.Canvas.Handle;
ScaleX := WinProcs.GetDeviceCaps(DC, LOGPIXELSX) div F.PixelsPerInch;
ScaleY := WinProcs.GetDeviceCaps(DC, LOGPIXELSY) div F.PixelsPerInch;
for I := 0 to F.ComponentCount - 1 do
if TControl(F.Components[I]).Visible then
if (ATag = 0) or (TControl(F.Components[I]).Tag and ATag = ATag) then
begin
if (F.Components[I] is TCustomLabel) or (F.Components[I] is
TCustomEdit) then
PrintMComponent(TMemo(F.Components[I]));
if (F.Components[I] is TShape) then
PrintShape(TShape(F.Components[I]));
if (F.Components[I] is TStringGrid) then
PrintSGrid(TStringGrid(F.Components[I]));
end;
finally
Printer.EndDoc;
Result := Count;
end;
end; {PrintForm}
end.
unit Rulers;
{ Добавьте в файл .DCR иконки для двух компонентов.
Успехов, Bill}
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms;
type
THRuler = class(TGraphicControl)
private
{ Private declarations }
fHRulerAlign: TAlign;
procedure SetHRulerAlign(Value: TAlign);
protected
{ Protected declarations }
procedure Paint; override;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
published
{ Published declarations }
property AlignHRuler: TAlign read fHRulerAlign write SetHRulerAlign default
alNone;
property Color default clYellow;
property Height default 33;
property Width default 768;
property Visible;
end;
type
TVRuler = class(TGraphicControl)
private
{ Private declarations }
fVRulerAlign: TAlign;
procedure SetVRulerAlign(Value: TAlign);
protected
{ Protected declarations }
procedure Paint; override;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
published
{ Published declarations }
property AlignVRuler: TAlign read fVRulerAlign write SetVRulerAlign default
alNone;
property Color default clYellow;
property Height default 1008;
property Width default 33;
property Visible;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Samples', [THRuler, TVRuler]);
end;
procedure THRuler.SetHRulerAlign(Value: TAlign);
begin
if Value in [alTop, alBottom, alNone] then
begin
fHRulerAlign := Value;
Align := Value;
end;
end;
constructor THRuler.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
AlignHRuler := alNone;
Color := clYellow;
Height := 33;
Width := 768;
end;
procedure THRuler.Paint;
var
a12th, N, X: word;
begin
a12th := Screen.PixelsPerInch div 12;
N := 0;
X := 0;
with Canvas do
begin
Brush.Color := Color;
FillRect(ClientRect);
with ClientRect do
Rectangle(Left, Top, Right, Bottom);
while X < Width do
begin
MoveTo(X, 1);
LineTo(X, 6 * (1 + byte(N mod 3 = 0) +
byte(N mod 6 = 0) +
byte(N mod 12 = 0)));
if (N > 0) and (N mod 12 = 0) then
TextOut(PenPos.X + 3, 9, IntToStr(N div 12));
N := N + 1;
X := X + a12th;
end;
end;
end;
{*********************************************}
procedure TVRuler.SetVRulerAlign(Value: TAlign);
begin
if Value in [alLeft, alRight, alNone] then
begin
fVRulerAlign := Value;
Align := Value;
end;
end;
constructor TVRuler.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
AlignVRuler := alNone;
Color := clYellow;
Height := 1008;
Width := 33;
end;
procedure TVRuler.Paint;
var
a6th, N, Y: word;
begin
a6th := Screen.PixelsPerInch div 6;
N := 0;
Y := 0;
with Canvas do
begin
Brush.Color := Color;
FillRect(ClientRect);
with ClientRect do
Rectangle(Left, Top, Right, Bottom);
while Y < Height do
begin
MoveTo(1, Y);
LineTo(6 * (2 + byte(N mod 3 = 0) +
byte(N mod 6 = 0)), Y);
if (N > 0) and (N mod 6 = 0) then
TextOut(12, PenPos.Y - 16, IntToStr(N div 6));
N := N + 1;
Y := Y + a6th;
end;
end;
end;
end.
|
|
шучу.
. Ты книжки не пишешь?