home *** CD-ROM | disk | FTP | other *** search
/ Delphi 2 - Developers' Solutions / Delphi 2 Developers' Solutions.iso / dds / chap05 / howto05 / delphi10 / ccprnmgr.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1995-11-29  |  17.4 KB  |  507 lines
  1. unit Ccprnmgr;
  2.  
  3. interface
  4.  
  5. uses
  6.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  7.   Forms, Dialogs, StdCtrls, ExtCtrls, Buttons, Printers, DRWSUtl1, PPrevUn;
  8.  
  9. type
  10.   TCCPrintForm = class(TForm)
  11.     ComboBox1: TComboBox;
  12.     Label1: TLabel;
  13.     BitBtn1: TBitBtn;
  14.     BitBtn3: TBitBtn;
  15.     BitBtn4: TBitBtn;
  16.     Bevel1: TBevel;
  17.     Label2: TLabel;
  18.     Label3: TLabel;
  19.     Label4: TLabel;
  20.     Bevel2: TBevel;
  21.     Label5: TLabel;
  22.     Label6: TLabel;
  23.     Bevel3: TBevel;
  24.     ListBox1: TListBox;
  25.     Label7: TLabel;
  26.     BitBtn6: TBitBtn;
  27.     BitBtn7: TBitBtn;
  28.     BitBtn8: TBitBtn;
  29.     Label8: TLabel;
  30.     Label9: TLabel;
  31.     Label10: TLabel;
  32.     Label11: TLabel;
  33.     RadioGroup1: TRadioGroup;
  34.     BitBtn9: TBitBtn;
  35.     FontDialog1: TFontDialog;
  36.     BitBtn10: TBitBtn;
  37.     BitBtn11: TBitBtn;
  38.     BitBtn12: TBitBtn;
  39.     PrintDialog1: TPrintDialog;
  40.     PrinterSetupDialog1: TPrinterSetupDialog;
  41.     BitBtn2: TBitBtn;
  42.     procedure FormCreate(Sender: TObject);
  43.     procedure BitBtn1Click(Sender: TObject);
  44.     procedure BitBtn7Click(Sender: TObject);
  45.     procedure BitBtn9Click(Sender: TObject);
  46.     procedure RadioGroup1Click(Sender: TObject);
  47.     procedure BitBtn6Click(Sender: TObject);
  48.     procedure BitBtn4Click(Sender: TObject);
  49.     procedure BitBtn8Click(Sender: TObject);
  50.     procedure BitBtn10Click(Sender: TObject);
  51.     procedure BitBtn12Click(Sender: TObject);
  52.     procedure BitBtn11Click(Sender: TObject);
  53.     procedure BitBtn2Click(Sender: TObject);
  54.   private
  55.     { Private declarations }
  56.   public
  57.     { Public declarations }
  58.     procedure HandlePrinting;
  59.     procedure DumpScreenToPrinter( PrintToFile : Boolean );
  60.     procedure HandlePrintPreview;
  61.   end;
  62.  
  63. var
  64.   CCPrintForm: TCCPrintForm;
  65.  
  66. implementation
  67.  
  68. {$R *.DFM}
  69.  
  70. procedure TCCPrintForm.HandlePrintPreview;
  71. var TheRatio : double;
  72.     TheMultiple,
  73.     RealWidth ,
  74.     RealHeight   : Integer;
  75.     TheBitmap : TBitmap;
  76.     ScreenDC : HDC;
  77.     TheResult : Boolean;
  78. begin
  79.   { Create the bitmap and put screen image in it }
  80.   TheBitmap := TBitmap.Create;
  81.   TheBitmap.Width := Screen.Width;
  82.   TheBitmap.Height := Screen.Height;
  83.   ScreenDC := GetDC( 0 );
  84.   TheResult := BitBlt( TheBitmap.Canvas.Handle , 0 , 0 , Screen.Width , Screen.Height ,
  85.           ScreenDC , 0 , 0 , SRCCOPY );
  86.   ReleaseDC( 0 , ScreenDC );
  87.   { This shows the position of a screen dump on the printed page }
  88.   PrintPreviewForm := TPrintPreviewForm.Create( Application );
  89.   TheMultiple := Round( Printer.PageWidth/Screen.Width ) - 1;
  90.   TheRatio := PrintPreviewForm.Panel2.Width/Printer.PageWidth;
  91.   RealWidth := Round( TheRatio * TheBitmap.Width * TheMultiple );
  92.   RealHeight := Round( TheRatio * TheBitmap.Height * TheMultiple );
  93.   PrintPreviewForm.Image1.Width := RealWidth;
  94.   PrintPreviewForm.Image1.Height := RealHeight;
  95.   PrintPreviewForm.Image1.Picture.Bitmap := TheBitmap;
  96.   PrintPreviewForm.ShowModal;
  97.   PrintPreviewForm.Free;
  98.   TheBitmap.Free;
  99. end;
  100.  
  101. procedure TCCPrintForm.DumpScreenToPrinter( PrintToFile : Boolean );
  102. var TheBitmap : TBitmap;
  103.     ScreenDC : HDC;
  104.     Info: PBitmapInfo;
  105.     InfoSize: Integer;
  106.     Image: Pointer;
  107.     ImageSize: Longint;
  108.     Bits: HBITMAP;
  109.     DIBWidth, DIBHeight: Longint;
  110.     PrintWidth, PrintHeight: Longint;
  111.     TheResult : Boolean;
  112.     PrinterMult : Integer;
  113.     OpenDialog1 : TOpenDialog;
  114. begin
  115.   { External try/except loop to get errors }
  116.   try
  117.     { Start the print }
  118.     if not PrintToFile then Printer.BeginDoc;
  119.     { Create the bitmap and put screen image in it }
  120.     TheBitmap := TBitmap.Create;
  121.     TheBitmap.Width := Screen.Width;
  122.     TheBitmap.Height := Screen.Height;
  123.     ScreenDC := GetDC( 0 );
  124.     TheResult := BitBlt( TheBitmap.Canvas.Handle , 0 , 0 , Screen.Width , Screen.Height ,
  125.             ScreenDC , 0 , 0 , SRCCOPY );
  126.     ReleaseDC( 0 , ScreenDC );
  127.     { Get the aspect ration printer to screen, less 1 for overruns }
  128.     PrinterMult := Round( Printer.PageWidth / Screen.Width ) - 1;
  129.     if PrintToFile then
  130.     begin
  131.       OpenDialog1 := TOpenDialog.Create( Application );
  132.       OpenDialog1.Filter := 'Windows Bitmaps|*.bmp|All Files|*.*';
  133.       OpenDialog1.Filename := '*.bmp';
  134.       OpenDialog1.Title := 'Save Screen Dump As...';
  135.       if OpenDialog1.Execute then TheBitmap.SaveToFile( OpenDialog1.FileName );
  136.       TheBitmap.Free;
  137.       OpenDialog1.Free;
  138.       exit;
  139.     end;
  140.     { Do a StretchDIBits due to a canvas bug in delphi printing }
  141.     Bits := TheBitmap.Handle;
  142.     GetDIBSizes(Bits, InfoSize, ImageSize);
  143.     Info := MemAlloc(InfoSize);
  144.     try
  145.       Image := MemAlloc(ImageSize);
  146.       try
  147.         GetDIB(Bits, 0, Info^, Image^);
  148.         with Info^.bmiHeader do
  149.         begin
  150.           DIBWidth := biWidth;
  151.           DIBHeight := biHeight;
  152.         end;
  153.         PrintWidth := DIBWidth * PrinterMult;
  154.         PrintHeight := DIBHeight * PrinterMult;
  155.         StretchDIBits(Printer.Canvas.Handle, 10 , 10 , PrintWidth, PrintHeight, 0, 0,
  156.          DIBWidth, DIBHeight, Image, Info^, DIB_RGB_COLORS, SRCCOPY);
  157.       finally
  158.           FreeMem(Image, ImageSize);
  159.       end;
  160.     finally
  161.       FreeMem(Info, InfoSize);
  162.     end;
  163.     TheBitmap.Free;
  164.     { Send the bitmap to the printer }
  165.     if not Printer.Aborted then Printer.EndDoc;
  166.   except
  167.     { Assume HandlePrint reraises exception }
  168.     On E:EPrinter do
  169.     begin
  170.       { Beep on error }
  171.       MessageBeep( MB_ICONEXCLAMATION );
  172.       { Set status label color to red }
  173.       Label6.Font.Color := clRed;
  174.       { Set the caption to the error message }
  175.       Label6.Caption := E.Message;
  176.       { If any exceptions occur chicken out and dump }
  177.       Printer.Abort;
  178.       exit;
  179.     end;
  180.     On E: Exception do
  181.     begin
  182.       raise;
  183.       exit;
  184.     end;
  185.   end;
  186. end;
  187.  
  188. procedure TCCPrintForm.HandlePrinting;
  189. var TheFile      : TextFile;    { Used to open text files     }
  190.     TheBitmap    : TBitmap;     { Used to open bitmap files   }
  191.     Counter_1 ,                 { Loop Counter for Selections }
  192.     Counter_2    : Integer;     { Loop Counter for lines      }
  193.     TheString    : String;      { Text file IO handler        }
  194.     TestString   : String;      { Used to check file extension}
  195.     Info         : PBitmapInfo; { Used to print bitmap        }
  196.     InfoSize     : Integer;     { Used to print bitmap        }
  197.     Image        : Pointer;     { Used to print bitmap        }
  198.     ImageSize    : Longint;     { Used to print bitmap        }
  199.     Bits         : HBITMAP;     { Used to print bitmap        }
  200.     DIBWidth ,                  { Used to print bitmap        }
  201.     DIBHeight    : Longint;     { Used to print bitmap        }
  202.     PrintWidth ,                { Used to print bitmap        }
  203.     PrintHeight  : Longint;     { Used to print bitmap        }
  204. begin
  205.   { Print text and bitmap files directly and shell all }
  206.   { other files out to windows to print, if possible.  }
  207.   for Counter_1 := 0 to Listbox1.Items.Count - 1 do
  208.   begin
  209.     { Allow checks for hitting abort button }
  210.     Application.ProcessMessages;
  211.     if Printer.Aborted then exit;
  212.     { Check for selected file in the listbox to do a print }
  213.     if ListBox1.Selected[ Counter_1 ] then
  214.     begin
  215.       { Check against extension of file selected }
  216.       TestString := Uppercase( ExtractFileExt( ListBox1.Items[ Counter_1 ] ));
  217.       if TestString = '.TXT' then
  218.       begin { Print out text files directly to demo method }
  219.         { Call begindoc method }
  220.         Printer.BeginDoc;
  221.         try
  222.           { Try to assign and open the file, barf if can't }
  223.           AssignFile( TheFile , ListBox1.Items[ Counter_1 ] );
  224.           Reset( TheFile );
  225.           { Set the lines printed counter }
  226.           Counter_2 := 1;
  227.           { Run to the end of the file }
  228.           while not EOF( TheFile ) do
  229.           begin
  230.             { Allow the user to abort }
  231.             Application.ProcessMessages;
  232.             if Printer.Aborted then
  233.             begin
  234.               { Display brief abort message }
  235.               Label6.Font.Color := clRed;
  236.               Label6.Caption := 'Aborting...';
  237.               Label6.Show;
  238.               { Go bye bye }
  239.               exit;
  240.             end;
  241.             { Do the actual printing with textout }
  242.             { Read the next line in               }
  243.             Readln( TheFile , TheString );
  244.             { Put it out down the page per line }
  245.             Printer.Canvas.TextOut( 10 , 20 +
  246.              ( Counter_2  * ( Printer.Canvas.TextHeight( 'W' ) + 5 )) ,
  247.               TheString );
  248.             { Increment the line counter and test for end of page }
  249.             Counter_2 := Counter_2 + 1;
  250.             if (( Counter_2 * ( Printer.Canvas.TextHeight( 'W' ) +
  251.              5 )) + 20 ) > ( Printer.PageHeight - 20 ) then
  252.             begin
  253.               { Send a form feed to printer and reset line counter }
  254.               Printer.NewPage;
  255.               Counter_2 := 1;
  256.             end;
  257.           end;
  258.           { Close the file being printed }
  259.           CloseFile( TheFile );
  260.         except
  261.           { Assume HandlePrint reraises exception }
  262.           On E:EPrinter do
  263.           begin
  264.             { Beep on error }
  265.             MessageBeep( MB_ICONEXCLAMATION );
  266.             { Set status label color to red }
  267.             Label6.Font.Color := clRed;
  268.             { Set the caption to the error message }
  269.             Label6.Caption := E.Message;
  270.             { If any exceptions occur chicken out and dump }
  271.             Printer.Abort;
  272.             exit;
  273.           end;
  274.         end;
  275.         { Call Enddoc method }
  276.         Printer.EndDoc;
  277.       end
  278.       else
  279.       begin
  280.         if TestString = '.BMP' then
  281.         begin { Print out bitmap files directly to demo method }
  282.           { If not graphics capabile signal error }
  283.           if Label9.Caption = 'Graphics Capable'
  284.           then
  285.           begin
  286.             { Otherwise create the bitmap and load the file }
  287.             TheBitmap := TBitmap.Create;
  288.             try
  289.               TheBitmap.LoadFromFile( ListBox1.Items[ Counter_1 ] );
  290.             except
  291.               { Abort on error }
  292.               raise;
  293.               exit;
  294.             end;
  295.             try
  296.               { Start the printing }
  297.               {Printer.BeginDoc;}
  298.               { Perform magic since normal canvas stuff won't work! }
  299.               with Printer, Canvas do
  300.               begin
  301.                 { Get a handle to the bitmap's data }
  302.                 Bits := TheBitmap.Handle;
  303.                 { Find out memory requirements }
  304.                 GetDIBSizes(Bits, InfoSize, ImageSize);
  305.                 { Get a pointer to enough memory for structure }
  306.                 Info := MemAlloc(InfoSize);
  307.                 try
  308.                   { Now try to hold the bits }
  309.                   Image := MemAlloc(ImageSize);
  310.                   try
  311.                     { And conver them to Device Independent }
  312.                     GetDIB(Bits, 0, Info^, Image^);
  313.                     with Info^.bmiHeader do
  314.                     begin
  315.                       { Get width and height when done }
  316.                       DIBWidth := biWidth;
  317.                       DIBHeight := biHeight;
  318.                     end;
  319.                     { Set these to enlarge but could scale }
  320.                     PrintWidth := DIBWidth * 3;
  321.                     PrintHeight := DIBHeight * 3;
  322.                     { Do actual print via StretchDIBits API call }
  323.                     StretchDIBits(Canvas.Handle, 20 , 20 , PrintWidth,
  324.                      PrintHeight, 0, 0, DIBWidth, DIBHeight, Image,
  325.                       Info^, DIB_RGB_COLORS, SRCCOPY);
  326.                   finally
  327.                     { Release memory regardless }
  328.                     FreeMem(Image, ImageSize);
  329.                   end;
  330.                 finally
  331.                   { Release more memory regardless }
  332.                   FreeMem(Info, InfoSize);
  333.                   { Free the bitmap }
  334.                   TheBitmap.Free;
  335.                 end;
  336.               end;
  337.               { End the printing }
  338.               Printer.EndDoc;
  339.             except
  340.               { Assume HandlePrint reraises exception }
  341.               On E:EPrinter do
  342.               begin
  343.                 { Beep on error }
  344.                 MessageBeep( MB_ICONEXCLAMATION );
  345.                 { Set status label color to red }
  346.                 Label6.Font.Color := clRed;
  347.                 { Set the caption to the error message }
  348.                 Label6.Caption := E.Message;
  349.                 { If any exceptions occur chicken out and dump }
  350.                 Printer.Abort;
  351.                 exit;
  352.               end;
  353.             end;
  354.           end
  355.           { Complain about printing to nonraster device! }
  356.           else MessageDlg( 'Cannot Print A Bitmap On Non-Graphics Printer!',
  357.            mtError, [mbOK],0 );
  358.         end
  359.         else
  360.         begin
  361.           { Otherwise try to shell out to windows to print complex file }
  362.           if not ShellExec( ExpandFileName( ListBox1.Items[ Counter_1 ] )
  363.             , '' , '', true , SW_SHOWMINIMIZED , true ) then
  364.             MessageDlg('Could not Print ' + ListBox1.Items[ Counter_1 ] ,
  365.              mtError, [mbOK], 0);
  366.         end;
  367.       end;
  368.     end;
  369.   end;
  370. end;
  371.  
  372. procedure TCCPrintForm.FormCreate(Sender: TObject);
  373. begin
  374.   { Clear the combobox and assign the available printers }
  375.   Combobox1.Clear;
  376.   Combobox1.Items.Assign( Printer.Printers );
  377.   Combobox1.Itemindex := Printer.PrinterIndex;
  378.   { Display currently active printer }
  379.   Label4.Caption := Printer.Printers[ Printer.PrinterIndex ];
  380.   { Display resolution of currently active printer }
  381.   Label11.Caption := 'Width: ' + InttoStr( Printer.PageWidth ) +
  382.    ' Height: ' + IntToStr( Printer.PageHeight );
  383.   { Display orientation of currently active printer }
  384.   case Printer.Orientation of
  385.     poPortrait  : RadioGroup1.ItemIndex := 0;
  386.     poLandscape : RadioGroup1.ItemIndex := 1;
  387.   end;
  388.   { Set label for status }
  389.   Label6.Font.Color := clBlack;
  390.   Label6.Caption := 'Idle';
  391.   { Determine basic device capabilities of the selected printer }
  392.   if GetDeviceCaps( Printer.Handle , TECHNOLOGY ) = DT_RASPRINTER then
  393.    Label9.Caption := 'Graphics Capable' else Label9.Caption := 'Character Device';
  394.   if GetDeviceCaps( Printer.Handle , BITSPIXEL ) > 1 then
  395.    Label8.Caption := 'Color Capable' else Label8.Caption := 'Monochrome';
  396.   Label10.Caption := 'Resolution: ' +
  397.    IntToStr( GetDeviceCaps( Printer.Handle , LOGPIXELSX )) + ' dpi';
  398. end;
  399.  
  400. procedure TCCPrintForm.BitBtn1Click(Sender: TObject);
  401. begin
  402.   { Set the Default printer to be the selection of the combobox }
  403.   Printer.PrinterIndex := ComboBox1.ItemIndex;
  404.   { And cleverly reset the display! }
  405.   FormCreate( Self );
  406. end;
  407.  
  408. procedure TCCPrintForm.BitBtn7Click(Sender: TObject);
  409. begin
  410.   { This just runs the printer setup dialog }
  411.   PrinterSetupDialog1.Execute;
  412. end;
  413.  
  414. procedure TCCPrintForm.BitBtn9Click(Sender: TObject);
  415. begin
  416.   { This just displays available fonts for the printer }
  417.   if FontDialog1.Execute then Printer.Canvas.Font := FontDialog1.Font;
  418. end;
  419.  
  420. procedure TCCPrintForm.RadioGroup1Click(Sender: TObject);
  421. begin
  422.   { Set the printer orientation based on the radiogroup itemindex }
  423.   case RadioGroup1.ItemIndex of
  424.     0 : Printer.Orientation := poPortrait;
  425.     1 : Printer.Orientation := poLandscape;
  426.   end;
  427. end;
  428.  
  429. procedure TCCPrintForm.BitBtn6Click(Sender: TObject);
  430. begin
  431.   { If execute print dialog then call HandlePrint method and deal with exceptions }
  432.   if PrintDialog1.Execute then
  433.   begin
  434.     { Reset Label font color }
  435.     Label6.Font.Color := clBlack;
  436.     { Change status label to printing }
  437.     Label6.Caption := 'Printing...';
  438.     { Call HandlePrinting Method }
  439.     HandlePrinting;
  440.     { Reset the display to indicate printing not in progress }
  441.     if Label6.Caption = 'Printing...' then Label6.Caption := 'Idle';
  442.   end;
  443. end;
  444.  
  445. procedure TCCPrintForm.BitBtn4Click(Sender: TObject);
  446. begin
  447.   { If already printing do abort }
  448.   if Printer.Printing then
  449.   begin
  450.     { call abort method }
  451.     Printer.Abort;
  452.     { Reset status label }
  453.     Label6.Font.Color := clBlack;
  454.     Label6.Caption := 'Aborted...';
  455.   end;
  456. end;
  457.  
  458. procedure TCCPrintForm.BitBtn8Click(Sender: TObject);
  459. begin
  460.   if not ShellExec( 'C:\WINDOWS\PRINTMAN.EXE', '' , '', false ,
  461.    SW_SHOWNORMAL , false ) then
  462.     MessageDlg('Could not locate Print Manager!', mtError, [mbOK], 0);
  463. end;
  464.  
  465. procedure TCCPrintForm.BitBtn10Click(Sender: TObject);
  466. begin
  467.   if PrintDialog1.Execute then
  468.   begin
  469.     { Reset Label font color }
  470.     Label6.Font.Color := clBlack;
  471.     { Change status label to printing }
  472.     Label6.Caption := 'Printing...';
  473.     { Call Print Screen Method }
  474.     DumpScreenToPrinter( false );
  475.     { Reset the display to indicate printing not in progress }
  476.     if Label6.Caption = 'Printing...' then Label6.Caption := 'Idle';
  477.   end;
  478. end;
  479.  
  480. procedure TCCPrintForm.BitBtn12Click(Sender: TObject);
  481. begin
  482.   if PrintDialog1.Execute then
  483.   begin
  484.     { Reset Label font color }
  485.     Label6.Font.Color := clBlack;
  486.     { Change status label to printing }
  487.     Label6.Caption := 'Printing...';
  488.     { Call Print Screen Method }
  489.     DumpScreenToPrinter( PrintDialog1.PrintToFile );
  490.     { Reset the display to indicate printing not in progress }
  491.     if Label6.Caption = 'Printing...' then Label6.Caption := 'Idle';
  492.   end;
  493. end;
  494.  
  495. procedure TCCPrintForm.BitBtn11Click(Sender: TObject);
  496. begin
  497.   { Call the HPP routine }
  498.   HandlePrintPreview;
  499. end;
  500.  
  501. procedure TCCPrintForm.BitBtn2Click(Sender: TObject);
  502. begin
  503.   Application.HelpJump('Main_Dialog');
  504. end;
  505.  
  506. end.
  507.