Mega Code Archive
Hardcopy PrintScreen to Printer with PRN Button
<![CDATA[
Title: Hardcopy / PrintScreen to Printer with PRN Button
Question: Hardcopy / PrintScreen to Printer with PRN Button
Answer:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, printers, ExtCtrls;
type
TForm1 = class(TForm)
FlagPRNWin: TCheckBox;
PrintDialog1: TPrintDialog;
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
procedure AppIdle(Sender:TObject; var Done:Boolean);
end;
var
Form1: TForm1;
procedure BltTBitmapAsDib(DestDC:hDC;x,y,Width,Height:word;bm:TBitmap);
function GetScreenImage(var C: TCanvas):TBitmap;
procedure Hardcopy(WithDialog:Boolean;PrnDialog:TPrintDialog;
PrnTitle,SheetTitle,Copyright:String);
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
//Print screen Btn check
Application.OnIdle:=AppIdle;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
//only to have a focus spot
end;
procedure TForm1.AppIdle(Sender:TObject; var Done:Boolean);
begin
if GetAsyncKeyState(VK_SNAPSHOT) 0 then
Hardcopy(FlagPRNWin.Checked,PrintDialog1,
'HardCopy','Company ABC Print ',' Company ABC');
done:=true;
end;
//This function called BltTBitmapAsDib comes from the Borland web site, and
//used with only slight changes }
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
CONST MAX_PALS = 256;
type
PPalEntriesArray = ^TPalEntriesArray; //for palette re-construction
TPalEntriesArray = array[1..MAX_PALS] of TPaletteEntry;
var
OriginalWidth :LongInt; //width of BM
DC : hDC; //screen DC
IsSrcPaletteDevice : 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
//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?
IsSrcPaletteDevice:=GetDeviceCaps(DC, RASTERCAPS) and RC_PALETTE = RC_PALETTE;
//Give back the screen DC
ReleaseDC(0, DC);
//Allocate the BitmapInfo structure
if IsSrcPaletteDevice 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
WITH lpBitmapInfo^.bmiHeader DO BEGIN
biSize := sizeof(TBitmapInfoHeader);
biWidth := OriginalWidth;
biHeight := bm.Height;
biPlanes := 1;
if IsSrcPaletteDevice then begin
biBitCount := 8;
biClrUsed := 256;
biClrImportant := 256;
end else begin
biBitCount := 24;
biClrUsed := 0;
biClrImportant := 0;
end;
biCompression := BI_RGB;
biSizeImage := ((biWidth * longint(biBitCount)) div 8) * biHeight;
biXPelsPerMeter := 0;
biYPelsPerMeter := 0;
END;
//Take ownership of the bitmap handle and palette
hBm := bm.ReleaseHandle;
hPal := bm.ReleasePalette;
OldPal := 0; //initialize to avoid a compiler warning
//Get the screen's DC to use since memory DC's are not reliable
DC := GetDC(0);
if IsSrcPaletteDevice 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 IsSrcPaletteDevice then begin
//Let's fix up the color table for buggy video drivers
GetMem(lPPalEntriesArray, sizeof(TPaletteEntry) * MAX_PALS);
{$IFDEF VER100}
NumPalEntries := GetPaletteEntries(hPal,0,MAX_PALS,lPPalEntriesArray^);
{$ELSE}
NumPalEntries := GetSystemPaletteEntries(DC,0,MAX_PALS,lPPalEntriesArray^);
{$ENDIF}
for i := 1 to NumPalEntries do
with lpBitmapInfo^.bmiColors[i] do begin
rgbRed := lPPalEntriesArray^[i].peRed;
rgbGreen := lPPalEntriesArray^[i].peGreen;
rgbBlue := lPPalEntriesArray^[i].peBlue;
end;
FreeMem(lPPalEntriesArray, sizeof(TPaletteEntry) * MAX_PALS);
end;
if IsSrcPaletteDevice then begin
//Select the old palette back in
SelectPalette(DC, OldPal, TRUE);
//Realize the old palette
RealizePalette(DC);
end;
//Give back the screen DC
ReleaseDC(0, DC);
//Is the Dest DC a palette device?
IsDestPaletteDevice :=
GetDeviceCaps(DestDC, RASTERCAPS) and RC_PALETTE = RC_PALETTE;
if IsSrcPaletteDevice 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;
end;
function GetScreenImage(var C: TCanvas): TBitmap;
begin
Result := TBitmap.Create;
try
Result.Canvas.Lock;
try
WITH Screen DO BEGIN
//we simply set the Bitmap Width and Height to the current screen size
//here. Ideally you may want to build in a mouse click tool to define
//the bitmap boundaries...
Result.Width := Width;
Result.Height := Height;
Result.Canvas.CopyRect(Rect(0, 0, Width, Height), C, Rect(0, 0, Width,Height));
END;
finally
Result.Canvas.Unlock;
end;
Application.ProcessMessages;
except
Result.Free;
raise;
end;
end;
procedure Hardcopy(WithDialog:Boolean;PrnDialog:TPrintDialog;
PrnTitle,SheetTitle,Copyright:String);
var
ScreenImage: TBitmap;
C: TCanvas;
DC: HDC;
maxratio: Double;
lf:Extended;
PHigh,TopLine,AddLeft,AddTop:Integer;
begin
if WithDialog then begin
if not PrnDialog.Execute then exit;
application.ProcessMessages;
end;
DC := GetDC(0);
C := TCanvas.Create;
C.Handle := DC;
try
ScreenImage := GetScreenImage(C);
try
Printer.Orientation := poLandscape;
Printer.Canvas.Font.Name := 'Arial';
Printer.Canvas.Pen.Width := 8;
Printer.Canvas.Font.Size := 8;
Printer.Canvas.Font.Style := [fsBold];
Printer.Title := PrnTitle;
Printer.BeginDoc;
lf:=Printer.PageHeight/3407;
TopLine:=Trunc(110*lf);
AddLeft:=0;
AddTop:=0;
PHigh:=Printer.PageHeight-TopLine;
maxratio := Printer.PageWidth / ScreenImage.Width;
if PHigh / ScreenImage.Height //Image width is smaler than Printer width
maxratio := PHigh / ScreenImage.Height;
AddLeft:=Trunc((Printer.PageWidth-ScreenImage.Width * maxratio)/2);
end else
//Image height is smaler than Printer height
AddTop:=Trunc((Printer.PageHeight-ScreenImage.Height * maxratio)/2);
BltTBitmapAsDib(Printer.Canvas.Handle,0+AddLeft,TopLine+AddTop,
Trunc(ScreenImage.Width * maxratio),
Trunc(ScreenImage.Height * maxratio),
ScreenImage);
Printer.Canvas.TextOut(0,0,SheetTitle+DateTimeToStr(Now)+Copyright);
Printer.EndDoc;
Printer.Orientation := poPortrait;
finally
ScreenImage.Free;
end;
finally
ReleaseDC(0, DC);
C.Free;
end;
end;
end.
]]>