我给贴一个我自己改的 HPRINTERS.PAS,希望对你有所帮助，我用它替代了Borland提供的
Printers.Pas,请关注里面的 SetPaperCode 函数的写法。。。。
{*******************************************************}
{ }
{ Borland Delphi Visual Component Library }
{ }
{ Copyright (c) 1995,99 Inprise Corporation }
{ }
{*******************************************************}
unit HPrinters;
{$R-,T-,X+,H+}
interface
uses Windows, WinSpool, SysUtils, Classes, Graphics, Forms;
const
CustomPaperName = '用户自定义纸张';
type
EHPrinter = class(Exception);
// 打印纸类型定义
TPaperFormItem = class(TCollectionItem)
private
FNames: string;
FSizeCode: integer;
FOrientAtion: integer;
FPaperWidth: integer;
// 单位为 0.1 毫米
FPaperHeight: integer;
// 单位为 0.1 毫米
FUserDefine: Boolean;
public
constructor Create(Collection: TCollection);
override;
destructor Destroy;
override;
procedure Assign(Source: TPersistent);
override;
property Names: string read FNames write FNames;
property SizeCode: integer read FSizeCode write FSizeCode;
property OrientAtion: integer read FOrientAtion write FOrientAtion;
property PaperWidth: integer read FPaperWidth write FPaperWidth;
property PaperHeight: integer read FPaperHeight write FPaperHeight;
property UserDefine: Boolean read FUserDefine write FUserDefine;
end;
TPaperFormItemClass = class of TPaperFormItem;
// 打印纸信息记录集合
TPaperForms = class(TCollection)
private
FOldPrintIdx: integer;
protected
function GetItem(Index: Integer): TPaperFormItem;
procedure SetItem(Index: Integer;
Value: TPaperFormItem);
public
constructor Create(ItemClass: TPaperFormItemClass);
function Add: TPaperFormItem;
function IndexOfName(aName: string): TPaperFormItem;
function IndexOfCode(aCode: Integer): TPaperFormItem;
function NameOfCode(aCode: Integer): string;
property OldPrintIdx: Integer read FOldPrintIdx write FOldPrintIdx;
property Items[Index: Integer]: TPaperFormItem read GetItem write SetItem;
default;
end;
PFormInfoNew = ^TFormInfoNew;
TFormInfoNew = array[0..511] of TFormInfo1A;
//CZY
{ THPrinter }
{ The HPrinter object encapsulates the HPrinter interface of Windows. A print
job is started whenever any redering isdo
ne either through a Text variable
or the printers canvas. This job will stay open until EndDoc is called or
the Text variable is closed. The title displayed in the Print Manager (and
on network header pages) is determined by the Title property.
EndDoc - Terminates the print job (and closes the currently open Text).
The print job will being printing on the HPrinter after a call to EndDoc.
NewPage - Starts a new page and increments the PageNumber property. The
pen position of the Canvas is put back at (0, 0).
Canvas - Represents the surface of the currently printing page. Note that
some HPrinterdo
not support drawing pictures and the Draw, StretchDraw,
and CopyRect methods might fail.
Fonts - The list of fonts supported by the HPrinter. Note that TrueType
fonts appear in this list even if the font is not supported natively on
the HPrinter since GDI can render them accurately for the HPrinter.
PageHeight - The height, in pixels, of the page.
PageWidth - The width, in pixels, of the page.
PageNumber - The current page number being printed. This is incremented
when ever the NewPage method is called. (Note: This property can also be
incremented when a Text variable is written, a CR is encounted on the
last line of the page).
PrinterIndex - Specifies which HPrinter in the TPrinters list that is
currently selected for printing. Setting this property to -1 will cause
the default HPrinter to be selected. If this value is changed EndDoc is
called automatically.
Printers - A list of the printers installed in Windows.
Title - The title used by Windows in the Print Manager and for network
title pages. }
THPrinterState = (pshNoHandle, pshHandleIC, pshHandleDC);
THPrinterOrientation = (pohPortrait, pohLandscape);
THPrinterCapability = (pchCopies, pchOrientation, pchCollation);
THPrinterCapabilities = set of THPrinterCapability;
THPrinter = class(TObject)
private
FCanvas: TCanvas;
FFonts: TStrings;
FPaperForms: TPaperForms;
FPageNumber: Integer;
FPrinters: TStrings;
FPrinterIndex: Integer;
FTitle: string;
FPrinting: Boolean;
FAborted: Boolean;
FCapabilities: THPrinterCapabilities;
State: THPrinterState;
FDC: HDC;
DevMode: PDeviceMode;
DeviceMode: THandle;
FPrinterHandle: THandle;
FAfterbegin
Doc: TNotifyEvent;
procedure SetState(Value: THPrinterState);
function GetCanvas: TCanvas;
function GetNumCopies: Integer;
function GetFonts: TStrings;
function GetHandle: HDC;
function GetOrientation: THPrinterOrientation;
function GetPaperCode: Integer;
function GetPaperUserDefine: Boolean;
function GetPaperForms: TPaperForms;
function GetPaperName: String;
function GetPageHeight: Integer;
function GetPageWidth: Integer;
function GetPrinterIndex: Integer;
procedure SetPrinterCapabilities(Value: Integer);
procedure SetPrinterIndex(Value: Integer);
function GetPrinters: TStrings;
procedure SetNumCopies(Value: Integer);
procedure SetOrientation(Value: THPrinterOrientation);
procedure SetPaperCode(Value: Integer);
procedure SetPageWidth(Value: integer);
procedure SetPageHeight(Value: integer);
procedure SetToDefaultPrinter;
procedure CheckPrinting(Value: Boolean);
procedure FreePrinters;
procedure FreeFonts;
public
constructor Create;
destructor Destroy;
override;
procedure Abort;
procedure begin
Doc;
procedure EndDoc;
procedure NewPage;
procedure GetPrinter(ADevice, ADriver, APort: PChar;
var ADeviceMode: THandle);
procedure SetPrinter(ADevice, ADriver, APort: PChar;
ADeviceMode: THandle);
procedure Refresh;
property Aborted: Boolean read FAborted;
property Canvas: TCanvas read GetCanvas;
property Capabilities: THPrinterCapabilities read FCapabilities;
property Copies: Integer read GetNumCopies write SetNumCopies;
property DC: HDC read FDC;
property Fonts: TStrings read GetFonts;
property Handle: HDC read GetHandle;
property Orientation: THPrinterOrientation read GetOrientation write SetOrientation;
property PageHeight: Integer read GetPageHeight write SetPageHeight;
// 以 0.1 毫米为单位
property PageWidth: Integer read GetPageWidth write SetPageWidth;
// 以 0.1 毫米为单位
property PaperCode: Integer read GetPaperCode write SetPaperCode;
property PaperIsUDf: Boolean read GetPaperUserDefine;
property PaperName: String read GetPaperName;
property PaperForms: TPaperForms read GetPaperForms;
property PageNumber: Integer read FPageNumber;
property PrinterHandle: THandle read FPrinterHandle;
property PrinterIndex: Integer read GetPrinterIndex write SetPrinterIndex;
property Printing: Boolean read FPrinting;
property Printers: TStrings read GetPrinters;
property Title: string read FTitle write FTitle;
property Afterbegin
Doc: TNotifyEvent read FAfterbegin
Doc write FAfterbegin
Doc;
end;
{ HPrinter function - Replaces the HPrinter global variable of previous versions,
to improve smart linking (reduce exe size by 2.5k in projects thatdo
n't use
the HPrinter). Code which assigned to the HPrinter global variable
must call SetHPrinter instead. SetHPrinter returns current HPrinter object
and makes the new HPrinter object the current HPrinter. It is the caller's
responsibility to free the old HPrinter, if appropriate. (This allows
toggling between different HPrinter objects without destroying configuration
settings.) }
function HPrinter: THPrinter;
function SetHPrinter(NewPrinter: THPrinter): THPrinter;
{ AssignHPrn - Assigns a Text variable to the currently selected HPrinter. Any
Write or Writeln's going to that file variable will be written on the
HPrinter using the Canvas property's font. A new page is automatically
started if a CR is encountered on (or a Writeln is written to) the last
line on the page. Closing the text file will imply a call to the
HPrinter.EndDoc method. Note: only one Text variable can be open on the
HPrinter at a time. Opening a second will cause an exception.}
procedure AssignHPrn(var F: Text);
implementation
uses Consts;
var
FPrinter: THPrinter = nil;
function FetchStr(var Str: PChar): PChar;
var
P: PChar;
begin
Result := Str;
if Str = nil then
Exit;
P := Str;
while P^ = ' 'do
Inc(P);
Result := P;
while (P^ <> #0) and (P^ <> ',')do
Inc(P);
if P^ = ',' then
begin
P^ := #0;
Inc(P);
end;
Str := P;
end;
procedure RaiseError(const Msg: string);
begin
raise EHPrinter.Create(Msg);
end;
function AbortProc(Prn: HDC;
Error: Integer): Bool;
stdcall;
begin
Application.ProcessMessages;
Result := not FPrinter.Aborted;
end;
type
PrnRec = record
case Integer of
1: (
Cur: TPoint;
Finish: TPoint;
{ End of the printable area }
Height: Integer);
{ Height of the current line }
2: (
Tmp: array[1..32] of Char);
end;
procedure NewPage(var Prn: PrnRec);
begin
with Prndo
begin
Cur.X := 0;
Cur.Y := 0;
FPrinter.NewPage;
end;
end;
{ Start a new line on the current page, if no more lines left start a new
page. }
procedure NewLine(var Prn: PrnRec);
function CharHeight: Word;
var
Metrics: TTextMetric;
begin
GetTextMetrics(FPrinter.Canvas.Handle, Metrics);
Result := Metrics.tmHeight;
end;
begin
with Prndo
begin
Cur.X := 0;
if Height = 0 then
Inc(Cur.Y, CharHeight) else
Inc(Cur.Y, Height);
if Cur.Y > (Finish.Y - (Height * 2)) then
NewPage(Prn);
Height := 0;
end;
end;
{ Print a string to the HPrinter without regard to special characters. These
should handled by the caller. }
procedure PrnOutStr(var Prn: PrnRec;
Text: PChar;
Len: Integer);
var
Extent: TSize;
L: Integer;
begin
with Prn, FPrinter.Canvasdo
begin
while Len > 0do
begin
L := Len;
GetTextExtentPoint(Handle, Text, L, Extent);
while (L > 0) and (Extent.cX + Cur.X > Finish.X)do
begin
L := CharPrev(Text, Text+L) - Text;
GetTextExtentPoint(Handle, Text, L, Extent);
end;
if Extent.cY > Height then
Height := Extent.cY + 2;
Windows.TextOut(Handle, Cur.X, Cur.Y, Text, L);
Dec(Len, L);
Inc(Text, L);
if Len > 0 then
NewLine(Prn)
else
Inc(Cur.X, Extent.cX);
end;
end;
end;
{ Print a string to the HPrinter handling special characters. }
procedure PrnString(var Prn: PrnRec;
Text: PChar;
Len: Integer);
var
L: Integer;
TabWidth: Word;
procedure Flush;
begin
if L <> 0 then
PrnOutStr(Prn, Text, L);
Inc(Text, L + 1);
Dec(Len, L + 1);
L := 0;
end;
function AvgCharWidth: Word;
var
Metrics: TTextMetric;
begin
GetTextMetrics(FPrinter.Canvas.Handle, Metrics);
Result := Metrics.tmAveCharWidth;
end;
begin
L := 0;
with Prndo
begin
while L < Lendo
begin
case Text[L] of
#9:
begin
Flush;
TabWidth := AvgCharWidth * 8;
Inc(Cur.X, TabWidth - ((Cur.X + TabWidth + 1)
mod TabWidth) + 1);
if Cur.X > Finish.X then
NewLine(Prn);
end;
#13: Flush;
#10:
begin
Flush;
NewLine(Prn);
end;
^L:
begin
Flush;
NewPage(Prn);
end;
else
Inc(L);
end;
end;
end;
Flush;
end;
{ Called when a Read or Readln is applied to a HPrinter file. Since reading is
illegal this routine tells the I/O system that no characters where read, which
generates a runtime error. }
function PrnInput(var F: TTextRec): Integer;
begin
with Fdo
begin
BufPos := 0;
BufEnd := 0;
end;
Result := 0;
end;
{ Called when a Write or Writeln is applied to a HPrinter file. The calls
PrnString to write the text in the buffer to the HPrinter. }
function PrnOutput(var F: TTextRec): Integer;
begin
with Fdo
begin
PrnString(PrnRec(UserData), PChar(BufPtr), BufPos);
BufPos := 0;
Result := 0;
end;
end;
{ Will ignore certain requests by the I/O system such as flush whiledo
ing an
input. }
function PrnIgnore(var F: TTextRec): Integer;
begin
Result := 0;
end;
{ Deallocates the resources allocated to the HPrinter file. }
function PrnClose(var F: TTextRec): Integer;
begin
with PrnRec(F.UserData)do
begin
FPrinter.EndDoc;
Result := 0;
end;
end;
{ Called to open I/O on a HPrinter file. Sets up the TTextFile to point to
HPrinter I/O functions. }
function PrnOpen(var F: TTextRec): Integer;
const
Blank: array[0..0] of Char = '';
begin
with F, PrnRec(UserData)do
begin
if Mode = fmInput then
begin
InOutFunc := @PrnInput;
FlushFunc := @PrnIgnore;
CloseFunc := @PrnIgnore;
end else
begin
Mode := fmOutput;
InOutFunc := @PrnOutput;
FlushFunc := @PrnOutput;
CloseFunc := @PrnClose;
FPrinter.begin
Doc;
Cur.X := 0;
Cur.Y := 0;
Finish.X := FPrinter.PageWidth;
Finish.Y := FPrinter.PageHeight;
Height := 0;
end;
Result := 0;
end;
end;
procedure AssignHPrn(var F: Text);
begin
with TTextRec(F), PrnRec(UserData)do
begin
HPrinter;
FillChar(F, SizeOf(F), 0);
Mode := fmClosed;
BufSize := SizeOf(Buffer);
BufPtr := @Buffer;
OpenFunc := @PrnOpen;
end;
end;
{ TPrinterDevice }
type
TPrinterDevice = class
Driver, Device, Port: String;
constructor Create(ADriver, ADevice, APort: PChar);
function IsEqual(ADriver, ADevice, APort: PChar): Boolean;
end;
constructor TPrinterDevice.Create(ADriver, ADevice, APort: PChar);
begin
inherited Create;
Driver := ADriver;
Device := ADevice;
Port := APort;
end;
function TPrinterDevice.IsEqual(ADriver, ADevice, APort: PChar): Boolean;
begin
Result := (Device = ADevice) and ((Port = '') or (Port = APort));
end;
{ TPrinterCanvas }
type
TPrinterCanvas = class(TCanvas)
Printer: THPrinter;
constructor Create(APrinter: THPrinter);
procedure CreateHandle;
override;
procedure Changing;
override;
procedure UpdateFont;
end;
constructor TPrinterCanvas.Create(APrinter: THPrinter);
begin
inherited Create;
Printer := APrinter;
end;
procedure TPrinterCanvas.CreateHandle;
begin
Printer.SetState(pshHandleIC);
UpdateFont;
Handle:= Printer.FDC;
end;
procedure TPrinterCanvas.Changing;
begin
Printer.CheckPrinting(True);
inherited Changing;
UpdateFont;
end;
procedure TPrinterCanvas.UpdateFont;
var
FontSize: Integer;
begin
if GetDeviceCaps(Printer.FDC, LOGPIXELSY) <> Font.PixelsPerInch then
begin
FontSize := Font.Size;
Font.PixelsPerInch := GetDeviceCaps(Printer.FDC, LOGPIXELSY);
Font.Size := FontSize;
end;
end;
constructor TPaperFormItem.Create(Collection: TCollection);
begin
inherited Create(Collection);
FNames := '';
FSizeCode := 0;
FOrientAtion := 0;
FPaperWidth := 0;
FPaperHeight := 0;
FUserDefine := False;
end;
destructor TPaperFormItem.Destroy;
begin
FNames := '';
inherited Destroy;
end;
procedure TPaperFormItem.Assign(Source: TPersistent);
begin
if Assigned(Source) then
begin
FNames := (Source as TPaperFormItem).Names;
FSizeCode := (Source as TPaperFormItem).SizeCode;
FOrientAtion := (Source as TPaperFormItem).OrientAtion;
FPaperWidth := (Source as TPaperFormItem).PaperWidth;
FPaperHeight := (Source as TPaperFormItem).PaperHeight;
FUserDefine := (Source as TPaperFormItem).UserDefine;
end;
end;
{ TPaperForms }
constructor TPaperForms.Create(ItemClass: TPaperFormItemClass);
begin
inherited Create(ItemClass);
FOldPrintIdx := -1;
end;
function TPaperForms.GetItem(Index: Integer): TPaperFormItem;
begin
Result := TPaperFormItem(inherited Items[Index]);
end;
procedure TPaperForms.SetItem(Index: Integer;
Value: TPaperFormItem);
begin
inherited Items[Index] := Value;
end;
function TPaperForms.Add: TPaperFormItem;
begin
Result := TPaperFormItem(inherited Add);
end;
function TPaperForms.IndexOfName(aName: string): TPaperFormItem;
var
i: integer;
begin
Result := nil;
for i := 0 to Count - 1do
begin
if UpperCase(Items.FNames) = UpperCase(aName) then
begin
Result := Items;
Break;
end;
end;
end;
function TPaperForms.IndexOfCode(aCode: Integer): TPaperFormItem;
var
i: integer;
begin
Result := nil;
for i := 0 to Count - 1do
begin
if Items.FSizeCode = aCode then
begin
Result := Items;
Break;
end;
end;
end;
function TPaperForms.NameOfCode(aCode: Integer): string;
var
i: integer;
begin
Result := '';
for i := 0 to Count - 1do
begin
if Items.FSizeCode = aCode then
begin
Result := Items.FNames;
Break;
end;
end;
end;
{ THPrinter }
constructor THPrinter.Create;
begin
inherited Create;
FPrinterIndex := -1;
FPaperForms := TPaperForms.Create(TPaperFormItem);
FPaperForms.OldPrintIdx := -1;
end;
destructor THPrinter.Destroy;
begin
if Printing then
EndDoc;
SetState(pshNoHandle);
FreePrinters;
FreeFonts;
FCanvas.Free;
if FPrinterHandle <> 0 then
ClosePrinter(FPrinterHandle);
if DeviceMode <> 0 then
begin
GlobalUnlock(DeviceMode);
GlobalFree(DeviceMode);
DeviceMode := 0;
end;
FPaperForms.Free;
inherited Destroy;
end;
procedure THPrinter.SetState(Value: THPrinterState);
type
TCreateHandleFunc = function (DriverName, DeviceName, Output: PChar;
InitData: PDeviceMode): HDC stdcall;
var
CreateHandleFunc: TCreateHandleFunc;
begin
if Value <> State then
begin
CreateHandleFunc := nil;
case Value of
pshNoHandle:
begin
CheckPrinting(False);
if Assigned(FCanvas) then
FCanvas.Handle := 0;
DeleteDC(FDC);
FDC := 0;
end;
pshHandleIC:
if State <> pshHandleDC then
CreateHandleFunc := CreateIC
else
Exit;
pshHandleDC:
begin
if FCanvas <> nil then
FCanvas.Handle := 0;
if FDC <> 0 then
DeleteDC(FDC);
CreateHandleFunc := CreateDC;
end;
end;
if Assigned(CreateHandleFunc) then
with TPrinterDevice(Printers.Objects[PrinterIndex])do
begin
FDC := CreateHandleFunc(PChar(Driver), PChar(Device), PChar(Port), DevMode);
if FDC = 0 then
RaiseError(SInvalidPrinter);
if FCanvas <> nil then
FCanvas.Handle := FDC;
end;
State := Value;
end;
end;
procedure THPrinter.CheckPrinting(Value: Boolean);
begin
if Printing <> Value then
if Value then
RaiseError(SNotPrinting)
else
RaiseError(SPrinting);
end;
procedure THPrinter.Abort;
begin
CheckPrinting(True);
AbortDoc(Canvas.Handle);
FAborted := True;
EndDoc;
end;
procedure THPrinter.begin
Doc;
var
do
cInfo: TDocInfo;
begin
CheckPrinting(False);
SetState(pshHandleDC);
Canvas.Refresh;
TPrinterCanvas(Canvas).UpdateFont;
FPrinting := True;
FAborted := False;
FPageNumber := 1;
FillChar(DocInfo, SizeOf(DocInfo), 0);
withdo
cInfodo
begin
cbSize := SizeOf(DocInfo);
lpszDocName := PChar(Title);
end;
SetAbortProc(FDC, AbortProc);
try
StartDoc(FDC,do
cInfo);
StartPage(FDC);
except
;
end;
end;
procedure THPrinter.EndDoc;
begin
CheckPrinting(True);
EndPage(FDC);
if not Aborted then
Windows.EndDoc(FDC);
FPrinting := False;
FAborted := False;
FPageNumber := 0;
end;
procedure THPrinter.NewPage;
begin
CheckPrinting(True);
EndPage(FDC);
StartPage(FDC);
Inc(FPageNumber);
Canvas.Refresh;
end;
procedure THPrinter.GetPrinter(ADevice, ADriver, APort: PChar;
var ADeviceMode: THandle);
begin
with TPrinterDevice(Printers.Objects[PrinterIndex])do
begin
StrCopy(ADevice, PChar(Device));
StrCopy(ADriver, PChar(Driver));
StrCopy(APort, PChar(Port));
end;
ADeviceMode := DeviceMode;
end;
procedure THPrinter.SetPrinterCapabilities(Value: Integer);
begin
FCapabilities := [];
if (Value and DM_ORIENTATION) <> 0 then
Include(FCapabilities, pchOrientation);
if (Value and DM_COPIES) <> 0 then
Include(FCapabilities, pchCopies);
if (Value and DM_COLLATE) <> 0 then
Include(FCapabilities, pchCollation);
end;
procedure THPrinter.SetPrinter(ADevice, ADriver, APort: PChar;
ADeviceMode: THandle);
var
I, J: Integer;
StubDevMode: TDeviceMode;
// czyczyczyczyczyczy
begin
CheckPrinting(False);
if ADeviceMode <> DeviceMode then
begin
// free the devmode block we have, and take the one we're given
if DeviceMode <> 0 then
begin
GlobalUnlock(DeviceMode);
GlobalFree(DeviceMode);
end;
DeviceMode := ADeviceMode;
end;
if DeviceMode <> 0 then
begin
DevMode := GlobalLock(DeviceMode);
SetPrinterCapabilities(DevMode.dmFields);
end;
FreeFonts;
if FPrinterHandle <> 0 then
begin
ClosePrinter(FPrinterHandle);
FPrinterHandle := 0;
end;
SetState(pshNoHandle);
J := -1;
with Printersdo
// <- this rebuilds the FPrinters list
for I := 0 to Count - 1do
begin
if TPrinterDevice(Objects).IsEqual(ADriver, ADevice, APort) then
begin
TPrinterDevice(Objects).Port := APort;
J := I;
Break;
end;
end;
if J = -1 then
begin
J := FPrinters.Count;
FPrinters.AddObject(Format(SDeviceOnPort, [ADevice, APort]),
TPrinterDevice.Create(ADriver, ADevice, APort));
end;
FPrinterIndex := J;
if OpenPrinter(ADevice, FPrinterHandle, nil) then
begin
if DeviceMode = 0 then
// alloc new device mode block if one was not passed in
begin
DeviceMode := GlobalAlloc(GHND,
do
cumentProperties(0, FPrinterHandle, ADevice, StubDevMode,
StubDevMode, 0));
if DeviceMode <> 0 then
begin
DevMode := GlobalLock(DeviceMode);
ifdo
cumentProperties(0, FPrinterHandle, ADevice, DevMode^,
DevMode^, DM_OUT_BUFFER) < 0 then
begin
GlobalUnlock(DeviceMode);
GlobalFree(DeviceMode);
DeviceMode := 0;
end
end;
end;
if DeviceMode <> 0 then
SetPrinterCapabilities(DevMode^.dmFields);
end;
end;
function THPrinter.GetCanvas: TCanvas;
begin
if FCanvas = nil then
FCanvas := TPrinterCanvas.Create(Self);
Result := FCanvas;
end;
function EnumFontsProc(var LogFont: TLogFont;
var TextMetric: TTextMetric;
FontType: Integer;
Data: Pointer): Integer;
stdcall;
begin
TStrings(Data).Add(LogFont.lfFaceName);
Result := 1;
end;
function THPrinter.GetFonts: TStrings;
begin
if FFonts = nil then
try
SetState(pshHandleIC);
FFonts := TStringList.Create;
EnumFonts(FDC, nil, @EnumFontsProc, Pointer(FFonts));
except
FreeAndNil(FFonts);
raise;
end;
Result := FFonts;
end;
function THPrinter.GetHandle: HDC;
begin
SetState(pshHandleIC);
Result := FDC;
end;
function THPrinter.GetNumCopies: Integer;
begin
GetPrinterIndex;
if DeviceMode = 0 then
RaiseError(SInvalidPrinterOp);
Result := DevMode^.dmCopies;
end;
procedure THPrinter.SetNumCopies(Value: Integer);
begin
CheckPrinting(False);
GetPrinterIndex;
if DeviceMode = 0 then
RaiseError(SInvalidPrinterOp);
SetState(pshNoHandle);
DevMode^.dmCopies := Value;
end;
function THPrinter.GetOrientation: THPrinterOrientation;
begin
GetPrinterIndex;
if DeviceMode = 0 then
RaiseError(SInvalidPrinterOp);
if DevMode^.dmOrientation = DMORIENT_PORTRAIT then
Result := pohPortrait
else
Result := pohLandscape;
end;
procedure THPrinter.SetOrientation(Value: THPrinterOrientation);
const
Orientations: array [THPrinterOrientation] of Integer = (
DMORIENT_PORTRAIT, DMORIENT_LANDSCAPE);
begin
CheckPrinting(False);
GetPrinterIndex;
if DeviceMode = 0 then
RaiseError(SInvalidPrinterOp);
SetState(pshNoHandle);
DevMode^.dmOrientation := Orientations[Value];
end;
function THPrinter.GetPaperCode: Integer;
begin
GetPrinterIndex;
if DeviceMode = 0 then
RaiseError(SInvalidPrinterOp);
Result := DevMode^.dmPaperSize;
end;
type
TPaperNames = array[0..63] of char;
function THPrinter.GetPaperForms: TPaperForms;
var
pPaperNum, i: integer;
pPaperCodes: array[0..511] of Word;
pPaperNames: array[0..511] of TPaperNames;
pPaperSizes: array[0..511] of TPoint;
pForm: array[0..1] of TFormInfo1A;
InForm: TFormInfo1A;
cbNeeded: DWord;
begin
if (not FPrinting) and (PrinterIndex <> FPaperForms.OldPrintIdx) then
begin
FPaperForms.OldPrintIdx := PrinterIndex;
if Win32Platform = VER_PLATFORM_WIN32_NT then
begin
//DeleteForm(PrinterHandle, CustomPaperName);
if not GetForm(PrinterHandle, CustomPaperName, 1, @pForm,
Sizeof(pForm), cbNeeded) then
// 取原先的 Paper Form
begin
//没有发现自定义的 Form 则添加
with InFormdo
begin
Flags := 0;
pName := CustomPaperName;
Size.cx := PageWidth * 1000;
// 千分之一毫米，纸张宽高以毫米为单位
Size.cy := PageHeight * 1000;
with ImageAbleAreado
begin
Left := 0;
Top := 0;
Right := Size.cx;
Bottom := Size.cy;
end;
end;
AddForm(PrinterHandle, 1, @InForm);
// 添加自定义的纸张
end;
end;
//纸型
with TPrinterDevice(Printers.Objects[PrinterIndex])do
begin
//取打印机支持的纸型数
pPaperNum := DeviceCapabilities(PChar(Device), PChar(Driver), DC_PAPERS, nil, nil);
if (pPaperNum < 1) or (pPaperNum > 256) then
begin
Result := FPaperForms;
Exit;
end;
// 取纸张代码
DeviceCapabilities(PChar(Device), PChar(Driver), DC_PAPERS, @pPaperCodes, nil);
// 取纸张名称
DeviceCapabilities(PChar(Device), PChar(Driver), DC_PAPERNAMES, @pPaperNames, nil);
// 取纸张大小，单位为 0.1毫米
DeviceCapabilities(PChar(Device), PChar(Driver), DC_PAPERSIZE, @pPaperSizes, nil);
end;
FPaperForms.Clear;
for i := 0 to pPaperNum - 1do
with FPaperForms.Adddo
begin
Names := pPaperNames;
SizeCode := pPaperCodes;
PaperWidth := pPaperSizes.x;
// 0.1 毫米
PaperHeight := pPaperSizes.y;
// 0.1 毫米
OrientAtion := 0;
if Win32Platform = VER_PLATFORM_WIN32_NT then
begin
if Names = CustomPaperName then
UserDefine := True;
// NT/2000
end else
UserDefine := SizeCode = 256;
// 95/98
end;
end;
Result := FPaperForms;
end;
function THPrinter.GetPaperName: String;
begin
GetPrinterIndex;
if DeviceMode = 0 then
RaiseError(SInvalidPrinterOp);
Result := DevMode^.dmFormName;
end;
function THPrinter.GetPaperUserDefine: Boolean;
var
tmI: integer;
aPaperForm: TPaperFormItem;
begin
GetPrinterIndex;
if DeviceMode = 0 then
RaiseError(SInvalidPrinterOp);
tmI := DevMode^.dmPaperSize;
aPaperForm := PaperForms.IndexOfCode(tmI);
if aPaperForm <> nil then
Result := aPaperForm.FUserDefine
else
Result := False;
end;
procedure THPrinter.SetPaperCode(Value: Integer);
var
StubDevmod: Pdevicemode;
begin
CheckPrinting(False);
GetPrinterIndex;
if DeviceMode = 0 then
RaiseError(SInvalidPrinterOp);
SetState(pshNoHandle);
DevMode^.dmFields := (DevMode^.dmFields or DM_PAPERSIZE) and
(not (DM_PAPERWIDTH or DM_PAPERLENGTH));
DevMode^.dmPaperSize := Value;
if Value = 256 then
// W95 / 98
begin
DevMode^.dmFields := DevMode^.dmFields or DM_PAPERWIDTH or DM_PAPERLENGTH;
DevMode^.dmPaperWidth := 2438;
// 缺省为 A4
DevMode^.dmPaperLength := 2794;
end;
StubDevmod := nil;
do
cumentProperties(0, PrinterHandle, PChar(FPrinters[FPrinterIndex]),
StubDevmod^, DevMode^, DM_IN_BUFFER);
StrCopy(DevMode^.dmFormName, PChar(PaperForms.NameOfCode(Value)));
if Assigned(PaperForms.IndexOfCode(Value)) then
with PaperForms.IndexOfCode(Value)do
begin
if FUserDefine then
begin
PaperWidth := 2438;
// 缺省为 A4
PaperHeight := 2794;
end;
end;
end;
function THPrinter.GetPageHeight: Integer;
begin
SetState(pshHandleIC);
Result := GetDeviceCaps(FDC, VertSize);
// HorzRes
end;
procedure THPrinter.SetPageHeight(Value: integer);
var
StubDevmod: Pdevicemode;
begin
CheckPrinting(False);
GetPrinterIndex;
if DeviceMode = 0 then
RaiseError(SInvalidPrinterOp);
SetState(pshNoHandle);
if Assigned(PaperForms.IndexOfCode(PaperCode)) and
(PaperForms.IndexOfCode(PaperCode).FUserDefine) then
begin
DevMode^.dmFields := DevMode^.dmFields or DM_PAPERLENGTH;
DevMode^.dmPaperLength := Value;
StubDevmod := nil;
do
cumentProperties(Application.Handle, PrinterHandle, PChar(FPrinters[FPrinterIndex]),
StubDevmod^, DevMode^, DM_IN_BUFFER);
PaperForms.IndexOfCode(PaperCode).PaperHeight := Value;
end;
end;
function THPrinter.GetPageWidth: Integer;
begin
SetState(pshHandleIC);
Result := GetDeviceCaps(FDC, HorzSize);
//HorzRes);
end;
procedure THPrinter.SetPageWidth(Value: integer);
var
StubDevmod: Pdevicemode;
begin
CheckPrinting(False);
GetPrinterIndex;
if DeviceMode = 0 then
RaiseError(SInvalidPrinterOp);
SetState(pshNoHandle);
if Assigned(PaperForms.IndexOfCode(PaperCode)) and
(PaperForms.IndexOfCode(PaperCode).FUserDefine) then
begin
DevMode^.dmFields := DevMode^.dmFields or DM_PAPERWIDTH;
DevMode^.dmPaperWidth := Value;
StubDevmod := nil;
do
cumentProperties(0, PrinterHandle, PChar(FPrinters[FPrinterIndex]), StubDevmod^,
DevMode^, DM_IN_BUFFER);
PaperForms.IndexOfCode(PaperCode).PaperWidth := Value;
end;
end;
function THPrinter.GetPrinterIndex: Integer;
begin
if FPrinterIndex = -1 then
SetToDefaultPrinter;
Result := FPrinterIndex;
end;
procedure THPrinter.SetPrinterIndex(Value: Integer);
begin
CheckPrinting(False);
if (Value = -1) or (PrinterIndex = -1) then
SetToDefaultPrinter
else
if (Value < 0) or (Value >= Printers.Count) then
RaiseError(SPrinterIndexError);
FPrinterIndex := Value;
FreeFonts;
SetState(pshNoHandle);
end;
function THPrinter.GetPrinters: TStrings;
var
LineCur, Port: PChar;
Buffer, PrinterInfo: PChar;
Flags, Count, NumInfo: DWORD;
I: Integer;
Level: Byte;
begin
if FPrinters = nil then
begin
FPrinters := TStringList.Create;
Result := FPrinters;
try
if Win32Platform = VER_PLATFORM_WIN32_NT then
begin
Flags := PRINTER_ENUM_CONNECTIONS or PRINTER_ENUM_LOCAL;
Level := 4;
end
else
begin
Flags := PRINTER_ENUM_LOCAL;
Level := 5;
end;
Count := 0;
EnumPrinters(Flags, nil, Level, nil, 0, Count, NumInfo);
if Count = 0 then
Exit;
GetMem(Buffer, Count);
try
if not EnumPrinters(Flags, nil, Level, PByte(Buffer), Count, Count, NumInfo) then
Exit;
PrinterInfo := Buffer;
for I := 0 to NumInfo - 1do
begin
if Level = 4 then
with PPrinterInfo4(PrinterInfo)^do
begin
FPrinters.AddObject(pPrinterName,
TPrinterDevice.Create(nil, pPrinterName, nil));
Inc(PrinterInfo, sizeof(TPrinterInfo4));
end
else
with PPrinterInfo5(PrinterInfo)^do
begin
LineCur := pPortName;
Port := FetchStr(LineCur);
while Port^ <> #0do
begin
FPrinters.AddObject(Format(SDeviceOnPort, [pPrinterName, Port]),
TPrinterDevice.Create(nil, pPrinterName, Port));
Port := FetchStr(LineCur);
end;
Inc(PrinterInfo, sizeof(TPrinterInfo5));
end;
end;
finally
FreeMem(Buffer, Count);
end;
except
FPrinters.Free;
FPrinters := nil;
raise;
end;
end;
Result := FPrinters;
end;
procedure THPrinter.SetToDefaultPrinter;
var
I: Integer;
ByteCnt, StructCnt: DWORD;
DefaultPrinter: array[0..79] of Char;
Cur, Device: PChar;
PrinterInfo: PPrinterInfo5;
begin
ByteCnt := 0;
StructCnt := 0;
if not EnumPrinters(PRINTER_ENUM_DEFAULT, nil, 5, nil, 0, ByteCnt,
StructCnt) and (GetLastError <> ERROR_INSUFFICIENT_BUFFER) then
begin
// With no printers installed, Win95/98 fails above with "Invalid filename".
// NT succeeds and returns a StructCnt of zero.
if GetLastError = ERROR_INVALID_NAME then
RaiseError(SNoDefaultPrinter)
else
RaiseLastOSError;
end;
PrinterInfo := AllocMem(ByteCnt);
try
EnumPrinters(PRINTER_ENUM_DEFAULT, nil, 5, PrinterInfo, ByteCnt, ByteCnt,
StructCnt);
if StructCnt > 0 then
Device := PrinterInfo.pPrinterName
else
begin
GetProfileString('windows', 'device', '', DefaultPrinter,
SizeOf(DefaultPrinter) - 1);
Cur := DefaultPrinter;
Device := FetchStr(Cur);
end;
with Printersdo
for I := 0 to Count-1do
begin
if TPrinterDevice(Objects).Device = Device then
begin
with TPrinterDevice(Objects)do
SetPrinter(PChar(Device), PChar(Driver), PChar(Port), 0);
Exit;
end;
end;
finally
FreeMem(PrinterInfo);
end;
RaiseError(SNoDefaultPrinter);
end;
procedure THPrinter.FreePrinters;
var
I: Integer;
begin
if FPrinters <> nil then
begin
for I := 0 to FPrinters.Count - 1do
FPrinters.Objects.Free;
FreeAndNil(FPrinters);
end;
end;
procedure THPrinter.FreeFonts;
begin
FreeAndNil(FFonts);
end;
function HPrinter: THPrinter;
begin
if FPrinter = nil then
FPrinter := THPrinter.Create;
Result := FPrinter;
end;
function SetHPrinter(NewPrinter: THPrinter): THPrinter;
begin
Result := FPrinter;
FPrinter := NewPrinter;
end;
procedure THPrinter.Refresh;
begin
FreeFonts;
FreePrinters;
end;
initialization
finalization
FPrinter.Free;
end.
DevMode;