打印窗体
{打印 form1,没有边框和标题栏}
procedure TForm1.Button1Click(Sender: TObject);
begin
Form1.Print;
end;
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
{取屏幕dc}
dc := GetDc(0);
MemDc := CreateCompatibleDc(dc);
{创建位图}
MemBitmap := CreateCompatibleBitmap(Dc,
AForm.Width,
AForm.Height);
OldMemBitmap := SelectObject(MemDc, MemBitmap);
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;
Delphi开发技巧之-打印
4星 · 超过85%的资源 需积分: 9 48 浏览量
2010-02-04
10:23:01
上传
评论
收藏 15KB RAR 举报
xuhao1
- 粉丝: 1
- 资源: 68
最新资源
- 基于CarNet实现裂缝检测python源码+文档说明+数据+图片(课程设计)
- 课程设计-基于耐火材料裂缝剥落检测python源码+课件
- 基于OpenCV的视频道路车道检测python源码+文档说明+实验演示+图片+使用方法(高分毕业设计)
- 基于OpenCV的案例:图像边缘、角点和轮廓检测,图像分割,图像增强;图片拼接;运动目标检测,颜色直方图比较,三帧帧差法,抠图
- SmartPlug-html大一笔记
- SmartPlug-proteusdemo
- Preliminary Findings on Handmade Rattan Baby Crib andBassinet Designs Regarding.zip
- aveebfq_v1.2.83_downyi.com.apk
- 基于有机发光二极管(OLED)的建模优化算法的matlab仿真源码+数据+文档说明+项目说明(高分课程设计)
- hash01-test.c 本人哈希表(一)的示例代码,仅供参考!
资源上传下载、课程学习等过程中有任何疑问或建议,欢迎提出宝贵意见哦~我们会及时处理!
点击此处反馈