Как распечатать картинку

Советы » Принтеры и Печать » Как распечатать картинку

uses

Printers; type

PPalEntriesArray = ^TPalEntriesArray; {for palette re-construction} TPalEntriesArray = array

[0..0] of

TPaletteEntry; procedure

BltTBitmapAsDib(DestDc: hdc; {Handle of where to blt} x: word; {Bit at x} y: word; {Blt at y} Width: word; {Width to stretch} Height: word; {Height to stretch} bm: TBitmap); {the TBitmap to Blt} var

OriginalWidth: LongInt; {width of BM} dc: hdc; {screen dc} IsPaletteDevice: bool; {if the device uses palettes} IsDestPaletteDevice: bool; {if the device uses palettes} BitmapInfoSize: integer; {sizeof the bitmapinfoheader} lpBitmapInfo: PBitmapInfo; {the bitmap info header} hBm: hBitmap; {handle to the bitmap} hPal: hPalette; {handle to the palette} OldPal: hPalette; {temp palette} hBits: THandle; {handle to the DIB bits} pBits: pointer; {pointer to the DIB bits} lPPalEntriesArray: PPalEntriesArray; {palette entry array} NumPalEntries: integer; {number of palette entries} i: integer; {looping variable} begin

{If range checking is on - lets turn it off for now} {we will remember if range checking was on by defining} {a define called CKRANGE if range checking is on.} {We do this to access array members past the arrays} {defined index range without causing a range check} {error at runtime. To satisfy the compiler, we must} {also access the indexes with a variable. ie: if we} {have an array defined as a: array[0..0] of byte,} {and an integer i, we can now access a[3] by setting} {i := 3; and then accessing a[i] without error} {$IFOPT R+} {$DEFINE CKRANGE} {$R-} {$ENDIF} {Save the original width of the bitmap} OriginalWidth := bm.Width; {Get the screen's dc to use since memory dc's are not reliable} dc := GetDc(0); {Are we a palette device?} IsPaletteDevice := GetDeviceCaps(dc, RASTERCAPS) and

RC_PALETTE = RC_PALETTE; {Give back the screen dc} dc := ReleaseDc(0, dc); {Allocate the BitmapInfo structure} if

IsPaletteDevice then

BitmapInfoSize := sizeof(TBitmapInfo) + (sizeof(TRGBQUAD) * 255) else

BitmapInfoSize := sizeof(TBitmapInfo); GetMem(lpBitmapInfo, BitmapInfoSize); {Zero out the BitmapInfo structure} FillChar(lpBitmapInfo^, BitmapInfoSize, #0); {Fill in the BitmapInfo structure} lpBitmapInfo^.bmiHeader.biSize := sizeof(TBitmapInfoHeader); lpBitmapInfo^.bmiHeader.biWidth := OriginalWidth; lpBitmapInfo^.bmiHeader.biHeight := bm.Height; lpBitmapInfo^.bmiHeader.biPlanes := 1; if

IsPaletteDevice then

lpBitmapInfo^.bmiHeader.biBitCount := 8 else

lpBitmapInfo^.bmiHeader.biBitCount := 24; lpBitmapInfo^.bmiHeader.biCompression := BI_RGB; lpBitmapInfo^.bmiHeader.biSizeImage := ((lpBitmapInfo^.bmiHeader.biWidth * longint(lpBitmapInfo^.bmiHeader.biBitCount)) div

8) * lpBitmapInfo^.bmiHeader.biHeight; lpBitmapInfo^.bmiHeader.biXPelsPerMeter := 0; lpBitmapInfo^.bmiHeader.biYPelsPerMeter := 0; if

IsPaletteDevice then

begin

lpBitmapInfo^.bmiHeader.biClrUsed := 256; lpBitmapInfo^.bmiHeader.biClrImportant := 256; end

else

begin

lpBitmapInfo^.bmiHeader.biClrUsed := 0; lpBitmapInfo^.bmiHeader.biClrImportant := 0; end

; {Take ownership of the bitmap handle and palette} hBm := bm.ReleaseHandle; hPal := bm.ReleasePalette; {Get the screen's dc to use since memory dc's are not reliable} dc := GetDc(0); if

IsPaletteDevice then

begin

{If we are using a palette, it must be} {selected into the dc during the conversion} OldPal := SelectPalette(dc, hPal, TRUE

); {Realize the palette} RealizePalette(dc); end

; {Tell GetDiBits to fill in the rest of the bitmap info structure} GetDiBits(dc, hBm, 0, lpBitmapInfo^.bmiHeader.biHeight, nil

, TBitmapInfo(lpBitmapInfo^), DIB_RGB_COLORS); {Allocate memory for the Bits} hBits := GlobalAlloc(GMEM_MOVEABLE, lpBitmapInfo^.bmiHeader.biSizeImage); pBits := GlobalLock(hBits); {Get the bits} GetDiBits(dc, hBm, 0, lpBitmapInfo^.bmiHeader.biHeight, pBits, TBitmapInfo(lpBitmapInfo^), DIB_RGB_COLORS); if

IsPaletteDevice then

begin

{Lets fix up the color table for buggy video drivers} GetMem(lPPalEntriesArray, sizeof(TPaletteEntry) * 256); {$IFDEF VER100} NumPalEntries := GetPaletteEntries(hPal, 0, 256, lPPalEntriesArray^); {$ELSE} NumPalEntries := GetSystemPaletteEntries(dc, 0, 256, lPPalEntriesArray^); {$ENDIF} for

i := 0 to

(NumPalEntries - 1) do

begin

lpBitmapInfo^.bmiColors[i].rgbRed := lPPalEntriesArray^[i].peRed; lpBitmapInfo^.bmiColors[i].rgbGreen := lPPalEntriesArray^[i].peGreen; lpBitmapInfo^.bmiColors[i].rgbBlue := lPPalEntriesArray^[i].peBlue; end

; FreeMem(lPPalEntriesArray, sizeof(TPaletteEntry) * 256); end

; if

IsPaletteDevice then

begin

{Select the old palette back in} SelectPalette(dc, OldPal, TRUE

); {Realize the old palette} RealizePalette(dc); end

; {Give back the screen dc} dc := ReleaseDc(0, dc); {Is the Dest dc a palette device?} IsDestPaletteDevice := GetDeviceCaps(DestDc, RASTERCAPS) and

RC_PALETTE = RC_PALETTE; if

IsPaletteDevice then

begin

{If we are using a palette, it must be} {selected into the dc during the conversion} OldPal := SelectPalette(DestDc, hPal, TRUE

); {Realize the palette} RealizePalette(DestDc); end

; {Do the blt} StretchDiBits(DestDc, x, y, Width, Height, 0, 0, OriginalWidth, lpBitmapInfo^.bmiHeader.biHeight, pBits, lpBitmapInfo^, DIB_RGB_COLORS, SrcCopy); if

IsDestPaletteDevice then

begin

{Select the old palette back in} SelectPalette(DestDc, OldPal, TRUE

); {Realize the old palette} RealizePalette(DestDc); end

; {De-Allocate the Dib Bits} GlobalUnLock(hBits); GlobalFree(hBits); {De-Allocate the BitmapInfo} FreeMem(lpBitmapInfo, BitmapInfoSize); {Set the ownership of the bimap handles back to the bitmap} bm.Handle := hBm; bm.Palette := hPal; {Turn range checking back on if it was on when we started} {$IFDEF CKRANGE} {$UNDEF CKRANGE} {$R+} {$ENDIF} end

; procedure

TForm1.Button1Click(Sender: TObject); begin

if

PrintDialog1.Execute then

begin

Printer.BeginDoc; BltTBitmapAsDib(Printer.Canvas.Handle, 0, 0, Image1.Picture.Bitmap.Width, Image1.Picture.Bitmap.Height, Image1.Picture.Bitmap); Printer.EndDoc; end

; end

;

Другое по теме:

Категории

Статьи

Советы

Copyright © 2022 - All Rights Reserved - www.delphirus.com