cpwprint.pas

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

             }
            lpszCurPort := szCurPort;

            Arg[0] := lpszprinter;
            Arg[1] := lpszCurPort;
            Arg[2] := lpszPrinter;
            Arg[3] := @szDriver;
            Arg[4] := lpszCurPort;
            wvsprintf (szBuf, '%s on %s**\t%s,%s,%s',Arg);

            { This is a fudge because the \t character isn't recognised. }
            lpszTemp := StrScan (szBuf, '*');
            lpszTemp^ := chr(9);
            lpszTemp := StrScan (szBuf, '*');
            lpszTemp^ := chr(9);

            { Enter the string here...}
            P^.Insert (StrNew(szBuf));
            end;
         lpszPort := StrScan (lpszPort,',');
         end;
      { next printer in list }
      lpszprinter := StrScan (lpszprinter, #0) + 1;
      end;

   {Now identify default printer }
   DefaultPrinter := 0;
   for i := 0 to Pred (P^.Count) do begin
      lpszPrinterInfo := StrScan (P^.At(i), '\');
      if StrComp(lpszPrinterInfo+2,szDefPrinter) = 0 then
         DefaultPrinter := i;
      end;
end;

{-----------------------------ResetDefPrinter------------------------------}

{ Reset the default printerby processing a new profile string,
  and store the device, driver, and port information in
  the private variables szDefDevice, szDefDriver, and szDefOutput.

  Return true if successful.
}
function ResetDefPrinter (ProfileString:PChar):Boolean;
var
   Buffer  : array[0..MAXBUF] of char;
   lpszTemp : PChar;
begin
   StrCopy (Buffer, ProfileString);
   lpszTemp   := @Buffer;
   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
            ResetDefPrinter := true;
         end;
      end;
end;

{-----------------------------HPDeskJet------------------------------------}

{ An example of calling a printer setup dialog box }
procedure HPDeskJet;
const
   szDevice     = 'HP DeskJet 500 Scalable';
   szDriverFile = 'DJ500.DRV';
   szOutPut     = 'LPT1';
var
   hLibrary    : THandle;
   DevModeProc : TDeviceMode;  { procedure type declared in WinTypes }
   DevModePtr  : TFarProc;
begin
   hLibrary := LoadLibrary (szDriverFile);
   if (hLibrary >= 32) then begin
      DevModePtr := GetProcAddress (hLibrary, 'DEVICEMODE');
      if (DevModePtr <> NIL) then begin
         DevModeProc := TDeviceMode (DevModePtr);
         DevModeProc (0, hLibrary, szDevice, szOutput);
         end;
      end;
end;

{-----------------------------PaperSizeMM----------------------------------}

{ Use Windows API GetEnvironment to get paper size and orientation }
procedure PaperSizeMM (var w, h, Orientation, Quality:integer);
var
   DevMode: PDevMode;
   tmp    : integer;
begin
   w           := 0;
   h           := 0;
   Orientation := 0;
   new (DevMode);
   GetEnvironment (szDefOutput, DevMode, SizeOf (TDevMode));
   if (DevMode <> NIL) then begin
      if ((DevMode^.dmFields and dm_PaperSize) = dm_PaperSize) then
         case DevMode^.dmPaperSize of
            dmpaper_Letter	  : begin w := 216; h := 279; end; { Letter 8 1/2 x 11 in }
            dmpaper_LetterSmall	  : begin w := 216; h := 279; end; { Letter Small 8 1/2 x 11 in }
            dmpaper_Tabloid	  : begin w := 279; h := 432; end; { Tabloid 11 x 17 in }
            dmpaper_Ledger	  : begin w := 432; h := 279; end; { Ledger 17 x 11 in }
            dmpaper_Legal	  : begin w := 216; h := 356; end; { Legal 8 1/2 x 14 in }
            dmpaper_Statement	  : begin w := 140; h := 216; end; { Statement 5 1/2 x 8 1/2 in }
            dmpaper_Executive     : begin w := 191; h := 254; end; { Executive"7 1/2 x 10 in }
            dmpaper_A3		  : begin w := 297; h := 420; end; { A3 297 x 420 mm }
            dmpaper_A4            : begin w := 210; h := 297; end; { A4 210 x 297 mm }
            dmpaper_A4Small	  : begin w := 210; h := 297; end; { A4 Small 210 x 297 mm }
            dmpaper_A5		  : begin w := 148; h := 210; end; { A5 148 x 210 mm }
            dmpaper_B4		  : begin w := 250; h := 354; end; { B4 250 x 354 }
            dmpaper_B5		  : begin w := 182; h := 257; end; { B5 182 x 257 mm }
            dmpaper_Folio	  : begin w := 216; h := 330; end; { Folio 8 1/2 x 13 in }
            dmpaper_Quarto	  : begin w := 215; h := 275; end; { Quarto 215 x 275 mm }
            dmpaper_10X14         : begin w := 254; h := 356; end; { 10x14 in }
            dmpaper_11X17         : begin w := 279; h := 432; end; { 11x17 in }
            dmpaper_Note          : begin w := 216; h := 279; end; { Note 8 1/2 x 11 in }
            dmpaper_Env_9         : begin w :=  98; h := 225; end; { Envelope #9 3 7/8 x 8 7/8 }
            dmpaper_Env_10        : begin w := 105; h := 241; end; { Envelope #10 4 1/8 x 9 1/2 }
            dmpaper_Env_11        : begin w := 114; h := 264; end; { Envelope #11 4 1/2 x 10 3/8 }
            dmpaper_Env_12        : begin w := 121; h := 279; end; { Envelope #12 4 \276 x 11 }
            dmpaper_Env_14        : begin w := 127; h := 292; end; { Envelope #14 5 x 11 1/2 }
            dmpaper_CSheet        : begin w := 432; h := 559; end; { C size sheet }
            dmpaper_DSheet        : begin w := 559; h := 864; end; { D size sheet }
            dmpaper_ESheet        : begin w := 864; h :=1118; end; { E size sheet }
            end; { case}
      if ((DevMode^.dmFields and dm_Orientation) = dm_Orientation) then begin
         Orientation := DevMode^.dmOrientation;
         if (Orientation = dmorient_Landscape) then begin
            tmp := w;
            w   := h;
            h   := tmp;
            end;
         end;
      if ((DevMode^.dmFields and dm_PrintQuality) = dm_PrintQuality) then
         Quality := DevMode^.dmPrintQuality;
      end; { if DevMode }
   Dispose (DevMode);
end;

{-----------------------------GetPrinterInfo-------------------------------}

{ Get some info on the printer }
procedure GetPrinterInfo (hdcPrn:HDC; var P:PrinterRec);
var
   o, dx, dy, tmp,
   px, py, nCode : integer;
   tp            : TPoint;
begin
   dx := GetDeviceCaps (hdcPrn, HorzSize);
   dy := GetDeviceCaps (hdcPrn, VertSize);
   PaperSizeMM (P.wPaper, P.hPaper, P.Orientation, P.Quality);
   with P do begin
      { printable area in pixels }
      xPixels := GetDeviceCaps (hdcPrn, HorzRes);
      yPixels := GetDeviceCaps (hdcPrn, VertRes);
      end;

   { Older printer drivers may not respond to Windows GetEnvironment
     function, so use Escape function to get info on page size, etc. }
   if (P.wPaper = 0) then begin

      nCode := QueryEscSupport;
      if (Escape (hdcPrn, QueryEscSupport, 1,
         PChar(@nCode), NIL) <> 0) then begin
         Escape (hdcPrn, GetPhysPageSize, 0, NIL, PChar(@tp));
         P.wPaper := Trunc (tp.x / (P.xPixels / dx));
         P.hPaper := Trunc (tp.y / (P.yPixels / dy));
         end
      else begin
         { No escape support so just make A4. }
         P.wPaper := 210;
         P.hPaper := 297;
         end;

      nCode := GetSetPrintOrient;
      if (Escape (hdcPrn, QueryEscSupport, 1,
         PChar(@nCode), NIL) <> 0) then begin
         P.Orientation := Escape (hdcPrn, GetSetPrintOrient, 0, NIL, NIL);
         with P do
            if Orientation = dmorient_Landscape then begin
               tmp := wPaper;
               wPaper   := hPaper;
               hPaper   := tmp;
               end;
         end
      else
         { No escape support, so set to portrait. }
         P.Orientation := dmorient_Portrait;

      { By default use high resolution. }
      P.Quality := dmres_High;
      end;

   { Other printer info. }
   with P do begin
      { Printable area }
      xMargin := (wPaper - dx) div 2;
      yMargin := (hPaper - dy) div 2;
      { pixels per point }
      Pt      := yPixels / ((dy / 25.4) * 72);
      end;
end;

procedure DumpPrinterInfo (var f:text; var P:PrinterRec);
begin
   writeln (f, 'Printer info: ');
   with P do begin
      writeln (f,'Paper width  ',wPaper:5,' mm');
      writeln (f,'Paper height ',hPaper:5,' mm');
      writeln (f,'x Margin     ',xMargin:5, ' mm');
      writeln (f,'y Margin     ',yMargin:5,' mm');
      writeln (f,'x pixels     ',xPixels:5);
      writeln (f,'y pixels     ',yPixels:5);
      writeln (f,'Pixels/pt    ',Pt:9:3);
      if Orientation = dmorient_Portrait then
         writeln (f,'Orientation    Portrait')
      else writeln (f,'Orientation    Landscape');
      end;

end;


{ EnumerateFont is a call back function.  It receives information
  about system fonts.  It creates an example of each font by calling
  CreateFont when MaxNumFonts have been processed, 0 is returned
  notifying windows to stop sending information, otherwise 1 is
  returned telling windows to send more information if available }
function EnumerateFont(var LogFont: TLogFont; TextMetric: PTextMetric;
   FontType: Integer; Data: PChar): Integer;
begin
   Fonts^.Insert (StrNew(LogFont.lfFaceName));
   Inc(NumFonts);
   if NumFonts > MaxNumFonts then
      EnumerateFont := 0 { Don't send any more information }
   else
      EnumerateFont := 1; { Send more information if available }
end;


{ Return a collection of the printer fonts }
procedure GetPrinterFonts (hdcPrn: HDC; FontList:PStrCollection);
var
   EnumProc: TFarProc;
begin
   Fonts    := FontList;
   NumFonts := 0;
   { Create an instance of the call back function.  This allows
     our program to refer to an exported function.  Otherwise the
     Data segment will not be correct. }
   EnumProc := MakeProcInstance(@EnumerateFont, HInstance);
   { Gather information about all fonts that are allowable in our window (DC) }
   EnumFonts(hdcPrn, nil, EnumProc, nil);
   { Free the instance of our call back function }
   FreeProcInstance(EnumProc);
   FontList := Fonts;
end;


{ For now just return the sizes 6, 8, 10, 12, 14, 16, 18, 24 }
procedure GetPrinterFontSizes (hdcPrn: HDC; FontSizes:PCollection);
begin
      FontSizes^.Insert (StrNew(' 6'));
      FontSizes^.Insert (StrNew(' 8'));
      FontSizes^.Insert (StrNew('10'));
      FontSizes^.Insert (StrNew('12'));
      FontSizes^.Insert (StrNew('14'));
      FontSizes^.Insert (StrNew('16'));
      FontSizes^.Insert (StrNew('18'));
      FontSizes^.Insert (StrNew('24'));
end;




{**********************}
{                      }
{  Printer Select      }
{                      }
{**********************}



{ Handle user pressing setup button }
procedure PrinterSelectDlg.SetUp (var Msg:TMessage);
var
   szPrintInfo : array[0..MAXPRINTINFOLEN] of char;
   szDevice    : array[0..MAXDEVICELEN] of char;
   szDriver    : array[0..MAXDRIVERLEN] of char;
   szPort      : array[0..MAXPORTLEN]   of char;
   hLibrary    : THandle;
   DevModeProc : TDeviceMode;  { procedure type declared in WinTypes }
   DevModePtr  : TFarProc;
   x : word;
   lpszTemp : PChar;
begin
   { Get selected printer }
   x := SendMessage (GetDlgItem (HWindow, id_PrinterBox),
                     lb_GetCurSel, 0, 0);
   lpszTemp := @szPrintInfo;
   SendMessage (GetDlgItem (HWindow, id_PrinterBox),
                lb_Gettext, x, longint(lpszTemp));

   { Parse printer string... }
   lpszTemp := StrScan (lpszTemp, '\') + 2;
   StrCopy (szDevice, NextToken (lpszTemp, ','));
      if (szDevice[0] <> #0) then begin
         StrCopy (szDriver, NextToken (lpszTemp, ','));
         if (szDriver[0] <> #0) then begin
            StrCat (szDriver, '.DRV');
            StrCopy (szPort, NextToken (lpszTemp, ','));
            if (szPort[0] <> #0) then begin

               { We have a valid printer string }
               hLibrary := LoadLibrary (szDriver);
               if (hLibrary >= 32) then begin
                  DevModePtr := GetProcAddress (hLibrary, 'DEVICEMODE');
                  if (DevModePtr <> NIL) then begin
                     DevModeProc := TDeviceMode (DevModePtr);
                     DevModeProc (0, hLibrary, szDevice, szPort);
                     end;
                  end;
            end;
         end;
      end;
end;




end.