unit1.~pas

Delphi实效编程百例的随书源代码 这是其中的操作系统部分

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls,Printers,CommDlg, ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    PrintDialog1: TPrintDialog;
    Image1: TImage;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}
{$IFNDEF WIN32}
const MAX_PATH = 144; 
{$ENDIF} 

procedure TForm1.Button1Click(Sender: TObject);
var 
Pd : TPrintDlg;
DocInfo: TDocInfo; 
begin 
FillChar(Pd, sizeof(Pd), #0); 
Pd.lStructSize := sizeof(Pd);
Pd.hWndOwner := Form1.Handle; 
Pd.Flags := PD_RETURNDC; 
if PrintDlg(pd) then begin 
FillChar(DocInfo, sizeof(DocInfo), #0); 
DocInfo.cbSize := SizeOf(DocInfo); 
GetMem(DocInfo.lpszDocName, 32); 
GetMem(DocInfo.lpszOutput, MAX_PATH);
lStrCpy(DocInfo.lpszDocName, 'My Document');
{Add this line to print to a file }
lStrCpy(DocInfo.lpszOutput, 'D:\private\Delphi.doc');
StartDoc(Pd.hDc, DocInfo);
StartPage(Pd.hDc);
TextOut(Pd.hDc, 100, 100, 'Page 1', 6);
EndPage(Pd.hDc);
StartPage(Pd.hDc);
TextOut(Pd.hDc, 100, 100, 'Page 2', 6);
EndPage(Pd.hDc);
EndDoc(Pd.hDc);
FreeMem(DocInfo.lpszDocName, 32);
FreeMem(DocInfo.lpszOutput, MAX_PATH);
end;
end;
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.Button2Click(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;


end.