Chip 2001 December/Chip_2001-12_cd1.bin/zkuste/delphi/kompon/d345/PPREV.ZIP/BenPreview/PrevPrinter.pas

Pascal/Delphi Source File | 2001-09-29 | 34.3 KB | 1,111 lines

Unit PrevPrinter;

Interface

{

Component Title:           Ben Zeigler's Print Preview Component
Program FileName:        PrevPrinter.pas
Creation Date:           You'll have to ask Ben
Notes:                   Created by Ben Ziegler ([e-mail])
Required Files:          Requires PrevForm & FormSettings & Res files Components
Programming Language:    Delphi 5 now...
Targeted OS:             32-bit calls everywhere -- Win32

Version      Date     Programmer        Notes
  2.00     ??????       BZ         Initial release by Ben.
  3.00     ??????       JGW        Initial release by JGW for Delhpi 5.  I have attempted
                              to support several things.  Notably the ability to have
                              landscape and portrait plots at the same time as well as
                              a bounding box-zoom control but didn't succeed.  Mostly, I
                              changed things to be compatable with all of the other code I had,
                              and altered a few things based upon the kind of users I had--they
                              got confused a lot.
  3.01     09Feb01      JGW       Problem:  The original method of drawing was to simply
                              take the metafile created and draw it to the canvas as is.  What
                              happened, however, was that whenever you changed printers, the
                              metafile still had the attributes of the old printer, and even
                              with minor differences, the printouts became inconsistant.  And
                              attempting to simply alter the metafiles was even more inconsistent.
                                  Solution (one of many I'm sure):  Since metafiles are vectored,
                              I will simply use StretchDraw to print the metafile and to view
                              it on the screen.  And since the bounds of the metafile seem to be
                              variable, I picked a happy median that worked.
                                  Fun stuff, windows.

}

Uses SysUtils, Classes, Windows, Graphics, Forms, Printers, StdCtrls, ComCtrls;

Const
  INCH_TO_CM = 2.54;

Type
  TDrawStyle = ( dsStandard, dsOwnerDrawFixed, dsOwnerDrawVariable );
  TPrintPageNumber = ( pnBottom, pnTop, pnNone );
  TUnits = ( unInches, unCentimeters );
  TZoomOption = ( zoFitToPage, zoFitToWidth, zoTwoPages, zoCustom );
  TStatusType = ( stPaginating, stPrinting, stPaginationFinished, stPrintFinished );

  TOwnerHeightProc = Procedure( Sender: TObject; Line: integer; Var Height: integer; Var ForceNewPage: boolean ) Of Object;
  TOwnerDrawProc = Procedure( Sender: TObject; Page, Line: integer; R: TRect; Canvas: TCanvas ) Of Object;
  TNewPageProc = Procedure( Sender: TObject; Page: integer ) Of Object;
  TStatusProc = Procedure( Sender: TObject; Const StatMsg: String; PageNum: integer; StatusType: TStatusType ) Of Object;
  PPrinterOrientation = ^TPrinterOrientation;

  TTextOptions = Class( TPersistent )
  Protected
    FDrawStyle: TDrawStyle;
    FLeft: double;
    FTop: double;
    FRight: double;
    FBot: double;
    FBodyFont: TFont;
    FHdrFont: TFont;
    FFtrFont: TFont;
    FPageFont: TFont;
    FHeader: String;
    FFooter: String;
    FHdrMarg: double;
    FFtrMarg: double;
    FHdrAlign: TAlignment;
    FFtrAlign: TAlignment;
    FPrtPage: TPrintPageNumber;
    FPageAlign: TAlignment;
    FPageText: String;
    Procedure SetBodyFont( Val: TFont );
    Procedure SetHdrFont( Val: TFont );
    Procedure SetFtrFont( Val: TFont );
    Procedure SetPageFont( Val: TFont );
  Public
    Constructor Create;
    Destructor Destroy; Override;
    Procedure Assign( Source: TPersistent ); Override;
  Published
    Property DrawStyle: TDrawStyle Read FDrawStyle Write FDrawStyle;
    Property MarginLeft: double Read FLeft Write FLeft;
    Property MarginTop: double Read FTop Write FTop;
    Property MarginRight: double Read FRight Write FRight;
    Property MarginBottom: double Read FBot Write FBot;
    Property BodyFont: TFont Read FBodyFont Write SetBodyFont;
    Property HeaderFont: TFont Read FHdrFont Write SetHdrFont;
    Property FooterFont: TFont Read FFtrFont Write SetFtrFont;
    Property PageNumFont: TFont Read FPageFont Write SetPageFont;
    Property Header: String Read FHeader Write FHeader;
    Property Footer: String Read FFooter Write FFooter;
    Property HeaderMargin: double Read FHdrMarg Write FHdrMarg;
    Property FooterMargin: double Read FFtrMarg Write FFtrMarg;
    Property HeaderAlign: TAlignment Read FHdrAlign Write FHdrAlign;
    Property FooterAlign: TAlignment Read FFtrAlign Write FFtrAlign;
    Property PrintPageNumber: TPrintPageNumber Read FPrtPage Write FPrtPage;
    Property PageNumAlign: TAlignment Read FPageAlign Write FPageAlign;
    Property PageNumText: String Read FPageText Write FPageText;
  End;

  TPreviewPrinter = Class( TComponent )
  Protected
    FOrient: TPrinterOrientation;
    FPrinting: boolean;
    FTitle: String;
    MFList: TList;
    CurCanvas: TCanvas;
    ppix, ppiy: integer;
    sizex, sizey: integer;
    offx, offy: integer;
    UsedPage: boolean;
    FDrawOpt: TTextOptions;
    FUnits: TUnits;
    ConvFac: double;
    FShowGrid: boolean;
    FZoomOpt: TZoomOption;
    FZoomVal: integer;
    FOwnHgt: TOwnerHeightProc;
    FOwnDraw: TOwnerDrawProc;
    FNewPage: TNewPageProc;
    FOnStatus: TStatusProc;
    FCurPageIndex: LongInt;
    FOrientations: TList;
    FPageTitles: TStringList;
    FBundlePrint: Boolean;
    //FWorkingDC: HDC;
  Protected
    Procedure SetOrientation( Index: LongInt; Value: TPrinterOrientation );
    Function GetOrientation( Index: LongInt ): TPrinterOrientation;
    Function GetCanvas: TCanvas;
    Function GetPageNum: integer;
    Procedure FreeMetaFiles;
    Function GetMetaFile( i: integer ): TMetaFile;
    Function GetLastAvailPage: integer;
    Procedure SetDrawOptions( NewOptions: TTextOptions );
    Procedure SetUnits( Val: TUnits );
    Procedure InitPrinterVars( hdc: THandle );
    Procedure Loaded; Override;
    Function GetMetaFileCount: LongInt;
    Function GetPageOrientCount: LongInt;
    Function GetPageTitleCount: LongInt;
  Public
    Property CurPageIndex: LongInt Write FCurPageIndex;
    Constructor Create( AOwner: TComponent ); Override;
    Destructor Destroy; Override;
   // Helper Methods (Canvas)
    Function UnitToX( x: double ): integer;
    Function UnitToY( y: double ): integer;
    Function XToUnit( x: integer ): double;
    Function YToUnit( y: integer ): double;
    Procedure DrawAlignText( y: integer; Align: TAlignment; Const Text: String; Font: TFont );
    Procedure FixFont( Font: TFont );
    Procedure RestoreFont( Font: TFont; PPI: integer );
    Function PageSetupDlg: integer;
   // Printer Methods
    Procedure BeginDoc;
    Procedure BeginDocEx( Title: String; Orientation: TPrinterOrientation ); Overload;
    Procedure BeginDocEx( Title: String; Orientation: TPrinterOrientation; pDC: HDC ); Overload;
    Procedure NewPage;
    Procedure NewPageEx( Title: String; Orientation: TPrinterOrientation );
    Procedure EndDoc;
    Procedure Preview;
    Procedure Print;
    Function GetPreviewForm: TForm;
    Function PrintDialog: boolean;
    Function PrintRange( StartPage, StopPage: integer ): boolean;
    Procedure DrawHdrFtrPage( PageNum: integer );
    Procedure DrawStringList( Strings: TStrings );
    Procedure DrawRichText( RE: TCustomRichEdit );
    Property PageTitles: TStringList Read FPageTitles Write FPageTitles;
    Property MultiPageOrientations[ Index: LongInt ]: TPrinterOrientation Read GetOrientation
    Write SetOrientation;
    Property PageOrientCount: LongInt Read GetPageOrientCount;
    Property PageTitleCount: LongInt Read GetPageTitleCount;
    Property MetaFiles[ i: integer ]: TMetaFile Read GetMetaFile;
    Property PixelsPerInchX: integer Read ppix;
    Property PixelsPerInchY: integer Read ppiy;
    Property PageWidth: integer Read sizex;
    Property PageHeight: integer Read sizey;
    Property OffsetX: integer Read offx;
    Property OffsetY: integer Read offy;
    Property LastAvailPage: integer Read GetLastAvailPage;
    Property Canvas: TCanvas Read GetCanvas;
    Property PageNumber: integer Read GetPageNum;
    Property Printing: boolean Read FPrinting;
    Property PageCount: LongInt Read GetMetaFileCount;
  Published
    Property BundlePrint: Boolean Read FBundlePrint Write FBundlePrint Default true;
    Property Orientation: TPrinterOrientation Read FOrient Write FOrient;
    Property Title: String Read FTitle Write FTitle;
    Property TextOptions: TTextOptions Read FDrawOpt Write SetDrawOptions;
    Property Units: TUnits Read FUnits Write SetUnits;
    Property ShowGrid: boolean Read FShowGrid Write FShowGrid;
    Property ZoomOption: TZoomOption Read FZoomOpt Write FZoomOpt;
    Property ZoomVal: integer Read FZoomVal Write FZoomVal;
    Property OnOwnerHeight: TOwnerHeightProc Read FOwnHgt Write FOwnHgt;
    Property OnOwnerDraw: TOwnerDrawProc Read FOwnDraw Write FOwnDraw;
    Property OnNewPage: TNewPageProc Read FNewPage Write FNewPage;
    Property OnStatus: TStatusProc Read FOnStatus Write FOnStatus;
  End;

Procedure Register;

Implementation

Uses PrevForm, Controls, Dialogs, RichEdit, PageSetupDlg;

Type
  TBenMetaFileCanvas = Class( TMetaFileCanvas )
  Protected
    OldFontChanged: TNotifyEvent;
    Procedure NewFontChanged( Sender: TObject );
  Public
    PPI: integer;
    Constructor Create( AMetafile: TMetafile; ReferenceDevice: HDC );
  End;

// ************************************************************************
// TBenMetaFileCanvas

Constructor TBenMetaFileCanvas.Create( AMetafile: TMetafile; ReferenceDevice: HDC );
Begin
  Inherited;
  OldFontChanged := Font.OnChange;
  Font.OnChange := NewFontChanged;
End;

Procedure TBenMetaFileCanvas.NewFontChanged( Sender: TObject );
Begin
  If Assigned( OldFontChanged ) Then OldFontChanged( Sender );
End;

// ************************************************************************
// TTextOptions

Constructor TTextOptions.Create;
Begin
  Inherited;
  DrawStyle := dsStandard;
  MarginLeft := 0;
  MarginTop := 0;
  MarginRight := 0;
  MarginBottom := 0;
  FHdrMarg := 0.5;
  FFtrMarg := 0.75;
  FHdrAlign := taCenter;
  FFtrAlign := taCenter;

  PrintPageNumber := pnBottom;
  FPageAlign := taRightJustify;

  FBodyFont := TFont.Create;
  FHdrFont := TFont.Create;
  FFtrFont := TFont.Create;
  FPageFont := TFont.Create;

  FBodyFont.Name := 'Arial';
  FBodyFont.Size := 10;
  FHdrFont.Name := 'Times New Roman';
  FHdrFont.Size := 18;
  FHdrFont.Style := [ fsBold ];
  FFtrFont.Name := 'Times New Roman';
  FFtrFont.Size := 10;
  FFtrFont.Style := [ fsItalic ];
  FPageFont.Assign( FFtrFont );

  FPageText := 'Page %d';
End;

Destructor TTextOptions.Destroy;
Begin
  FBodyFont.Free;
  FHdrFont.Free;
  FFtrFont.Free;
  FPageFont.Free;
  Inherited;
End;

Procedure TTextOptions.Assign( Source: TPersistent );
Begin
  If Self = Source Then exit;
  MessageBeep( 0 );
End;

Procedure TTextOptions.SetBodyFont( Val: TFont );
Begin
  FBodyFont.Assign( Val );
End;

Procedure TTextOptions.SetHdrFont( Val: TFont );
Begin
  FHdrFont.Assign( Val );
End;

Procedure TTextOptions.SetFtrFont( Val: TFont );
Begin
  FFtrFont.Assign( Val );
End;

Procedure TTextOptions.SetPageFont( Val: TFont );
Begin
  FPageFont.Assign( Val );
End;

// ************************************************************************
// TPreviewPrinter

Constructor TPreviewPrinter.Create( AOwner: TComponent );
Begin
  Inherited;
  FDrawOpt := TTextOptions.Create;
  FPrinting := False;
  FOrient := poPortrait;
  CurCanvas := Nil;
  MFList := TList.Create;
  FUnits := unInches;
  FShowGrid := False;
  FZoomOpt := zoFitToPage;
  FZoomVal := 100;
  FCurPageIndex := -1;
  FOrientations := TList.Create;
  FPageTitles := TStringList.Create;
  FBundlePrint := True;
End;

Destructor TPreviewPrinter.Destroy;
Begin
  FreeMetaFiles;
  MFList.Free;
  FDrawOpt.Free;
  FOrientations.Free;
  FPageTitles.Free;
  Inherited;
End;

Procedure TPreviewPrinter.Loaded;
Var
  ps: TPageSetupForm;
Begin
  Inherited;
  If Not ( csDesigning In ComponentState ) Then
    Begin
      ps := TPageSetupForm.Create( Self );
      ps.TextOpt := TextOptions;
      ps.pp := Self;

      ps.GetDefaults;
      ps.Free;
    End;
End;

Function TPreviewPrinter.GetPageOrientCount: LongInt;
Begin
  Result := FOrientations.Count;
End;

Function TPreviewPrinter.GetPageTitleCount: LongInt;
Begin
  Result := FPageTitles.Count;
End;

Procedure TPreviewPrinter.SetDrawOptions( NewOptions: TTextOptions );
Begin
  If FDrawOpt <> NewOptions Then
    FDrawOpt.Assign( NewOptions );
End;

Function TPreviewPrinter.PageSetupDlg: integer;
Var
  ps: TPageSetupForm;
Begin
  ps := TPageSetupForm.Create( Self );
  ps.TextOpt := TextOptions;
  ps.pp := Self;

  Result := ps.Execute;
  ps.Free;
End;

Procedure TPreviewPrinter.FreeMetaFiles;
Var
  i: integer;
Begin
  For i := 0 To MFList.Count - 1 Do
    MetaFiles[ i ].Free;
  MFList.Clear;
  CurCanvas.Free;
  CurCanvas := Nil;
  FOrientations.Free;
  FOrientations := TList.Create;
  FPageTitles.Clear;
End;

Function TPreviewPrinter.GetMetaFile( i: integer ): TMetaFile;
Begin
  Result := MFList[ i ];
End;

Function TPreviewPrinter.GetMetaFileCount: LongInt;
Begin
  Result := MFList.Count;
End;

Procedure TPreviewPrinter.SetUnits( Val: TUnits );
Begin
  FUnits := Val;
  Case FUnits Of
    unInches: ConvFac := 1;
    unCentimeters: ConvFac := INCH_TO_CM;
  End;
End;

Procedure TPreviewPrinter.BeginDoc;
Begin
  FPrinting := True;
  FreeMetaFiles;
  NewPage;
End;

Procedure TPreviewPrinter.BeginDocEx( Title: String; Orientation: TPrinterOrientation );
Begin
  FPrinting := True;
  FreeMetaFiles;
  NewPageEx( Title, Orientation );
End;

Procedure TPreviewPrinter.BeginDocEx( Title: String; Orientation: TPrinterOrientation; pDC: HDC );
Begin
  FPrinting := True;
  FreeMetaFiles;
  NewPageEx( Title, Orientation );
End;

Procedure TPreviewPrinter.InitPrinterVars( hdc: THandle );
Begin
  ppix := GetDeviceCaps( hdc, LOGPIXELSX );
  ppiy := GetDeviceCaps( hdc, LOGPIXELSY );

  If ppix = 0 Then
    ppix := Screen.PixelsPerInch;
  If ppiy = 0 Then
    ppiy := Screen.PixelsPerInch;

  sizex := GetDeviceCaps( hdc, PHYSICALWIDTH );
  sizey := GetDeviceCaps( hdc, PHYSICALHEIGHT );

  If sizex = 0 Then
    Begin
      sizex := Round( 8.5 * Screen.PixelsPerInch );
      sizey := Round( 11 * Screen.PixelsPerInch );
    End;

  offx := GetDeviceCaps( hdc, PHYSICALOFFSETX );
  offy := GetDeviceCaps( hdc, PHYSICALOFFSETY );
End;

Procedure TPreviewPrinter.NewPageEx( Title: String; Orientation: TPrinterOrientation );
Var
  CurOr: PPrinterOrientation;
Begin
  New( CurOr );
  CurOr^ := Orientation;
  FOrientations.Insert( FOrientations.Count, CurOr );
  FPageTitles.Add( Title );
  Self.NewPage;
End;

Procedure TPreviewPrinter.NewPage;
Var
  MetaFile: TMetaFile;
  NewCanvas: TCanvas;
  UseScreen: boolean;

//  lpszDriver: String;    // pointer to string specifying driver name
//  lpszDevice: String;    // pointer to string specifying device name
//  lpInitData: DEVMODE;
Begin
  Assert( FPrinting );

  MetaFile := TMetaFile.Create;
  MetaFile.Enhanced := True;
  MFList.Add( MetaFile );

   // Setup up the Metafile Canvas
   // Use the Default Printer if one is available, otherwise use the Screen

  UseScreen := True;
  NewCanvas := Nil;

  If Printer.Printers.Count > 0 Then
    Begin

    (*  lpszDriver := 'BZ-Printer' + #0;
      lpszDevice := 'B.Z.-Printer' + #0;
      lpInitData.dmDeviceName := 'B.Z.-Printer';
      lpInitData.dmSpecVersion := 100;
      lpInitData.dmDriverVersion := 100;
      case Self.Orientation of
        poLandScape: begin
                       lpInitData.dmOrientation := DMORIENT_LANDSCAPE;
                       lpInitData.dmPaperLength := 27940;
                       lpInitData.dmPaperWidth := 21590;
                       lpInitData.dmPelsWidth := 6360;
                       lpInitData.dmPelsHeight := 4900;
                     end;
         poPortrait: begin
                       lpInitData.dmOrientation := DMORIENT_PORTRAIT;
                       lpInitData.dmPaperLength := 21590;
                       lpInitData.dmPaperWidth := 27940;
                       lpInitData.dmPelsWidth := 4900;
                       lpInitData.dmPelsHeight := 6360;
                     end;
      end;

      lpInitData.dmPaperSize := DMPAPER_LETTER;
      lpInitData.dmScale := 100;
      lpInitData.dmCopies := 1;
      lpInitData.dmDefaultSource := 0;
      lpInitData.dmPrintQuality := DMRES_HIGH;
      lpInitData.dmColor := DMCOLOR_COLOR;
      lpInitData.dmDuplex := DMDUP_SIMPLEX;
      lpInitData.dmYResolution := 6300;
      lpInitData.dmTTOption := DMTT_DOWNLOAD;
      lpInitData.dmCollate := DMCOLLATE_FALSE;
      lpInitData.dmFormName := 'Letter';
      lpInitData.dmLogPixels := 600;
      lpInitData.dmBitsPerPel := 8;

      FWorkingDC := Windows.CreateDC( nil, @lpszDevice, nil, @lpInitData );
      //FWorkingDC := Windows.CreateDC( 'DISPLAY', nil, nil, nil );

      if FWorkingDC = 0 then
        Application.MessageBox( 'NULL DC','',0 );*)

      UseScreen := False;
      Try
        If Not ( FBundlePrint ) And ( FOrientations.Count > 0 ) Then
          Printer.Orientation := TPrinterOrientation( FOrientations[ FOrientations.Count - 1 ] )
        Else
          Printer.Orientation := Orientation;
        NewCanvas := TBenMetaFileCanvas.Create( MetaFile, Printer.Handle );
        InitPrinterVars( Printer.Handle );
        //NewCanvas := TBenMetaFileCanvas.Create( MetaFile, FWorkingDC );
        //InitPrinterVars( FWorkingDC );
        //Windows.DeleteDC( FWorkingDC );
      Except
        UseScreen := True;
        NewCanvas.Free;
      End;
    End;

   // Use the screen if there is no Default Printer or printers installed
  If UseScreen Then
    Begin
      NewCanvas := TBenMetaFileCanvas.Create( MetaFile, 0 );
      InitPrinterVars( NewCanvas.Handle );
    End;

  ( NewCanvas As TBenMetaFileCanvas ).PPI := ppiy;
  NewCanvas.Font.PixelsPerInch := ppiy; // Delphi must not do this right, that's why I have to do it manually here
  If CurCanvas <> Nil Then
    Begin
      NewCanvas.Font := CurCanvas.Font;
      NewCanvas.Brush := CurCanvas.Brush;
      NewCanvas.Pen := CurCanvas.Pen;
    End
  Else
    Begin
      NewCanvas.Font.Name := 'Arial';   // Need a TrueType font that can scale (MS Sans Serif doesn't scale well)
      NewCanvas.Font.Size := 10;
      NewCanvas.Brush.Style := bsClear;
    End;

  CurCanvas.Free;
  CurCanvas := NewCanvas;
  UsedPage := False;

  If Assigned( OnStatus ) Then
    OnStatus( Self, Format( 'Paginating page %d', [ MFList.Count ] ), MFList.Count, stPaginating );
End;

Function TPreviewPrinter.UnitToX( x: double ): integer;
Begin
  If ConvFac <> 0 Then
    Result := Round( x * ppix / ConvFac )
  Else
    Result := 0;
End;

Function TPreviewPrinter.UnitToY( y: double ): integer;
Begin
  If ConvFac <> 0 Then
    Result := Round( y * ppiy / ConvFac )
  Else
    Result := 0;
End;

Function TPreviewPrinter.XToUnit( x: integer ): double;
Begin
  If ppix <> 0 Then
    Result := x / ppix * ConvFac
  Else
    Result := 0;
End;

Function TPreviewPrinter.YToUnit( y: integer ): double;
Begin
  If ppiy <> 0 Then
    Result := y / ppiy * ConvFac
  Else
    Result := 0;

End;

Procedure TPreviewPrinter.EndDoc;
Var
  i: integer;
Begin
  FPrinting := False;
  CurCanvas.Free;                       // This is to close out the MetaFile
  CurCanvas := Nil;

   // This is incase they called NewPage, but never drew anything on it
  If UsedPage = False Then
    Begin
      i := MFList.Count - 1;
      MetaFiles[ MFList.Count - 1 ].Free;
      MFList.Delete( i );
    End;

  If Assigned( OnStatus ) Then
    OnStatus( Self, 'Pagination Complete', -1, stPaginationFinished );
End;

Function TPreviewPrinter.GetPreviewForm: TForm;
Var
  pf: TPreviewForm;
Begin
//   Assert(FPrinting = False); // Change this later when allow threaded printing
  If FPrinting = False Then
    Begin

      pf := TPreviewForm.Create( Nil );
      pf.PrevPrinterObj := Self;
      pf.GridBut.Down := ShowGrid;

      Case ZoomOption Of
        zoFitToPage: pf.ZoomBox.ItemIndex := 0;
        zoFitToWidth: pf.ZoomBox.ItemIndex := 1;
        zoTwoPages: pf.TwoPageBut.Down := True;
        zoCustom:
          Begin
            pf.ZoomBox.ItemIndex := 11;
            pf.Zoom := ZoomVal;
          End;
      End;
      pf.ScrollBox1Resize( Nil );

      Result := pf;
    End
  Else
    Result := Nil;
End;

Procedure TPreviewPrinter.Preview;
Var
  pf: TPreviewForm;
Begin
  pf := GetPreviewForm As TPreviewForm;

  If pf <> Nil Then
    Begin
      pf.ShowModal;
      pf.Free;
    End
  Else
    Application.MessageBox( 'Error on getting preview form', 'Error', MB_OK );
End;

Function TPreviewPrinter.PrintDialog: boolean;
Var
  pd: TPrintDialog;
  Start, Stop, Copy: integer;
  StartIndex: Integer;
//   MMPageW, MMPageH  : Integer;
Begin
  If ( Printer.PrinterIndex = -1 ) Or ( Printer.Printers.Count = 0 ) Then
    Raise Exception.Create( 'NO PRINTERS AVAILABLE' );

  Result := False;

   // If the printer changes the resolution of the metafiles
   //may also change.  We need to make sure we can adjust the metafiles
  StartIndex := Printer.PrinterIndex;

  pd := TPrintDialog.Create( Nil );
  pd.FromPage := 1;
  pd.MinPage := 1;
  pd.MaxPage := LastAvailPage;
  pd.ToPage := LastAvailPage;
  pd.Options := [ poPageNums, poSelection ];

  Try
    If pd.Execute Then
      Begin
        Result := True;

        If pd.PrintRange = prAllPages Then
          Begin
            Start := 0;
            Stop := LastAvailPage - 1;
          End
        Else If pd.PrintRange = prSelection Then
          Begin
            Start := FCurPageIndex;
            Stop := FCurPageIndex;
          End
        Else
          Begin
            Start := pd.FromPage - 1;
            Stop := pd.ToPage - 1;
          End;

        Printer.Refresh;
        For Copy := 1 To pd.Copies Do
          Begin
            PrintRange( Start, Stop );
          End;
      End;
  Finally
    pd.Free;
  End;
End;

Procedure TPreviewPrinter.Print;
Begin
  PrintRange( 0, LastAvailPage - 1 );
End;

// Returns False if user cancels print job

Function TPreviewPrinter.PrintRange( StartPage, StopPage: integer ): boolean;
Var
  Page: integer;
  tmp: TPrinterOrientation;

Begin
  Screen.Cursor := crHourGlass;
  Try
    Result := True;
    Printer.Refresh;
      { Print bundling is defined as this:
      Windows does not allow the changing of the printer orientation between
   a single begindoc/enddoc sequence.  Therefore, if you want multiple orientations,
   you must do seperate begindoc/enddoc sequences.
      }

      {
        Okay, here's the problem... These metafiles can cause problems when we just
     lay them out there.  The metafiles are created based upon the information about the
     selected printer AT THE TIME OF PRINTING.  Then when "PrintDialog" is called, there
     is a possiblility of the printer to change to something with a different resolution.
     And since everything just used TCanvas.Draw, the printout was just thrown out there
     without regaurd to what the resolution was.  If you want from 72 Dpi to 700 dpi, you
     got a thumbnail.
        So how do you resolve it?  I've tried a number of things.  The first idea is that
     the whole reason you use metafiles instead of a bitmap, you can resize them without
     causing it to "pixelate" or even loosing detail.  It's a vectored graphic.  So why
     not use the "StretchDraw" function?  Well, what I discovered is that there is a really
     curous dis-connect between the starting of a metafile by the numbers and the starting
     of the metafile by the picture.  I drew a rectangle on the metafile from 0,0,PageWidth,PageWidth
     and hoped that would be at the edges of the page, but the end result was all over the
     place.  So, as a compromise, I just picked a happy median, and stuck with it.
        What would make this really good is if I could create the metafiles based upon
     a device context that I created dynamically, and then used the printer only when
     I actually wanted to print.  Ah, well.

        08Feb01 -jgw     }

    If FBundlePrint Then
      Begin
        Printer.Orientation := Orientation;
        Printer.Title := Title;
        InitPrinterVars( Printer.Handle );

        Printer.BeginDoc;
        For Page := StartPage To StopPage Do
          Begin
            If Assigned( OnStatus ) Then
              OnStatus( Self, Format( 'Printing page %d', [ Page ] ), Page, stPrinting );
             // Print the Page
             //Printer.Canvas.Draw(-offx, -offy, MetaFiles[Page]);
            Case Orientation Of
              poLandscape:
                Printer.Canvas.StretchDraw( Rect( 0 {(Round(ppix*0.15))}, 0 {(Round(ppiy*0.15))},
                  ( Round( ppix * 10.25 ) ), ( Round( ppiy * 7.75 ) ) ), MetaFiles[ Page ] );
              poPortrait:
                Printer.Canvas.StretchDraw( Rect( 0 {(Round(ppiy*0.15))}, 0 {(Round(ppix*0.15))},
                  ( Round( ppiy * 7.75 ) ), ( Round( ppix * 10.25 ) ) ), MetaFiles[ Page ] );
            End;

            If Page < StopPage Then Printer.NewPage;
          End;
        Printer.EndDoc;
      End
    Else
      Begin                             // You can't change the printer orientation in mid-stream... go figure...
        For Page := StartPage To StopPage Do
          Begin
            If Assigned( OnStatus ) Then
              OnStatus( Self, Format( 'Printing page %d', [ Page ] ), Page, stPrinting );

             // Print the Page
            If ( Page > -1 ) And ( Page < FPageTitles.Count ) Then
              Printer.Title := FPageTitles[ Page ]
            Else
              Printer.Title := Title;

            If ( Page > -1 ) And ( Page < FOrientations.Count ) Then
              Printer.Orientation := TPrinterOrientation( FOrientations[ Page ]^ )
            Else
              Printer.Orientation := Orientation;
            InitPrinterVars( Printer.Handle );
            Printer.BeginDoc;
            //Printer.Canvas.Draw( -offx, -offy, MetaFiles[ Page ] );
            Case Printer.Orientation Of
              poLandscape:
                Printer.Canvas.StretchDraw( Rect( 0 {(Round(ppix*0.15))}, 0 {(Round(ppiy*0.15))},
                  ( Round( ppix * 10.25 ) ), ( Round( ppiy * 7.75 ) ) ), MetaFiles[ Page ] );
              poPortrait:
                Printer.Canvas.StretchDraw( Rect( 0 {(Round(ppiy*0.15))}, 0 {(Round(ppix*0.15))},
                  ( Round( ppiy * 7.75 ) ), ( Round( ppix * 10.25 ) ) ), MetaFiles[ Page ] );
            End;
            Printer.EndDoc;
          End;
      End;
    If Assigned( OnStatus ) Then
      OnStatus( Self, 'Print Job Complete', -1, stPrintFinished );
  Finally
    Screen.Cursor := crDefault;
  End;
End;

Function TPreviewPrinter.GetPageNum: integer;
Begin
  Result := MFList.Count;
End;

Function TPreviewPrinter.GetLastAvailPage: integer;
Begin
   // TODO:  This will change with threading
  Result := GetPageNum;
End;

Procedure TPreviewPrinter.SetOrientation( Index: LongInt; Value: TPrinterOrientation );
Begin
  If ( Index > -1 ) And ( Index < FOrientations.Count ) Then
    PPrinterOrientation( FOrientations[ Index ] )^ := Value
  Else
    Raise Exception.CreateFmt( 'Index out-of-bounds on Setting Orientation (%d)', [ Index ] );
End;

Function TPreviewPrinter.GetOrientation( Index: LongInt ): TPrinterOrientation;
Begin
  If ( Index > -1 ) And ( Index < FOrientations.Count ) Then
    Result := PPrinterOrientation( FOrientations[ Index ] )^
  Else
    Raise Exception.CreateFmt( 'Index out-of-bounds on Getting Orientation (%d)', [ Index ] );
End;

Function TPreviewPrinter.GetCanvas: TCanvas;
Begin
  Assert( FPrinting, 'Canvas is not available before BeginDoc' );
  Result := CurCanvas;
  UsedPage := True;
End;

Procedure TPreviewPrinter.RestoreFont( Font: TFont; PPI: integer );
Var
  OldSize: integer;
Begin
  OldSize := Font.Size;
  Font.PixelsPerInch := PPI;
  Font.Size := OldSize;
End;

Procedure TPreviewPrinter.FixFont( Font: TFont );
Begin
   // RestoreFont(Font, ppiy);
End;

Procedure TPreviewPrinter.DrawAlignText( y: integer; Align: TAlignment; Const Text: String; Font: TFont );
Var
  OldFont: TFont;
  x, tmp: integer;
Begin
  OldFont := TFont.Create;
  OldFont.Assign( Canvas.Font );

  If Font <> Nil Then Canvas.Font := Font;
  tmp := Canvas.TextWidth( Text );
  Case Align Of
    taLeftJustify: x := UnitToX( TextOptions.MarginLeft );
    taCenter: x := PageWidth Div 2 - tmp Div 2;
    taRightJustify: x := PageWidth - UnitToX( TextOptions.MarginRight ) - tmp;
    Else
      x := 0;
  End;

  Canvas.TextOut( x, y, Text );

  Canvas.Font := OldFont;
  OldFont.Free;
End;

Procedure TPreviewPrinter.DrawHdrFtrPage( PageNum: integer );
Var
  y1, y2: integer;
  PageStr: String;
Begin
  With TextOptions Do
    Begin
      // Draw the Header, Footer, & Page Num
      y1 := UnitToY( HeaderMargin );
      y2 := PageHeight - UnitToY( FooterMargin );
      DrawAlignText( y1, HeaderAlign, Header, HeaderFont );
      DrawAlignText( y2, FooterAlign, Footer, FooterFont );
      PageStr := Format( PageNumText, [ PageNum ] );
      Case PrintPageNumber Of
        pnTop: DrawAlignText( y1, PageNumAlign, PageStr, PageNumFont );
        pnBottom: DrawAlignText( y2, PageNumAlign, PageStr, PageNumFont );
      End;
    End;
End;

Procedure TPreviewPrinter.DrawStringList( Strings: TStrings );
Var
  Line: integer;
  Page: integer;
  x, y: integer;
  h: integer;
  R: TRect;
  ForceNewPage: boolean;
  tm: TTextMetric;
Begin
  Screen.Cursor := crHourGlass;
  BeginDoc;

   // Init the fonts
  With TextOptions Do
    Begin
      FixFont( BodyFont );
      FixFont( HeaderFont );
      FixFont( FooterFont );
      FixFont( PageNumFont );
    End;

  Page := 0;

   // Begin Page
  x := UnitToX( TextOptions.MarginLeft );
  y := -2;

  For Line := 0 To Strings.Count - 1 Do
    With TextOptions Do
      Begin
      // Get our current line height (and check for New Page)
        Canvas.Font := BodyFont;
        h := -1;
        ForceNewPage := False;
        If Assigned( OnOwnerHeight ) Then OnOwnerHeight( Self, Line, h, ForceNewPage );
        If ForceNewPage Then
          y := -1;
        If DrawStyle <> dsOwnerDrawVariable Then
          Begin
            h := Canvas.TextHeight( 'f' );
            GetTextMetrics( Canvas.Handle, tm );
            h := h + tm.tmInternalLeading + tm.tmExternalLeading;
          End;
        If h = -1 Then Exception.Create( 'OnOwnerHeight Event returned an invalid height!' );

      // Check if we need a new page
        If ( y < 0 ) Or ( y + h > UnitToY( YToUnit( PageHeight ) - TextOptions.MarginBottom ) ) Then
          Begin
            Page := Page + 1;
            If Assigned( OnNewPage ) Then OnNewPage( Self, Page );
            If y >= -1 Then NewPage;
            y := UnitToY( MarginTop );

            DrawHdrFtrPage( Page );
          End;

      // Draw the current line
        R := Rect( UnitToX( MarginLeft ), y, PageWidth - UnitToX( MarginRight ) + 1, y + h + 1 {PageHeight - lower "g" getting clipped?} );
        Case DrawStyle Of
          dsOwnerDrawFixed,
            dsOwnerDrawVariable:
            If Assigned( OnOwnerDraw ) Then OnOwnerDraw( Self, Page, Line, R, Canvas );
          Else
            Canvas.TextRect( R, x, y, Strings[ Line ] );
        End;

        y := y + h;
      End;

  EndDoc;
  Screen.Cursor := crDefault;
End;

Procedure RE_To_Canvas( RE: TCustomRichEdit; Canvas: TCanvas; Var R: TRect;
  Var Pos: integer; Var NeedWrap: boolean );
Var
  Range: TFormatRange;
  OutDC: HDC;
  LastChar, MaxLen,
    LogX, LogY, OldMap: Integer;
Begin
  Assert( RE <> Nil );
  Assert( IsWindow( RE.Handle ) );

  FillChar( Range, SizeOf( TFormatRange ), 0 );

  LastChar := Pos;

  OutDC := Canvas.Handle;
  Range.hdc := OutDC;
  Range.hdcTarget := OutDC;
  LogX := GetDeviceCaps( OutDC, LOGPIXELSX );
  LogY := GetDeviceCaps( OutDC, LOGPIXELSY );
  If IsRectEmpty( RE.PageRect ) Then
    Begin
      Range.rc := R;
    End
  Else
    Begin
      Range.rc.left := RE.PageRect.Left * 1440 Div LogX;
      Range.rc.top := RE.PageRect.Top * 1440 Div LogY;
      Range.rc.right := RE.PageRect.Right * 1440 Div LogX;
      Range.rc.bottom := RE.PageRect.Bottom * 1440 Div LogY;
    End;
  Range.rcPage := Range.rc;
  MaxLen := RE.GetTextLen;
  Range.chrg.cpMax := -1;

   // ensure the output DC is in text map mode
  OldMap := SetMapMode( Range.hdc, MM_TEXT );
  SendMessage( RE.Handle, EM_FORMATRANGE, 0, 0 ); // flush buffer

  Range.chrg.cpMin := LastChar;
  LastChar := SendMessage( RE.Handle, EM_FORMATRANGE, 1, Longint( @Range ) );
  NeedWrap := ( LastChar < MaxLen ) And ( LastChar <> -1 );

  SendMessage( RE.Handle, EM_FORMATRANGE, 0, 0 ); // flush buffer
  SetMapMode( OutDC, OldMap );

  Pos := LastChar;
  R := Range.rc;
End;

Procedure TPreviewPrinter.DrawRichText( RE: TCustomRichEdit );
Var
  x1, y1: integer;
  x2, y2: integer;
  R: TRect;
  Pos, Page: integer;
  NeedWrap: boolean;
  OldUnits: TUnits;
Begin
  Screen.Cursor := crHourGlass;
  OldUnits := Units;
  Units := unInches;
  Try
    Pos := 0;
    Page := 0;
    Repeat
      If Pos = 0 Then
        BeginDoc
      Else
        NewPage;

      Page := Page + 1;
      DrawHdrFtrPage( Page );

      x1 := Round( 1440.0 * TextOptions.MarginLeft );
      y1 := Round( 1440.0 * TextOptions.MarginTop );
      x2 := Round( 1440.0 * ( XToUnit( PageWidth ) - TextOptions.MarginRight ) );
      y2 := Round( 1440.0 * ( XToUnit( PageHeight ) - TextOptions.MarginBottom ) );
      R := Rect( x1, y1, x2, y2 );

      RE_To_Canvas( RE, Canvas, R, Pos, NeedWrap );
    Until Not NeedWrap;

    EndDoc;
  Finally
    Units := OldUnits;
    Screen.Cursor := crDefault;
  End;
End;

Procedure Register;
Begin
  RegisterComponents( 'Print Preview', [ TPreviewPrinter ] );
End;

End.