STPRINT

Top  Previous  Next

 

{  StellaSOFT printer unit }

 

 

unit Stprint;

 

interface

 

Uses SysUtils, WinTypes, WinProcs, Classes, Graphics, Printers, Extctrls;

 

Type TPrinterAspect = record

     aspx, aspy  : real;

   end;

 

Function IsPrinter:boolean;

Function GetPrinterMargins:TPoint;

Function GetPrinterPageSize:TPoint;

Function GetPrinterAspect:TPrinterAspect;

       {Printer torzitási szorsókat adja vissza}

Function GetPrAspectX:integer;

       {Printer X irányú torzitási szorsóját adja vissza}

Function GetPrAspectY:integer;

       {Printer Y irányú torzitási szorsóját adja vissza}

Function PixpermmX:integer;    {pixel/mm a printeren}

Function PixpermmY:integer;    {pixel/mm a printeren}

Function PageWidthmm:integer;

Function PageHeightmm:integer;

{procedure PrintPicture(im:TImage);}

 

{ LPT portok közvetlen elérése }

function LPTOpen(LPTn:integer):integer;

function LPTClose(Handle:integer):boolean;

function LPTSendChar(Handle:integer;Kar:Char):boolean;

 

function IsLPT(LPTn:word):boolean;

procedure SendByteToLPT(LPTn:word;Data:byte);

 

function GetAmiBiosPassword:string;

 

Var ScaleX,ScaleY : integer;         {x,y pixel/inch}

  Xmm,Ymm       : integer;         {x,y pixel/mm}

 

Const  inch  : real = 24.180;

 

implementation

 

Function IsPrinter:boolean;

begin

Try

  GetDeviceCaps(Printer.Handle, logPixelsX);

  Result:=True;

except

  Result:=False;

end;

end;

 

{A bal és felső margót szélességét adja}

Function GetPrinterMargins:TPoint;

begin

Escape(Printer.Handle, GETPRINTINGOFFSET,0,nil,@Result);

end;

 

{A lap méretét adja}

Function GetPrinterPageSize:TPoint;

begin

 Escape(Printer.Handle, GETPHYSPAGESIZE,0,nil,@Result);

end;

 

{Közvetlenül a printer portra köld egy stringet}

Procedure DirectPrint(s : String);

Type

      TPassThroughData = Record

              nLen : Integer;

              Data : Array[0..255] of byte;

      end;

      var

      PTBlock : TPassThroughData;

Begin

      PTBlock.nLen := Length(s);

      StrPCopy(@PTBlock.Data,s);

      Escape(printer.handle, PASSTHROUGH,0,@PTBlock,nil);

End;

 

Function GetPrinterAspect:TPrinterAspect;

begin

Result.aspx := 1;

Result.aspy := 1;

If IsPrinter then begin

Result.aspx := GetPrAspectX;

Result.aspy := GetPrAspectY;

end;

end;

 

Function GetPrAspectX:integer;

begin

If IsPrinter then

  ScaleX := GetDeviceCaps(Printer.Handle, logPixelsX)

else ScaleX := 1;

  Result := ScaleX;

end;

 

Function GetPrAspectY:integer;

begin

If IsPrinter then

  ScaleY := GetDeviceCaps(Printer.Handle, logPixelsY)

else ScaleY := 1;

  Result := ScaleY;

end;

 

Function PixpermmX:integer;

begin

   If IsPrinter then

      Result := GetDeviceCaps(Printer.Handle,HORZRES) div

                GetDeviceCaps(Printer.Handle,HORZSIZE)

   else Result := 24;

end;

 

Function PixpermmY:integer;

begin

   If IsPrinter then

      Result := GetDeviceCaps(Printer.Handle,VERTRES) div

                GetDeviceCaps(Printer.Handle,VERTSIZE)

   else Result := 24;

end;

 

Function PageWidthmm:integer;

begin

 If IsPrinter then Result := GetDeviceCaps(Printer.Handle,HORZSIZE)

 else Result := 0;

end;

 

Function PageHeightmm:integer;

begin

 If IsPrinter then Result := GetDeviceCaps(Printer.Handle,VERTSIZE)

 else Result := 0;

end;

{

procedure PrintPicture(im:TImage);

var

ScaleX, ScaleY: Integer;

R: TRect;

begin

Printer.BeginDoc;

with Printer do

try

  ScaleX := GetDeviceCaps(Handle, logPixelsX) div PixelsPerInch;

  ScaleY := GetDeviceCaps(Handle, logPixelsY) div PixelsPerInch;

  R := Rect(0, 0, Im.Picture.Width * ScaleX,

    Im.Picture.Height * ScaleY);

  Canvas.StretchDraw(R, Im.Picture.Graphic);

finally

  EndDoc;

end;

end;

}

 

{Megnyitja az LPTn=1,2,3 LPT portokat és visszadja a a port Handle-t,

         hiba esetén a Handle < 0}

function LPTOpen(LPTn:integer):integer;

var Data : array[0..4] of char;

  s    : string;

begin

s:='LPT'+IntToStr(LPTn);

StrPCopy(Data,s);

Result := OpenComm(Data,0,0);

end;

 

{Lezárja a Handle által meghatározott portot:

       LPTOpen a Handle értékkel tér vissza}

function LPTClose(Handle:integer):boolean;

begin

Result := CloseComm(Handle)=0;

end;

 

{A megnyitott portra küld egy karaktert}

function LPTSendChar(Handle:integer;Kar:Char):boolean;

begin

Result := TransmitCommChar(Handle,kar)=0;

end;

 

{Ha az LPTn=1..4 port létezik akkor igaz}

function IsLPT(LPTn:word):boolean;

begin

  Result := Word(ptr($0040, $0008 + (LPTn - 1) * 2)^)<>0;

end;

 

{1 byte adatot küld az LPTn=1..4 portra}

procedure SendByteToLPT(LPTn:word;Data:byte);

Var

PrinterPort:Array[1..4] Of Byte Absolute $40:$8;

Begin

Port[PrinterPort[LPTn]]:=Data;

End;

 

function GetAmiBiosPassword:string;

VAR

BYTEBUFFER:ARRAY [0..6] OF BYTE;

SENHA:STRING[6];

A,I,CARAC,PREVIO,TMPA,TMPB:WORD;

begin

SENHA:='';

FOR A:=$37 TO ($3D) DO

 BEGIN

 PORT[$70]:=A;

 BYTEBUFFER[A-$37]:=PORT[$71];

 END;

SENHA:='';

BYTEBUFFER[0]:=BYTEBUFFER[0] AND $F0;

I:=1;

WHILE (I<7) AND (BYTEBUFFER[I]<>0) DO

 BEGIN

 CARAC:=0;

 PREVIO:=BYTEBUFFER[I-1];

 WHILE (PREVIO<>BYTEBUFFER[I]) DO

    BEGIN

    INC(CARAC);

    TMPA:=0;

    TMPB:=0;

    IF (PREVIO AND $80>0) THEN

       INC(TMPA);

    IF (PREVIO AND $40)>0 THEN

       INC(TMPA);

    IF (PREVIO AND $02)>0 THEN

       INC(TMPA);

    IF (PREVIO AND $01)>0 THEN

       INC(TMPA);

    WHILE TMPB<TMPA DO

       INC(TMPB,2);

    PREVIO:=PREVIO DIV 2;

    DEC(TMPB,TMPA);

    IF TMPB=1 THEN

       INC(PREVIO,$80);

    END;

 SENHA:=SENHA+CHR(CARAC);

 INC(I);

 END;

 IF I=1 THEN Result:='' else Result:=SENHA;

end;

 

end.