cpwprint.pas

生物信息学中的遗传数据分析的delphi源码。

{*********************************************}
{                                             }
{    COMPONENT for MS DOS and MS WINDOWS      }
{                                             }
{    Source code for Turbo Pascal 6.0 and     }
{    Turbo Pasacal for Windows 1.0 compilers. }
{                                             }
{    (c) 1991, Roderic D. M. Page             }
{                                             }
{*********************************************}


{* Windows printing module *}

{* 28 Aug 1991 *}


{*
   18 Oct 1991 Finally worked out how to call DeviceMode function
               using Turbo Pascal.  The pointer from GetProcAddress
               is type cast into a procedure of the type TDeviceMode
               (declared in WinTypes) and then executed.

   21 Apr 1992 Support for older printer drivers (such as Epson FX-80)
               improved by using Windows Escape calls to retrieve paper
	       sizes. (Fixes at least part of Leiden bug #13.)

   30 Jul 1992 Supports TPW 1.5.
*}

{$I CPDIR.INC}

unit cpwprint;

interface

uses
   WinCrt,
   WinTypes,
   WinProcs,
   {$IFDEF BWCC}
   BWCC,
   {$IFDEF VER10}
   WObjectB,
   {$ELSE}
   WObjects,
   {$ENDIF} {VER10}
   {$ELSE}
   WObjects,
   {$ENDIF}
   Strings,
   cpheader,  { dialog ids }
   cpwvars,   { defines szAppName }
   cpwdlg;    { standard dialogs }

const
  MaxNumFonts =  20;

type
  PrinterRec=record
     wPaper,
     hPaper,
     xMargin,
     yMargin : integer;
     xPixels,
     yPixels : integer;
     Orientation,
     Quality : integer;
     Pt : real;
     end;

var
   bError    : Boolean;
   bUserAbort: Boolean;
   hDlgPrint : HWnd;

const
   id_SetUp      = 910;
   id_PrinterBox = 206;

type
   PPrinterSelectDlg= ^PrinterSelectDlg;
   PrinterSelectDlg = object(CPWDialog)
      procedure SetUp (var Msg:TMessage);virtual id_First + id_SetUp;
      end;

   { Printer abort procedure. }
   TAbortProc = function (hdcPrn: HDC; nCode: integer):Bool;


function GetPrinterDC:HDC;
function PrintDlgProc (hDlg: HWnd; Message, wParam:
   word; lParam: longint):Bool;export;
function AbortProc (hdcPrn: HDC; nCode: integer):Bool;export;


function NextToken (var P: PChar; C:PChar):PChar;

procedure HPDeskJet;
procedure PaperSizeMM (var w, h, orientation, quality:integer);
procedure GetPrinterInfo (hdcPrn:HDC; var P:PrinterRec);
procedure DumpPrinterInfo (var f:text; var P:PrinterRec);
function EnumerateFont(var LogFont: TLogFont; TextMetric: PTextMetric;
   FontType: Integer; Data: PChar): Integer; export;

{ Return a collection of the printer fonts }
procedure GetPrinterFonts (hdcPrn: HDC; FontList:PStrCollection);
procedure GetPrinterFontSizes (hdcPrn: HDC; FontSizes:PCollection);


procedure FillPrinterList (P:PStrCollection; var Defaultprinter:integer);
function DefPrinter:Boolean;
function DefPrinterDC:HDC;
function ResetDefPrinter (ProfileString:PChar):Boolean;

implementation
const
   MAXPORTLEN      = 25;
   MAXDRIVERLEN    = 50;
   MAXDEVICELEN    = cchDeviceName; { WINTYPES.PAS}
   MAXPRINTINFOLEN = MAXDEVICELEN + 1 + MAXDRIVERLEN + 1 + MAXPORTLEN;
   MAXINFOLEN      = 5 * MAXPRINTINFOLEN;
   MAXBUF          = 2 * MAXPRINTINFOLEN;
var
   { Hold the default printer information }
   szDefPrinter : array[0..MAXPRINTINFOLEN] of char;
   szDefDevice  : array[0..MAXDEVICELEN] of char;
   szDefDriver  : array[0..MAXDRIVERLEN] of char;
   szDefOutput  : array[0..MAXPORTLEN] of char;

   Fonts   : PStrCollection;
   NumFonts: integer;

{-----------------------------PrintDlgProc---------------------------------}

{ Printer abort dialog box function }
function PrintDlgProc (hDlg: HWnd; Message,
   wParam: word; lParam: longint):Bool;
var
   szInfo: array[0..128] of char;
begin
   case Message of
      wm_InitDialog:
         begin
{            SetWindowText (hDlg, szAppName);}


            StrCopy (szInfo, 'on the ');
            StrCat (szInfo, szDefDevice);
            SetDlgItemText (hDlg, id_PrintDevice, szInfo);

            StrCopy (szInfo, 'connected to ');
            StrCat (szInfo, szDefOutput);
            SetDlgItemText (hDlg, id_PrintOutput, szInfo);

            EnableMenuItem (GetSystemMenu (hDlg, False), sc_Close, mf_Grayed);
            PrintDlgProc := True;
         end;
      wm_Command:
         begin
            bUserAbort := True;
            EnableWindow (GetParent (hDlg), True);
            DestroyWindow (hDlg);
            hDlgPrint    := 0;
            PrintDlgProc := True;
         end;
      else PrintDlgProc := False;
      end;
end;

{-----------------------------AbortProc------------------------------------}

{ printer abort procedure }
function AbortProc (hdcPrn: HDC; nCode: integer):Bool;
var
   Msg: TMsg;
begin
   while (not bUserAbort and PeekMessage (Msg, 0, 0, 0, pm_Remove)) do
      if ((hdcPrn <> 0) or not IsDialogMessage (hDlgPrint, Msg)) then begin
         TranslateMessage (Msg);
         DispatchMessage (Msg);
         end;
   AbortProc := not bUserAbort;
end;

{-----------------------------NextToken------------------------------------}

{ Return a pointer to the next token in P
  delimited by C, and remove that token from the
  string P. This is equivalent to C's strtok.
}
function NextToken (var P: PChar; C:PChar):PChar;
const
   Next:PChar = NIL;
var
   There : PChar;
begin
   if (P <> NIL) then begin
      Next := P;
      There := StrPos (P, C);
      if (There <> NIL) then begin
         There^ := #0;
         P := @There[1];
         end;
      end;
   NextToken := Next;
end;

{-----------------------------GetPrinterDC---------------------------------}

{ Return a handle to the default printer }
function GetPrinterDC:HDC;
var
   Buffer  : array[0..MAXBUF] of char;
   lpszTemp: PChar;
   i, j, k   : integer;
begin
   GetPrinterDC := 0;
   lpszTemp := @Buffer;
   if GetProfileString
      ('windows', 'device', ',,,', lpszTemp, 80) <> 0 then begin
      StrCopy (szDefDevice, NextToken (lpszTemp, ','));
      if (szDefDevice[0] <> #0) then begin
         StrCopy (szDefDriver, NextToken (lpszTemp, ','));
         if (szDefDriver[0] <> #0) then begin
            StrCopy (szDefOutput, NextToken (lpszTemp, ','));
            if (szDefOutput[0] <> #0) then
               GetPrinterDC := CreateDC (szDefDriver, szDefDevice, szDefOutput, NIL);
            end;
         end;
      end;
end;

{-----------------------------DefPrinter-----------------------------------}

{ Process the profile string for the default printer,
  and store the device, driver, and port information in
  the private variables szDefDevice, szDefDriver, and szDefOutput.

  Return true if successful.
}
function DefPrinter:Boolean;
var
   Buffer  : array[0..MAXBUF] of char;
   lpszTemp : PChar;
begin
   DefPrinter := False;
   lpszTemp   := @Buffer;
   if GetProfileString
      ('windows', 'device', ',,,', lpszTemp, 80) <> 0 then begin
      StrCopy (szDefPrinter, lpszTemp);
      StrCopy (szDefDevice, NextToken (lpszTemp, ','));
      if (szDefDevice[0] <> #0) then begin
         StrCopy (szDefDriver, NextToken (lpszTemp, ','));
         if (szDefDriver[0] <> #0) then begin
            StrCopy (szDefOutput, NextToken (lpszTemp, ','));
            if (szDefOutput[0] <> #0) then
               DefPrinter := true;
            end;
         end;
      end;
end;

{-----------------------------DefPrinterDC---------------------------------}

{ Return the device context for the default printer.
  Assumes printer profile string already processed.
}
function DefPrinterDC:HDC;
begin
   DefPrinterDC := CreateDC (szDefDriver, szDefDevice, szDefOutput, NIL);
end;

{-----------------------------FillPrinterList------------------------------}

{ Return a list of all printers and the default printer }
procedure FillPrinterList (P:PStrCollection; var Defaultprinter:integer);
var
   { string buffers }
   szAllPrinters : array[0..MAXINFOLEN] of char;
   szPrinterInfo : array[0..MAXPRINTINFOLEN] of char;
   szNullPort    : array[0..MAXPORTLEN] of char;
   szBuf         : array[0..MAXBUF] of char;
   szDevice      : array[0..MAXDEVICELEN] of char;
   szDriver      : array[0..MAXDRIVERLEN] of char;
   szCurPort     : array[0..MAXPORTLEN] of char;
   szPorts       : array[0..MAXPRINTINFOLEN] of char;

   { string pointers }
   lpszPrinterInfo,
   lpszPort,
   lpszTemp,
   lpszCurPort:PChar;

   x : word;

   lpszPrinter : PChar;
   lpszCrntPort : PChar;
   Arg : array[0..4] of PChar;

   i : integer;

begin
   { Get the list of all printers }
   x := GetProfileString ('devices', NIL, '', szAllPrinters, sizeof(szAllprinters));
   if (x = (sizeof(szAllPrinters) - 2)) then begin
      { buffer too small }
      writeln (output, 'Too many printers installed');

      lpszPrinter := szAllprinters + sizeof(szAllprinters) - 3;
      while (lpszPrinter^ <> #0) do begin
         lpszprinter^ := #0;
         Dec (lpszprinter);
         end;
      end;

   { Get the name of the NullPort }
   GetProfileString ('windows','NullPort','',szNullPort, sizeof(szNullPort));

   { Go through the list of printers getting info on each }
   lpszprinter := szAllPrinters;
   while (lpszprinter <> NIL) and (lpszprinter^ <> #0) do begin
      { lpszprinter points to one printer }
      GetProfileString ('devices',lpszPrinter,'',szPrinterInfo,sizeof(szPrinterInfo));

      { get driver and port }
      lpszPrinterInfo := szPrinterInfo;
      StrCopy (szDriver, NextToken (lpszPrinterInfo, ','));
      StrCopy (szPorts, NextToken (lpszprinterInfo,','));

      lpszPort := szPorts;
      while (lpszPort <> NIL) do begin
         { get a port }
         StrCopy (szCurPort, NextToken (lpszPort, ','));
         if (StrComp (szCurPort, szNullPort) <> 0) then begin
            { Build string
              '(device) ON (port)\t(device),(driver),(port)'