1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162
| procedure BitmapPrn(DCimp:HDC;Bmp:HBITMAP;X,Y,Zx,ZY:word;rop:longint);
var
dc: HDC;
isDcPalDevice : BOOL;
MemDc,memdc2 :hdc;
MemBitmap : hBitmap;
OldMemBitmap,oldbmp : hBitmap;
hDibHeader : Thandle;
pDibHeader : pointer;
hBits : Thandle;
pBits : pointer;
ScaleX : Double;
ScaleY : Double;
ppal : PLOGPALETTE;
pal : hPalette;
Oldpal : hPalette;
i : integer;
B:TBITMAP;
begin
{Get the screen dc}
dc := GetDc(0);
GetObject(BMP,Sizeof(B), @B);
{Create a compatible dc}
MemDc := CreateCompatibleDc(dc);
MemDc2 := CreateCompatibleDc(dc);
{create a bitmap}
MemBitmap := CreateCompatibleBitmap(Dc,B.bmwidth,B.bmheight);
{select the bitmap into the dc}
OldMemBitmap := SelectObject(MemDc, MemBitmap);
Oldbmp:=SelectObject(MemDc2, bmp);
{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,b.bmwidth,b.bmheight,MemDc2,0,0,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 := b.bmwidth;
PBITMAPINFOHEADER(pDibHeader)^.biHeight := B.bmheight;
PBITMAPINFOHEADER(pDibHeader)^.biCompression := BI_RGB;
{find out how much memory for the bits}
GetDIBits(Memdc2,MemBitmap,0,B.Bmheight,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(Memdc2,MemBitmap,0,b.Bmheight,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 := self.Height * (Printer.PageWidth / self.Width);
end
else
begin
ScaleX := self.Width * (Printer.PageHeight / self.Height);
ScaleY := Printer.PageHeight;
end;
*)
{Just incase the printer drver is a palette device}
isDcPalDevice := false;
if GetDeviceCaps(Dcimp, 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(Dcimp, Pal, false);
isDcPalDevice := true
end;
{send the bits to the printer}
StretchDiBits(Dcimp,impx(x),impy(y),impx(zx), ImpY(zy),0,
0,b.bmWidth, B.bmHeight,pBits,
PBitmapInfo(pDibHeader)^,DIB_RGB_COLORS,ROP);
{Just incase you printer drver is a palette device}
if isDcPalDevice = true then
begin
SelectPalette(DCimp, oldPal, false);
DeleteObject(Pal);
end;
{Clean up allocated memory}
GlobalUnlock(hBits);
GlobalFree(hBits);
GlobalUnlock(hDibHeader);
GlobalFree(hDibHeader);
{End the print job}
deletedc(memdc2);
end; |
Partager