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}
type
PPalEntriesArray = ^TPalEntriesArray; //用于重设调色板
TPalEntriesArray = array[0..0] of TPaletteEntry;

procedure BltTBitmapAsDib(DestDc : hdc;
x : word;
y : word;
Width : word;
Height : word;
bm : TBitmap);
var
OriginalWidth :LongInt;
dc : hdc;
IsPaletteDevice : bool; //判断设备是否是调色板
IsDestPaletteDevice : bool; //判断设备是否使用调色板
BitmapInfoSize : integer;
lpBitmapInfo : PBitmapInfo;//位图信息头
hBm : hBitmap; //位图句柄
hPal : hPalette; //调色板句柄
OldPal : hPalette; //临时调色板
hBits : THandle; //DIB位的句柄
pBits : pointer; //DIB位的指针
lPPalEntriesArray : PPalEntriesArray;//调色板入口数组
NumPalEntries : integer; //调色板入口的数目
i : integer; //循环变量
begin

{$IFOPT R+}
{$DEFINE CKRANGE}
{$R-}
{$ENDIF}

//存储位图的初始宽度
OriginalWidth := bm.Width;

//获得屏幕的设备上下文
dc := GetDc(0);
//是否是一个调色板设备
IsPaletteDevice :=
GetDeviceCaps(dc, RASTERCAPS) and RC_PALETTE = RC_PALETTE;
dc := ReleaseDc(0, dc);

//设置位图信息结构
if IsPaletteDevice then
BitmapInfoSize := sizeof(TBitmapInfo) + (sizeof(TRGBQUAD) * 255)
else
BitmapInfoSize := sizeof(TBitmapInfo);
GetMem(lpBitmapInfo, BitmapInfoSize);

FillChar(lpBitmapInfo^, BitmapInfoSize, #0);

//填充位图信息结构
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;

hBm := bm.ReleaseHandle;
hPal := bm.ReleasePalette;

//获得屏幕的设备上下文
dc := GetDc(0);

if IsPaletteDevice then begin
OldPal := SelectPalette(dc, hPal, TRUE);
RealizePalette(dc);
end;
GetDiBits(dc,
hBm,
0,
lpBitmapInfo^.bmiHeader.biHeight,
nil,
TBitmapInfo(lpBitmapInfo^),
DIB_RGB_COLORS);

//为位图分配内存
hBits := GlobalAlloc(GMEM_MOVEABLE,
lpBitmapInfo^.bmiHeader.biSizeImage);
pBits := GlobalLock(hBits);
GetDiBits(dc,
hBm,
0,
lpBitmapInfo^.bmiHeader.biHeight,
pBits,
TBitmapInfo(lpBitmapInfo^),
DIB_RGB_COLORS);


if IsPaletteDevice then begin
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
SelectPalette(dc, OldPal, TRUE);
RealizePalette(dc);
end;

dc := ReleaseDc(0, dc);

IsDestPaletteDevice :=
GetDeviceCaps(DestDc, RASTERCAPS) and RC_PALETTE = RC_PALETTE;


if IsPaletteDevice then begin

OldPal := SelectPalette(DestDc, hPal, TRUE);
RealizePalette(DestDc);
end;


StretchDiBits(DestDc,
x,
y,
Width,
Height,
0,
0,
OriginalWidth,
lpBitmapInfo^.bmiHeader.biHeight,
pBits,
lpBitmapInfo^,
DIB_RGB_COLORS,
SrcCopy);

if IsDestPaletteDevice then begin
SelectPalette(DestDc, OldPal, TRUE);
RealizePalette(DestDc);
end;

GlobalUnLock(hBits);
GlobalFree(hBits);
FreeMem(lpBitmapInfo, BitmapInfoSize);

bm.Handle := hBm;
bm.Palette := hPal;

{$IFDEF CKRANGE}
{$UNDEF CKRANGE}
{$R+}
{$ENDIF}
end;

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;

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.