Delphi开发技巧之－打印

打印窗体 {打印 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;