Печать всей формы 2Delphi , ОС и Железо , Принтеры и ПечатьПечать всей формы 2
Оформил: DeeCo { 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; Статья Печать всей формы 2 раздела ОС и Железо Принтеры и Печать может быть полезна для разработчиков на Delphi и FreePascal. Комментарии и вопросыМатериалы статей собраны из открытых источников, владелец сайта не претендует на авторство. Там где авторство установить не удалось, материал подаётся без имени автора. В случае если Вы считаете, что Ваши права нарушены, пожалуйста, свяжитесь с владельцем сайта. :: Главная :: Принтеры и Печать ::
|
||||
©KANSoftWare (разработка программного обеспечения, создание программ, создание интерактивных сайтов), 2007 |