Kod: Tümünü seç
uses
Printers;
function GetPixelsPerInchX: Integer;
begin
Result := GetDeviceCaps(Printer.Handle, LOGPIXELSX)
end;
function GetPixelsPerInchY: Integer;
begin
Result := GetDeviceCaps(Printer.Handle, LOGPIXELSY)
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Caption := Format('x: %d y: %d DPI (dots per inch)',
[GetPixelsPerInchX, GetPixelsPerInchY]);
end;
Kod: Tümünü seç
{
By using the Windows API Escape() function,
your application can pass data directly to the printer.
If the printer driver supports the PASSTHROUGH printer escape,
you can use the Escape() function and the PASSTHROUGH printer escape
to send native printer language codes to the printer driver.
If the printer driver does not support the PASSTHROUGH printer escape,
you must use the DeviceCapabilities() and ExtDevMode() functions instead.
Mit der Windows API Funktion Escape() kann man Daten direkt zum Drucker schicken.
Wenn der Drucker Treiber dies nicht unterstützt, müssen die DeviceCapabilities()
und ExtDevMode() Funktionen verwendet werden.
}
// DOS like printing using Passthrough command
// you should use "printer.begindoc" and "printer.enddoc"
type
TPrnBuffRec = record
bufflength: Word;
Buff_1: array[0..255] of Char;
end;
function DirectToPrinter(S: string; NextLine: Boolean): Boolean;
var
Buff: TPrnBuffRec;
TestInt: Integer;
begin
TestInt := PassThrough;
if Escape(Printer.Handle, QUERYESCSUPPORT, SizeOf(TESTINT), @testint, nil) > 0 then
begin
if NextLine then S := S + #13 + #10;
StrPCopy(Buff.Buff_1, S);
Buff.bufflength := StrLen(Buff.Buff_1);
Escape(Printer.Canvas.Handle, Passthrough, 0, @buff, nil);
Result := True;
end
else
Result := False;
end;
// this code works if the printer supports escape commands
// you can get special esc codes from printer's manual
// example:
printer.BeginDoc;
try
directoprinter('This text ');
finally
printer.EndDoc;
end;
Kod: Tümünü seç
{1.}
uses
Printers;
procedure TForm1.Button1Click(Sender: TObject);
var
ScaleX, ScaleY: Integer;
RR: TRect;
begin
with Printer do
begin
BeginDoc;
// Mit BeginDoc wird ein Druckauftrag initiiert.
// The StartDoc function starts a print job.
try
ScaleX := GetDeviceCaps(Handle, logPixelsX) div PixelsPerInch;
ScaleY := GetDeviceCaps(Handle, logPixelsY) div PixelsPerInch;
// Informationen über die Auflösung
// Retrieves information about the Pixels per Inch of the Printer.
RR := Rect(0, 0, Image1.picture.Width * scaleX, Image1.Picture.Height * ScaleY);
Canvas.StretchDraw(RR, Image1.Picture.Graphic);
// An die Auflösung anpassen
// Stretch to fit
finally
EndDoc; //Methode EndDoc beendet den aktuellen Druckauftrag und schließt die
// Textdatei-Variable.
// Steht in finally - um auch bei Abbruch des Druckauftrages Papierausgabe
// sicherzustellen
end;
end;
end;
{2.}
{************************************************************************}
// Based on posting to borland.public.delphi.winapi by Rodney E Geraghty, 8/8/97.
procedure PrintBitmap(Canvas: TCanvas; DestRect: TRect; Bitmap: TBitmap);
var
BitmapHeader: pBitmapInfo;
BitmapImage: Pointer;
HeaderSize: DWORD;
ImageSize: DWORD;
begin
GetDIBSizes(Bitmap.Handle, HeaderSize, ImageSize);
GetMem(BitmapHeader, HeaderSize);
GetMem(BitmapImage, ImageSize);
try
GetDIB(Bitmap.Handle, Bitmap.Palette, BitmapHeader^, BitmapImage^);
StretchDIBits(Canvas.Handle,
DestRect.Left, DestRect.Top, // Destination Origin
DestRect.Right - DestRect.Left, // Destination Width
DestRect.Bottom - DestRect.Top, // Destination Height
0, 0, // Source Origin
Bitmap.Width, Bitmap.Height, // Source Width & Height
BitmapImage,
TBitmapInfo(BitmapHeader^),
DIB_RGB_COLORS,
SRCCOPY)
finally
FreeMem(BitmapHeader);
FreeMem(BitmapImage)
end
end {PrintBitmap};
{3.}
{************************************************************************}
// from www.experts-exchange.com
uses
printers;
procedure DrawImage(Canvas: TCanvas; DestRect: TRect; ABitmap: TBitmap);
var
Header, Bits: Pointer;
HeaderSize: DWORD;
BitsSize: DWORD;
begin
GetDIBSizes(ABitmap.Handle, HeaderSize, BitsSize);
Header := AllocMem(HeaderSize);
Bits := AllocMem(BitsSize);
try
GetDIB(ABitmap.Handle, ABitmap.Palette, Header^, Bits^);
StretchDIBits(Canvas.Handle, DestRect.Left, DestRect.Top,
DestRect.Right, DestRect.Bottom,
0, 0, ABitmap.Width, ABitmap.Height, Bits, TBitmapInfo(Header^),
DIB_RGB_COLORS, SRCCOPY);
finally
FreeMem(Header, HeaderSize);
FreeMem(Bits, BitsSize);
end;
end;
procedure PrintImage(Image: TImage; ZoomPercent: Integer);
// if ZoomPercent=100, Image will be printed across the whole page
var
relHeight, relWidth: integer;
begin
Screen.Cursor := crHourglass;
Printer.BeginDoc;
with Image.Picture.Bitmap do
begin
if ((Width / Height) > (Printer.PageWidth / Printer.PageHeight)) then
begin
// Stretch Bitmap to width of PrinterPage
relWidth := Printer.PageWidth;
relHeight := MulDiv(Height, Printer.PageWidth, Width);
end
else
begin
// Stretch Bitmap to height of PrinterPage
relWidth := MulDiv(Width, Printer.PageHeight, Height);
relHeight := Printer.PageHeight;
end;
relWidth := Round(relWidth * ZoomPercent / 100);
relHeight := Round(relHeight * ZoomPercent / 100);
DrawImage(Printer.Canvas, Rect(0, 0, relWidth, relHeight), Image.Picture.Bitmap);
end;
Printer.EndDoc;
Screen.cursor := crDefault;
end;
// Example Call:
procedure TForm1.Button1Click(Sender: TObject);
begin
// Print image at 40% zoom:
PrintImage(Image1, 40);
end;
Kod: Tümünü seç
uses
Winspool, Printers;
function GetCurrentPrinterHandle: THandle;
var
Device, Driver, Port: array[0..255] of Char;
hDeviceMode: THandle;
begin
Printer.GetPrinter(Device, Driver, Port, hDeviceMode);
if not OpenPrinter(@Device, Result, nil) then
RaiseLastWin32Error;
end;
function SavePChar(p: PChar): PChar;
const
error: PChar = 'Nil';
begin
if not Assigned(p) then
Result := error
else
Result := p;
end;
procedure TForm1.Button1Click(Sender: TObject);
type
TJobs = array [0..1000] of JOB_INFO_1;
PJobs = ^TJobs;
var
hPrinter: THandle;
bytesNeeded, numJobs, i: Cardinal;
pJ: PJobs;
begin
hPrinter := GetCurrentPrinterHandle;
try
EnumJobs(hPrinter, 0, 1000, 1, nil, 0, bytesNeeded,
numJobs);
pJ := AllocMem(bytesNeeded);
if not EnumJobs(hPrinter, 0, 1000, 1, pJ, bytesNeeded,
bytesNeeded, numJobs) then
RaiseLastWin32Error;
memo1.Clear;
if numJobs = 0 then
memo1.Lines.Add('No jobs in queue')
else
for i := 0 to Pred(numJobs) do
memo1.Lines.Add(Format('Printer %s, Job %s, Status (%d): %s',
[SavePChar(pJ^[i].pPrinterName), SavePChar(pJ^[i].pDocument),
pJ^[i].Status, SavePChar(pJ^[i].pStatus)]));
finally
ClosePrinter(hPrinter);
end;
end;
Kod: Tümünü seç
uses
Winspool, Printers;
function GetCurrentPrinterHandle: THandle;
var
Device, Driver, Port: array[0..255] of Char;
hDeviceMode: THandle;
begin
Printer.GetPrinter(Device, Driver, Port, hDeviceMode);
if not OpenPrinter(@Device, Result, nil) then
RaiseLastWin32Error;
end;
function SavePChar(p: PChar): PChar;
const
error: PChar = 'Nil';
begin
if not Assigned(p) then
Result := error
else
Result := p;
end;
procedure TForm1.Button1Click(Sender: TObject);
type
TJobs = array [0..1000] of JOB_INFO_1;
PJobs = ^TJobs;
var
hPrinter: THandle;
bytesNeeded, numJobs, i: Cardinal;
pJ: PJobs;
begin
hPrinter := GetCurrentPrinterHandle;
try
EnumJobs(hPrinter, 0, 1000, 1, nil, 0, bytesNeeded,
numJobs);
pJ := AllocMem(bytesNeeded);
if not EnumJobs(hPrinter, 0, 1000, 1, pJ, bytesNeeded,
bytesNeeded, numJobs) then
RaiseLastWin32Error;
memo1.Clear;
if numJobs = 0 then
memo1.Lines.Add('No jobs in queue')
else
for i := 0 to Pred(numJobs) do
memo1.Lines.Add(Format('Printer %s, Job %s, Status (%d): %s',
[SavePChar(pJ^[i].pPrinterName), SavePChar(pJ^[i].pDocument),
pJ^[i].Status, SavePChar(pJ^[i].pStatus)]));
finally
ClosePrinter(hPrinter);
end;
end;
Kod: Tümünü seç
uses
WinSpool, Printers;
procedure GetPaperBins(sl: TStrings);
type
TBinName = array [0..23] of Char;
TBinNameArray = array [1..High(Integer) div SizeOf(TBinName)] of TBinName;
PBinnameArray = ^TBinNameArray;
TBinArray = array [1..High(Integer) div SizeOf(Word)] of Word;
PBinArray = ^TBinArray;
var
Device, Driver, Port: array [0..255] of Char;
hDevMode: THandle;
i, numBinNames, numBins, temp: Integer;
pBinNames: PBinnameArray;
pBins: PBinArray;
begin
Printer.PrinterIndex := -1;
Printer.GetPrinter(Device, Driver, Port, hDevmode);
numBinNames := WinSpool.DeviceCapabilities(Device, Port, DC_BINNAMES, nil, nil);
numBins := WinSpool.DeviceCapabilities(Device, Port, DC_BINS, nil, nil);
if numBins <> numBinNames then
begin
raise Exception.Create('DeviceCapabilities reports different number of bins and bin names!');
end;
if numBinNames > 0 then
begin
pBins := nil;
GetMem(pBinNames, numBinNames * SizeOf(TBinname));
GetMem(pBins, numBins * SizeOf(Word));
try
WinSpool.DeviceCapabilities(Device, Port, DC_BINNAMES, PChar(pBinNames), nil);
WinSpool.DeviceCapabilities(Device, Port, DC_BINS, PChar(pBins), nil);
sl.Clear;
for i := 1 to numBinNames do
begin
temp := pBins^[i];
sl.addObject(pBinNames^[i], TObject(temp));
end;
finally
FreeMem(pBinNames);
if pBins <> nil then
FreeMem(pBins);
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
GetPaperBins(Listbox1.Items);
end;
Kod: Tümünü seç
uses
Printers, WinSpool;
procedure TForm1.Button1Click(Sender: TObject);
var
Dev, Drv, Prt: array[0..255] of Char;
DM1: PDeviceMode;
DM2: PDeviceMode;
Sz: Integer;
DevM: THandle;
begin
Printer.PrinterIndex := -1;
Printer.GetPrinter(Dev, Drv, Prt, DevM);
DM1 := nil;
DM2 := nil;
Sz := DocumentProperties(0, 0, Dev, DM1^, DM2^, 0);
GetMem(DM1, Sz);
DocumentProperties(0, 0, Dev, DM1^, DM2^, DM_OUT_BUFFER);
if DM1^.dmColor > 1 then
label1.Caption := Dev + ': Color'
else
label1.Caption := Dev + ': Black and White';
if DM1^.dmFields and DM_Color <> 0 then
Label2.Caption := 'Printer supports color printing'
else
Label2.Caption := 'Printer does not support color printing';
FreeMem(DM1);
end;Kod: Tümünü seç
{1.}
procedure TForm1.Button1Click(Sender: TObject);
var
port, prnfile: file;
buffer: array [1..128] of Char;
Read: Integer;
begin
// Specify a file to print
AssignFile(prnfile, 'filetoprint');
Reset(prnfile, 1);
// specify printer port
AssignFile(port, 'LPT1');
Rewrite(port, 1);
repeat
BlockRead(prnfile, buffer, SizeOf(buffer), Read);
BlockWrite(port, buffer, Read);
// Application.ProcessMessages;
until EOF(prnfile) or (Read <> SizeOf(buffer));
CloseFile(prnfile);
CloseFile(port);
end;
{*****************************************************}
{2.}
{
Question:
How do I write a raw string of a data to the printer?
The following unit "PrtRaw.pas" demonstrates a 16/32 bit
raw printing unit for Delphi and Borland C Builder.
Following the unit, is an exmaple on using the
PrtRaw unit.
Notes:
1) You are responsible for embedding all necessary
control codes that the printer may require (including
form feed codes).
2) You must specify a valid printer and port name.
}
unit PrtRaw;
{Copyright (c) 1998 by Joe C. Hecht - All rights Reserved}
{joehecht@gte.net You may use and share this unit}
{providing my name and the copyright notice stays intact.}
interface
uses
WinTypes;
{$IFDEF WIN32}
type SpoolInt = DWORD;
{$ELSE}
type SpoolInt = integer;
{$ENDIF}
function StartRawPrintJob(PrinterName : pChar;
Port : pChar;
DocName : pChar) : THandle;
function StartRawPrintPage(hPrn : THandle) : integer;
function PrintRawData(hPrn : THandle;
Buffer : pointer;
NumBytes : SpoolInt) : integer;
function EndRawPrintPage(hPrn : THandle) : integer;
function EndRawPrintJob(hPrn : THandle) : integer;
implementation
uses
WinProcs,
{$IFDEF WIN32}
WinSpool;
{$ELSE}
Print;
{$ENDIF}
function StartRawPrintJob(PrinterName : pChar;
Port : pChar;
DocName : pChar) : THandle;
{$IFDEF WIN32}
var
hPrn : THandle;
DocInfo1 : TDocInfo1;
{$ENDIF}
begin
{$IFDEF WIN32}
if (OpenPrinter(PChar(PrinterName),
hPrn,
nil) = FALSE) then
begin
Result := THandle(-1);
Exit;
end;
DocInfo1.pDocName := DocName;
DocInfo1.pOutputFile := Port;
DocInfo1.pDataType := 'RAW';
if (StartDocPrinter(hPrn,
1,
@DocInfo1) = 0) then
begin
Result := THandle(-1);
Exit;
end;
Result := hPrn;
{$ELSE}
result := OpenJob(Port,
DocName,
0);
{$ENDIF}
end;
function StartRawPrintPage(hPrn : THandle) : integer;
begin
{$IFDEF WIN32}
if (StartPagePrinter(hPrn) = FALSE) then
begin
Result := -1;
Exit;
end;
result := 1;
{$ELSE}
result := StartSpoolPage(hPrn);
{$ENDIF}
end;
function PrintRawData(hPrn : THandle;
Buffer : pointer;
NumBytes : SpoolInt) : integer;
{$IFDEF WIN32}
var
BytesWritten : DWORD;
{$ENDIF}
begin
if (NumBytes = 0) then
begin
Result := 1;
Exit;
end;
{$IFDEF WIN32}
if (WritePrinter(hPrn,
Buffer,
NumBytes,
BytesWritten) = FALSE) then
begin
Result := -1;
Exit;
end;
if (NumBytes <> BytesWritten) then
begin
Result := -1;
Exit;
end;
Result := 1;
{$ELSE}
result := WriteSpool(hPrn,
Buffer,
NumBytes);
{$ENDIF}
end;
function EndRawPrintPage(hPrn : THandle) : integer;
begin
{$IFDEF WIN32}
if (EndPagePrinter(hPrn) = FALSE) then
begin
Result := -1;
Exit;
end;
Result := 1;
{$ELSE}
result := EndSpoolPage(hPrn);
{$ENDIF}
end;
function EndRawPrintJob(hPrn : THandle) : integer;
begin
{$IFDEF WIN32}
if (EndDocPrinter(hPrn) = FALSE) then
begin
Result := -1;
Exit;
end;
if (ClosePrinter(hPrn) = FALSE) then
begin
Result := -1;
Exit;
end;
Result := 1;
{$ELSE}
result := CloseJob(hPrn);
{$ENDIF}
end;
end.
// Example of use:
uses
PrtRaw;
procedure TForm1.Button1Click(Sender: TObject);
var
hPrn : THandle;
Data : array[0..31] of char;
begin
hPrn := StartRawPrintJob('Generic / Text Only',
'LPT1:',
'My Document');
if (integer(hPrn) < 0) then
begin
ShowMessage('StartRawPrintJob Failed');
Exit;
end;
if (StartRawPrintPage(hPrn) < 0) then
begin
ShowMessage('StartRawPrintPage Failed');
EndRawPrintJob(hPrn);
Exit;
end;
Data[0] := 'P';
Data[1] := 'a';
Data[2] := 'g';
Data[3] := 'e';
Data[4] := #32;
Data[5] := '1';
Data[6] := #13;
Data[7] := #10;
if (PrintRawData(hPrn,
@data,
8) < 0) then
begin
ShowMessage('PrintRawData Failed');
EndRawPrintPage(hPrn);
EndRawPrintJob(hPrn);
Exit;
end;
if (EndRawPrintPage(hPrn) < 0) then
begin
ShowMessage('EndRawPrintPage Failed');
EndRawPrintJob(hPrn);
Exit;
end;
if (StartRawPrintPage(hPrn) < 0) then
begin
ShowMessage('StartRawPrintPage Failed');
EndRawPrintJob(hPrn);
Exit;
end;
Data[0] := 'P';
Data[1] := 'a';
Data[2] := 'g';
Data[3] := 'e';
Data[4] := #32;
Data[5] := '2';
Data[6] := #13;
Data[7] := #10;
if (PrintRawData(hPrn,
@data,
8) < 0) then
begin
ShowMessage('PrintRawData Failed');
EndRawPrintPage(hPrn);
EndRawPrintJob(hPrn);
Exit;
end;
if (EndRawPrintPage(hPrn) < 0) then
begin
ShowMessage('EndRawPrintPage Failed');
EndRawPrintJob(hPrn);
Exit;
end;
if (EndRawPrintJob(hPrn) < 0) then
begin
ShowMessage('EndRawPrintJob Failed');
Exit;
end;
end;
end.
Kod: Tümünü seç
{
Create a unit PrinterSetup and place code in this unit
Do the following to save the printer config to file
}
procedure TForm1.Button1Click(Sender: TObject);
var
PrinterSetup: TPrinterSetup
begin
PrinterSetup := TPrinterSetup.Create;
PrinterSetup.SaveSetup(FileName);
//where file name is a string to the location of the File ex.'c:\print.cfg'
PrinterSetup.Free;
end
{***********************************}
unit PrinterSetup;
interface
uses
printers,
windows,
SysUtils,
Classes,
WinSpool;
type
TPrinterSetup = class
private
Device, Driver, Port: array[0..CCHDEVICENAME] of char;
DeviceMode: THandle;
procedure Refresh;
protected
public
procedure SaveSetup(FileName: TFilename);
procedure LoadSetup(FileName: TFilename);
end;
TPrinterConfig = record
ADevice, ADriver, APort: array[0..CCHDEVICENAME] of char;
SizeOfDeviceMode: DWORD;
end;
implementation
procedure TPrinterSetup.Refresh;
begin
Printer.GetPrinter(Device, Driver, Port, DeviceMode);
end;
procedure TPrinterSetup.SaveSetup(FileName: TFilename);
var
StubDevMode: TDeviceMode;
SetupPrinter: TPrinterConfig;
FPrinterHandle: THandle;
fFileConfig: file of TPrinterConfig;
fFileDevMode: file of Char;
pDevMode: PChar;
Contador: Integer;
begin
Refresh;
with SetupPrinter do
begin
StrLCopy(ADevice, Device, SizeOf(ADevice));
StrLCopy(ADriver, Driver, SizeOf(ADriver));
StrLCopy(APort, Port, SizeOf(APort));
OpenPrinter(Device, FPrinterHandle, nil);
SizeOfDeviceMode := DocumentProperties(0, FPrinterHandle, Device,
StubDevMode, StubDevMode, 0);
end;
AssignFile(fFileConfig, FileName);
ReWrite(fFileConfig);
Write(fFileConfig, SetupPrinter);
CloseFile(fFileConfig);
AssignFile(fFileDevMode, FileName);
Reset(fFileDevMode);
Seek(fFileDevMode, FileSize(fFileDevMode));
pDevMode := GlobalLock(DeviceMode);
for Contador := 0 to SetupPrinter.SizeOfDeviceMode - 1 do
begin
Write(fFileDevMode, pDevMode[Contador]);
end;
CloseFile(fFileDevMode);
GlobalUnLock(DeviceMode);
end;
procedure TPrinterSetup.LoadSetup(FileName: TFilename);
var
SetupPrinter: TPrinterConfig;
fFileConfig: file of TPrinterConfig;
fFileDevMode: file of Char;
ADeviceMode: THandle;
pDevMode: PChar;
Contador: Integer;
begin
if FileExists(FileName) then
begin
AssignFile(fFileConfig, FileName);
Reset(fFileConfig);
read(fFileConfig, SetupPrinter);
CloseFile(fFileConfig);
AssignFile(fFileDevMode, FileName);
Reset(fFileDevMode);
Seek(fFileDevMode, SizeOf(SetupPrinter));
ADeviceMode := GlobalAlloc(GHND, SetupPrinter.SizeOfDeviceMode);
pDevMode := GlobalLock(ADeviceMode);
for Contador := 0 to SetupPrinter.SizeOfDeviceMode - 1 do
begin
read(fFileDevMode, char(pDevMode[Contador]));
end;
CloseFile(fFileDevMode);
GlobalUnLock(ADeviceMode);
Printer.SetPrinter(SetupPrinter.ADevice, SetupPrinter.ADriver,
SetupPrinter.APort, ADeviceMode);
end;
end;
end.Kod: Tümünü seç
{
This unit can be compiled into a package and will then appear in the delphi
Help menu.
}
unit SDCSimpleExpert;
interface
uses ToolsApi;
type
TSDCSimpleExpert = class(TNotifierObject, IOTAMenuWizard, IOTAWizard)
public
function GetIDString: string;
function GetName: string;
function GetState: TWizardState;
procedure Execute;
function GetMenuText: string;
end;
procedure Register;
implementation
uses Dialogs;
procedure Register;
begin
{register expert}
RegisterPackageWizard(TSDCSimpleExpert.Create);
end;
{ TSDCSimpleExpert }
procedure TSDCSimpleExpert.Execute;
begin
{code to execute when menu item is clicked}
ShowMessage('Hello SwissDelphiCenter Simple Expert.');
end;
function TSDCSimpleExpert.GetIDString: string;
begin
{unique expert identifier}
Result := 'SwissDelphiCenter.SimpleExpert';
end;
function TSDCSimpleExpert.GetMenuText: string;
begin
{caption of menu item in help menu}
Result := 'SwissDelphiCenter Simple Expert';
end;
function TSDCSimpleExpert.GetName: string;
begin
{name of the expert}
Result := 'SwissDelphiCenter Simple Expert';
end;
function TSDCSimpleExpert.GetState: TWizardState;
begin
Result := [wsEnabled];
end;
end.
Kod: Tümünü seç
unit printers;
begin
//...
Printer.PrinterIndex := -1;
DefaultPrnName := Printer.Printers.Strings[Printer.PrinterIndex];
//...
end;Kod: Tümünü seç
{ Changing the properties of a global printer object is a tedious task.
The code below allows to save current settings of any installed printer
to a stream using the SavePrinterInfo procedure. These settings include
vendor specific settings. }
{ Using LoadPrinterInfo, one can retrieve saved settings and apply these
to the printer. }
unit PrinterIO;
interface
uses
Classes;
procedure SavePrinterInfo(APrinterName: PChar; ADestStream: TStream);
procedure LoadPrinterInfo(APrinterName: PChar; ASourceStream: TStream);
implementation
uses
Windows, SysUtils, WinSpool;
procedure SavePrinterInfo(APrinterName: PChar; ADestStream: TStream);
var
HPrinter : THandle;
InfoSize,
BytesNeeded: Cardinal;
PI2: PPrinterInfo2;
PrinterDefaults: TPrinterDefaults;
begin
with PrinterDefaults do
begin
DesiredAccess := PRINTER_ACCESS_USE;
pDatatype := nil;
pDevMode := nil;
end;
if OpenPrinter(APrinterName, HPrinter, @PrinterDefaults) then
try
SetLastError(0);
//Determine the number of bytes to allocate for the PRINTER_INFO_2 construct...
if not GetPrinter(HPrinter, 2, nil, 0, @BytesNeeded) then
begin
//Allocate memory space for the PRINTER_INFO_2 pointer (PrinterInfo2)...
PI2 := AllocMem(BytesNeeded);
try
InfoSize := SizeOf(TPrinterInfo2);
if GetPrinter(HPrinter, 2, PI2, BytesNeeded, @BytesNeeded) then
ADestStream.Write(PChar(PI2)[InfoSize], BytesNeeded - InfoSize);
finally
FreeMem(PI2, BytesNeeded);
end;
end;
finally
ClosePrinter(HPrinter);
end;
end;
procedure LoadPrinterInfo(APrinterName: PChar; ASourceStream: TStream);
var
HPrinter : THandle;
InfoSize,
BytesNeeded: Cardinal;
PI2: PPrinterInfo2;
PrinterDefaults: TPrinterDefaults;
begin
with PrinterDefaults do
begin
DesiredAccess := PRINTER_ACCESS_USE;
pDatatype := nil;
pDevMode := nil;
end;
if OpenPrinter(APrinterName, HPrinter, @PrinterDefaults) then
try
SetLastError(0);
//Determine the number of bytes to allocate for the PRINTER_INFO_2 construct...
if not GetPrinter(HPrinter, 2, nil, 0, @BytesNeeded) then
begin
//Allocate memory space for the PRINTER_INFO_2 pointer (PrinterInfo2)...
PI2 := AllocMem(BytesNeeded);
try
InfoSize := SizeOf(TPrinterInfo2);
if GetPrinter(HPrinter, 2, PI2, BytesNeeded, @BytesNeeded) then
begin
PI2.pSecurityDescriptor := nil;
ASourceStream.ReadBuffer(PChar(PI2)[InfoSize], BytesNeeded - InfoSize);
// Apply settings to the printer
if DocumentProperties(0, hPrinter, APrinterName, PI2.pDevMode^,
PI2.pDevMode^, DM_IN_BUFFER or DM_OUT_BUFFER) = IDOK then
begin
SetPrinter(HPrinter, 2, PI2, 0); // Ignore the result of this call...
end;
end;
finally
FreeMem(PI2, BytesNeeded);
end;
end;
finally
ClosePrinter(HPrinter);
end;
end;
end.Kod: Tümünü seç
Kod: Tümünü seç
{
If you need to create your own printer dialog, you can use the PrinterProperties
API function to bring up a printer's properties dialog.
}
uses
WinSpool, Printers;
procedure TForm1.Button1Click(Sender: TObject);
const
{
The TPrinterDefaults structure specifies the default data type,
environment, initialization data, and access rights for a printer.
}
Defaults: TPrinterDefaults = (pDatatype: nil;
pDevMode: nil;
DesiredAccess: STANDARD_RIGHTS_REQUIRED or PRINTER_ACCESS_USE);
var
hPrinter: THandle;
Device: array[0..255] of char;
Driver: array[0..255] of char;
Port: array[0..255] of char;
hDeviceMode: THandle;
RetVal: Boolean;
begin
Printer.PrinterIndex := Combobox1.ItemIndex;
{ Retrieve information about the specified printer }
Printer.GetPrinter(Device,
Driver,
Port,
hDeviceMode);
{ Retrieve a handle identifying the specified printer or print }
if not OpenPrinter(@Device, hPrinter, @Defaults) then
RaiseLastWin32Error;
try
{ Display a printer-properties property sheet for the specified printer }
PrinterProperties(Handle, hPrinter);
finally
{ Close the specified printer object }
ClosePrinter(hPrinter);
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
{ Show available printers in a Combobox }
Combobox1.Items := Printer.Printers;
Combobox1.ItemIndex := 0;
end;Kod: Tümünü seç
{
TWebBrowser can use native IE API to print and do other things.
Implement on a Form a TWebBrowser component, and a button to print.
The code attached to this button is as follow :
}
//--------------------------------------------
procedure TForm.OnClickPrint(Sender: TObject);
begin
WebBrowser.ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_PROMPTUSER);
end;
//--------------------------------------------
You can replace "OLECMDID_PRINT" by other possibilities :
OLECMDID_OPEN OLECMDID_NEW OLECMDID_SAVE
OLECMDID_SAVEAS OLECMDID_SAVECOPYAS OLECMDID_PRINT
OLECMDID_PRINTPREVIEW OLECMDID_PAGESETUP OLECMDID_SPELL
OLECMDID_PROPERTIES OLECMDID_CUT OLECMDID_COPY
OLECMDID_PASTE OLECMDID_PASTESPECIAL OLECMDID_UNDO
OLECMDID_REDO OLECMDID_SELECTALL OLECMDID_CLEARSELECTION
OLECMDID_ZOOM OLECMDID_GETZOOMRANGE OLECMDID_UPDATECOMMANDS
OLECMDID_REFRESH OLECMDID_STOP OLECMDID_HIDETOOLBARS
OLECMDID_SETPROGRESSMAX OLECMDID_SETPROGRESSPOS
OLECMDID_SETPROGRESSTEXT
OLECMDID_SETTITLE OLECMDID_SETDOWNLOADSTATE OLECMDID_STOPDOWNLOAD
OLECMDID_FIND OLECMDID_ONTOOLBARACTIVATED OLECMDID_DELETE
OLECMDID_HTTPEQUIV OLECMDID_ENABLE_INTERACTION OLECMDID_HTTPEQUIV_DONE
OLECMDID_ONUNLOAD OLECMDID_PROPERTYBAG2 OLECMDID_PREREFRESH