title image


Smiley Re: Gib mir mal bitte den Code, vielleicht erzeugt der neue Ideen in Köpfen :-)
das war das ding.

wenn man genau hinguckt, ist es klar, dass es hier nicht helfen kann, ansonsten ja.....







unformatiert:



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;





//
// C wurde erfunden, damit die baeume der programmierer
// nicht in den himmel wachsen.
//
// frager


geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: