psjob.pas

GREATIS Print Suite Pro for Delphi (3-7,2005,2006,2007) and C++ Builder (3-6) Set of components for

  if joFooter in FOptions then
  begin
    Result:=GetMarginRect;
    with Result do
      Top:=Bottom-Round(ConvertUnits(FFooter,FFooterUnits,unPixels,dirVertical,Bottom-Top));
  end
  else Result:=Rect(0,0,0,0);
end;

function TCustomPrintJob.ConvertUnits(Source: Double; FromUnits,ToUnits: TUnits; Dir: TDirection; FullRange: Double): Double;
var
  Internal,Prec: Double;
begin
  if FromUnits<>ToUnits then
  begin
    case FromUnits of
      unPixels: Internal:=PixToMm(Source,Dir);
      unPercents: Internal:=PixToMm(Source*FullRange/100,Dir);
      unInches: Internal:=InchToMm(Source);
    else Internal:=Source;
    end;
    case ToUnits of
      unPixels: Result:=MmToPix(Internal,Dir);
      unPercents: Result:=100*MmToPix(Internal,Dir)/FullRange;
      unInches: Result:=MmToInch(Internal);
    else Result:=Internal;
    end;
  end
  else Result:=Source;
  case ToUnits of
    unPercents: Prec:=Power(10,upPercents);
    unInches: Prec:=Power(10,upInches);
    unMillimeters: Prec:=Power(10,upMillimeters);
  else Prec:=1;
  end;
  Result:=Round(Result*Prec)/Prec;
end;

procedure TCustomPrintJob.ConvertMargins(M: TMargins; FromUnits,ToUnits: TUnits);
begin
  with M do
  begin
    Left:=ConvertUnits(Left,FromUnits,ToUnits,dirHorizontal,FPageWidth);
    Top:=ConvertUnits(Top,FromUnits,ToUnits,dirVertical,FPageHeight);
    Right:=ConvertUnits(Right,FromUnits,ToUnits,dirHorizontal,FPageWidth);
    Bottom:=ConvertUnits(Bottom,FromUnits,ToUnits,dirVertical,FPageHeight);
  end;
end;

procedure TCustomPrintJob.PaintTo(TheCanvas: TCanvas; PageIndex: Integer);
begin
  Draw(TheCanvas,PageIndex,dtExternal);
end;

procedure TCustomPrintJob.InitDraw(TheCanvas: TCanvas; Target: TDrawTarget);
begin
  with TheCanvas do
  begin
    with Font do
    begin
      Name:='Arial';
      Color:=clBlack;
      Style:=[];
      Size:=10;
    end;
    with Pen do
    begin
      Color:=clBlack;
      Mode:=pmCopy;
      Style:=psSolid;
      Width:=0;
    end;
    with Brush do
    begin
      Color:=clWhite;
      Style:=bsSolid;
    end;
    FillRect(GetSheetRect);
  end;
  if Assigned(FOnInitDraw) then
    FOnInitDraw(Self,TheCanvas,Target);
end;

procedure TCustomPrintJob.Draw(TheCanvas: TCanvas; PageIndex: Integer; Target: TDrawTarget);

var
  PrevOrg,OldOrg: TPoint;
  R: TRect;
  V,W: TSize;
  ScaleX,ScaleY: Double;

  procedure DrawAreaCall(R: TRect; Area: TDrawArea);
  begin
    if Area in DefaultDrawing then DrawArea(TheCanvas,PageIndex,R,Area,Target)
    else
      if Assigned(FOnDraw) then FOnDraw(Self,TheCanvas,PageIndex,R,Area,Target);
  end;

  procedure ResetCanvas;
  var
    DC: HDC;
  begin
    with TheCanvas do
    begin
      DC:=Handle;
      Handle:=0;
      Handle:=DC;
    end;
  end;

begin
  FDrawTarget:=Target;
  if not DrawLocked then
  begin
    GetViewportExtEx(TheCanvas.Handle,V);
    GetWindowExtEx(TheCanvas.Handle,W);
    ScaleX:=V.CX/W.CX;
    ScaleY:=V.CY/W.CY;
    ResetToDefaultPage;
    TheCanvas.Font.PixelsPerInch:=GetDeviceCaps(Printer.Handle,LOGPIXELSY);
    GetViewportOrgEx(TheCanvas.Handle,PrevOrg);
    InitDraw(TheCanvas,Target);
    ResetCanvas;
    R:=GetPageRect;
    if FRelativeCoords then
      with R do
      begin
        SetViewportOrgEx(
          TheCanvas.Handle,
          PrevOrg.X+Round(Left*ScaleX),
          PrevOrg.Y+Round(Top*ScaleY),
          @OldOrg);
        try
          OffsetRect(R,-Left,-Top);
          DrawAreaCall(R,daPage);
        finally
          with OldOrg do SetViewportOrgEx(TheCanvas.Handle,X,Y,nil);
        end;
      end
    else DrawAreaCall(R,daPage);
    if joHeader in FOptions then
    begin
      ResetCanvas;
      R:=GetHeaderRect;
      if FRelativeCoords then
        with R do
        begin
          SetViewportOrgEx(
            TheCanvas.Handle,
            PrevOrg.X+Round(Left*ScaleX),
            PrevOrg.Y+Round(Top*ScaleY),
            @OldOrg);
          try
            OffsetRect(R,-Left,-Top);
            DrawAreaCall(R,daHeader);
          finally
            with OldOrg do SetViewportOrgEx(TheCanvas.Handle,X,Y,nil);
          end;
        end
      else DrawAreaCall(R,daHeader);
    end;
    if joFooter in FOptions then
    begin
      ResetCanvas;
      R:=GetFooterRect;
      if FRelativeCoords then
        with R do
        begin
          SetViewportOrgEx(
            TheCanvas.Handle,
            PrevOrg.X+Round(Left*ScaleX),
            PrevOrg.Y+Round(Top*ScaleY),
            @OldOrg);
          try
            OffsetRect(R,-Left,-Top);
            DrawAreaCall(R,daFooter);
          finally
            with OldOrg do SetViewportOrgEx(TheCanvas.Handle,X,Y,nil);
          end;
        end
      else DrawAreaCall(R,daFooter);
    end;
  end;
end;

procedure TCustomPrintJob.DrawArea(TheCanvas: TCanvas; PageIndex: Integer; TheRect: TRect; Area: TDrawArea; Target: TDrawTarget);
begin
  if Assigned(FOnDraw) then
    FOnDraw(Self,TheCanvas,PageIndex,TheRect,Area,Target);
end;

procedure TCustomPrintJob.PrinterSetupChange;
begin
  if Assigned(FOnPrinterSetupChange) then FOnPrinterSetupChange(Self);
end;

function TCustomPrintJob.AllowPrint: Boolean;
begin
  Result:=True;
  if Assigned(FOnAllowPrint) then FOnAllowPrint(Self,Result);
end;

procedure TCustomPrintJob.StartPrint;
begin
  if Assigned(FOnStartPrint) then FOnStartPrint(Self);
end;

procedure TCustomPrintJob.EndPrint;
begin
  if Assigned(FOnEndPrint) then FOnEndPrint(Self);
end;

procedure TCustomPrintJob.PrintProgress(CurPage,MinPage,MaxPage: Integer);
begin
  if Assigned(FOnPrintProgress) then FOnPrintProgress(Self,CurPage,MinPage,MaxPage);
end;

procedure TCustomPrintJob.StartPrintPage(PageIndex: Integer);
begin
  if Assigned(FOnStartPrintPage) then FOnStartPrintPage(Self,PageIndex);
end;

procedure TCustomPrintJob.EndPrintPage(PageIndex: Integer);
begin
  if Assigned(FOnEndPrintPage) then FOnEndPrintPage(Self,PageIndex);
end;

procedure TCustomPrintJob.ForceNewPage(PageIndex: Integer);
begin
  Printer.NewPage;
end;

procedure TCustomPrintJob.PrintEx(StartPage,EndPage: Integer; PrintMode: TPrintModes);

var
  Page: Integer;

  procedure PrintPage(Page: Integer);
  var
    ProgressPage: Integer;
  begin
    with Printer do
    begin
      if pmMultiDoc in PrintMode then BeginDoc;
      StartPrintPage(Page);
      Draw(Canvas,Page,dtPrint);
      EndPrintPage(Page);
      if pmMultiDoc in PrintMode then EndDoc
      else;
        if Page<EndPage then ForceNewPage(Page);
      if pmReverse in PrintMode then ProgressPage:=Succ(StartPage-Page)
      else ProgressPage:=Succ(Page-StartPage);
      PrintProgress(ProgressPage,1,Abs(EndPage-StartPage));
      Application.ProcessMessages;
    end;
  end;

begin
  if AllowPrint then
  begin
    FMustAbort:=False;
    with Printer do
    begin
      case Self.Orientation of
        orLandscape: Orientation:=poLandscape;
        orPortrait: Orientation:=poPortrait;
      end;
      Title:=FTitle;
      StartPrint;
      if not (pmMultiDoc in PrintMode) then BeginDoc;
      if pmReverse in PrintMode then
        for Page:=EndPage downto StartPage do
        begin
          if FMustAbort then
          begin
            FMustAbort:=False;
            Break;
          end;
          PrintPage(Page);
        end
      else
        for Page:=StartPage to EndPage do
        begin
          if FMustAbort then
          begin
            FMustAbort:=False;
            Break;
          end;
          PrintPage(Page);
        end;
      if not (pmMultiDoc in PrintMode) then EndDoc;
      EndPrint;
    end;
  end;
end;

procedure TCustomPrintJob.Print;
var
  PM: TPrintModes;
begin
  if FMultiDoc then PM:=[pmMultiDoc]
  else PM:=[];
  PrintEx(1,PageCount,PM);
end;

procedure TCustomPrintJob.PrintDialog;
var
  PM: TPrintModes;
begin
  with TPrintDialog.Create(Owner) do
  try
    Options:=Options+[poPageNums];
    MinPage:=1;
    MaxPage:=PageCount;
    FromPage:=1;
    ToPage:=PageCount;
    if Execute then
    begin
      Update;
      FMustAbort:=False;
      with Printer do
      begin
        Title:=FTitle;
        Update;
        PrinterSetupChange;
        if FMultiDoc then PM:=[pmMultiDoc]
        else PM:=[];
        PrintEx(FromPage,ToPage,PM);
      end;
    end;
  finally
    Free;
  end;
end;

procedure TCustomPrintJob.PrinterSetupDialog;
begin
  with TPrinterSetupDialog.Create(Owner) do
  try
    if Execute then
    begin
      Update;
      PrinterSetupChange;
      Update;
    end;
  finally
    Free;
  end;
end;

procedure TCustomPrintJob.Abort;
begin
  FMustAbort:=True;
end;

procedure TCustomPrintJob.ResetToDefaultPage;
begin
  if PrinterOK then
  begin
    if (FOrientation<>orDefault) and not Printer.Printing then
      Printer.Orientation:=TPrinterOrientation(Pred(FOrientation));
    if PageMode=pmDefault then
    begin
      FPageWidth:=ConvertUnits(PhysicalPageWidth,unPixels,FPageUnits,dirHorizontal,PhysicalPageWidth);
      FPageHeight:=ConvertUnits(PhysicalPageHeight,unPixels,FPageUnits,dirVertical,PhysicalPageHeight);
    end;
  end
  else
  begin
    FPageHeight:=3000;
    FPageWidth:=2000;
  end;
end;

procedure TCustomPrintJob.AddControlNotification(AControl: TControl);
begin
  if Assigned(FControls) then
    with FControls do
      if IndexOf(AControl)=-1 then Add(AControl);
end;

procedure TCustomPrintJob.DeleteControlNotification(AControl: TControl);
begin
  if Assigned(FControls) then
    with FControls do
      try
        if IndexOf(AControl)<>-1 then Delete(IndexOf(AControl));
      except
      end;
end;

procedure TCustomPrintJob.AddPrintJobNotification(APrintJob: TCustomPrintJob);
begin
  with FPrintJobs do
    if IndexOf(APrintJob)=-1 then Add(APrintJob);
end;

procedure TCustomPrintJob.DeletePrintJobNotification(APrintJob: TCustomPrintJob);
begin
  with FPrintJobs do
    if IndexOf(APrintJob)<>-1 then Delete(IndexOf(APrintJob));
end;

procedure TCustomPrintJob.Update;
begin
  ApplyUpdates;
end;

procedure TCustomPrintJob.ApplyUpdates;
var
  i: Integer;
begin
  if not UpdateLocked then
  begin
    if PrinterOK then
    begin
      ResetToDefaultPage;
      CheckMargins(Margins);
      if not UpdateJobsLocked then
        for i:=0 to Pred(FPrintJobs.Count) do
        try
          TCustomPrintJob(FPrintJobs[i]).Update;
        except
        end;
      if Assigned(FControls) then
        if not UpdateControlsLocked then
          for i:=0 to Pred(FControls.Count) do
          try
            TControl(FControls[i]).Update;
          except
          end;
      if Assigned(FOnUpdate) then FOnUpdate(Self);
    end;
  end;
end;

function TCustomPrintJob.PrinterOK: Boolean;
begin
  try
    Result:=(Printer.Handle<>0) and (Printer.Printers.Count>0);
  except
    Result:=False;
  end;
end;

procedure TCustomPrintJob.DrawBitmap(TheCanvas: TCanvas; const TheRect: TRect; Bitmap: TBitmap; Target: TDrawTarget);
var
  Info: PBitmapInfo;
  Image: Pointer;
  InfoSize,ImageSize: DWORD;
  Bits: HBITMAP;
begin
  with TheCanvas do
    {$IFNDEF PSAVOIDSTRETCHDRAW}
    if Target=dtPrint then
    {$ENDIF}
    begin
      Bits:=Bitmap.Handle;
      GetDIBSizes(Bits,InfoSize,ImageSize);
      Info:=AllocMem(InfoSize);
      try
        Image:=AllocMem(ImageSize);