unit1.pas

本程序是用Delphi开发的打印表单程序,简单易懂,好用

unit Unit1;

interface

uses
  Windows, SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Variants,
  Controls, Forms, Dialogs, StdCtrls, ExtCtrls, jpeg; 

type
  TForm1 = class(TForm)
    Button1: TButton;
    Image1: TImage;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses Printers;

procedure TForm1.Button1Click(Sender: TObject);
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 := GetDc(0);              //获得屏幕的设备描述表
  MemDc := CreateCompatibleDc(dc);    //  创建兼容的设备描述表
  MemBitmap := CreateCompatibleBitmap(Dc,form1.width,form1.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;

   //将屏幕内容拷贝到内存设备描述表中或位图中
   BitBlt(MemDc,
         0, 0,
         form1.width, form1.height,
         Dc,
         form1.left, form1.top,
         SrcCopy);

  if isDcPalDevice = true then
  begin
    SelectPalette(MemDc, OldPal, false);
    DeleteObject(Pal);
  end;

  SelectObject(MemDc, OldMemBitmap);   //取消对位图的选择
  DeleteDc(MemDc);  //删除内存设备描述表
  //为一个DIB结构分配内存
  hDibHeader := GlobalAlloc(GHND,sizeof(TBITMAPINFO)+(sizeof(TRGBQUAD) * 256));
  pDibHeader := GlobalLock(hDibHeader);   //获得指向分配内存的指针

   //使用DIB使用的信息来添加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 := form1.width;
  PBITMAPINFOHEADER(pDibHeader)^.biHeight := form1.height;
  PBITMAPINFOHEADER(pDibHeader)^.biCompression := BI_RGB;

   //找出这些位使用了多少内存
  GetDIBits(dc,
            MemBitmap,
            0,
            form1.height,
            nil,
            TBitmapInfo(pDibHeader^),
            DIB_RGB_COLORS);

    //为这些位分配内存
  hBits := GlobalAlloc(GHND, PBitmapInfoHeader(pDibHeader)^.BiSizeImage);
   //获得指向这些位的指针
  pBits := GlobalLock(hBits);

   //再次调用fn，并给出这些位
  GetDIBits(dc,
            MemBitmap,
            0,
            form1.height,
            pBits,
            PBitmapInfo(pDibHeader)^,
            DIB_RGB_COLORS);

   //尽量修正已经破坏的视频设备驱动程序
  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;

  ReleaseDc(0, dc);           //释放设备描述表
  DeleteObject(MemBitmap);    //删除位图

  Printer.BeginDoc;           //开始打印

  if Printer.PageWidth < Printer.PageHeight then      //调整打印大小
  begin
   ScaleX := Printer.PageWidth;
   ScaleY := Form1.Height * (Printer.PageWidth / Form1.Width);
  end else
  begin
   ScaleX := Form1.Width * (Printer.PageHeight / Form1.Height);
   ScaleY := Printer.PageHeight;
  end;

   //当打印机驱动程序是一个调色板设备时，下面的代码才起作用
  isDcPalDevice := false;
  if GetDeviceCaps(Printer.Canvas.Handle, RASTERCAPS) and
      RC_PALETTE = RC_PALETTE then
  begin
   //为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;

   //向打印机发送这些位
  StretchDiBits(Printer.Canvas.Handle,
                0, 0,
                Round(scaleX), Round(scaleY),
                0, 0,
                Form1.Width, Form1.Height,
                pBits,
                PBitmapInfo(pDibHeader)^,
                DIB_RGB_COLORS,
                SRCCOPY);

  if isDcPalDevice = true then
  begin
    SelectPalette(Printer.Canvas.Handle, oldPal, false);
    DeleteObject(Pal);
  end;

  //释放分配的内存
  GlobalUnlock(hBits);
  GlobalFree(hBits);
  GlobalUnlock(hDibHeader);
  GlobalFree(hDibHeader);

  //终止打印机的工作
  Printer.EndDoc;
end;

end.