psjob.pas

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

        try
          GetDIB(Bits,0,Info^,Image^);
          with Info^.bmiHeader,TheRect do
            StretchDIBits(TheCanvas.Handle,
              Left,Top,Right-Left,Bottom-Top,
              0,0,biWidth,biHeight,
              Image,Info^,DIB_RGB_COLORS,SRCCOPY);
        finally
          FreeMem(Image,ImageSize);
        end;
      finally
        FreeMem(Info,InfoSize);
      end;
    end
    {$IFNDEF PSAVOIDSTRETCHDRAW}
    else StretchDraw(TheRect,Bitmap);
    {$ENDIF}
end;

procedure TCustomPrintJob.StretchBitmap(TheCanvas: TCanvas; const TheRect: TRect; Bitmap: TBitmap; StretchMode: TStretchMode; AlignHorizontal: TAlignHorizontal; AlignVertical: TAlignVertical; Target: TDrawTarget);
var
  R: TRect;
  PrintBitmap: TBitmap;
begin
  with TheCanvas,Bitmap,TheRect do
    if not Empty then
    begin
      case StretchMode of
        smFit:
        begin
          R:=Classes.Rect(
            0,0,
            Right-Left,
            Height*(Right-Left) div Width);
          if R.Bottom>Bottom-Top then
            R:=Classes.Rect(
              0,0,
              Width*(Bottom-Top) div Height,
              Bottom-Top);
        end;
        smOriginalSize: R:=Classes.Rect(0,0,Width,Height);
        smStretch: R:=TheRect;
        else
        begin
          R:=Classes.Rect(
            0,0,
            Width*DPIX div GetDeviceCaps(Canvas.Handle,LOGPIXELSX),
            Height*DPIY div GetDeviceCaps(Canvas.Handle,LOGPIXELSY));
          with R do
            case StretchMode of
              sm50:
              begin
                Right:=Right div 2;
                Bottom:=Bottom div 2;
              end;
              sm75:
              begin
                Right:=2*Right div 3;
                Bottom:=2*Bottom div 3;
              end;
              sm125:
              begin
                Right:=5*Right div 4;
                Bottom:=5*Bottom div 4;
              end;
              sm150:
              begin
                Right:=3*Right div 2;
                Bottom:=3*Bottom div 2;
              end;
              sm175:
              begin
                Right:=7*Right div 4;
                Bottom:=7*Bottom div 4;
              end;
              sm200:
              begin
                Right:=2*Right;
                Bottom:=2*Bottom;
              end;
            end;
        end;
      end;
      if StretchMode<>smStretch then
      begin
        case AlignHorizontal of
          ahLeft: OffsetRect(R,Left,0);
          ahCenter: OffsetRect(R,Left+(Right-Left-R.Right) div 2,0);
          ahRight: OffsetRect(R,Right-R.Right,0);
        end;
        case AlignVertical of
          avTop: OffsetRect(R,0,Top);
          avCenter: OffsetRect(R,0,Top+(Bottom-Top-R.Bottom) div 2);
          avBottom: OffsetRect(R,0,Bottom-R.Bottom);
        end;
      end;
      if Target=dtPrint then
      begin
        PrintBitmap:=TBitmap.Create;
        try
          PrintBitmap.Assign(Bitmap);
          if GetDeviceCaps(TheCanvas.Handle,NUMCOLORS)=2 then
            PrintBitmap.PixelFormat:=pf8Bit;
          DrawBitmap(TheCanvas,R,PrintBitmap,Target);
        finally
          PrintBitmap.Free;
        end;
      end
      else DrawBitmap(TheCanvas,R,Bitmap,Target);
    end;
end;

procedure TCustomPrintJob.StretchGraphic(TheCanvas: TCanvas; const TheRect: TRect; Graphic: TGraphic; StretchMode: TStretchMode; Scale,PageIndex: Integer; AlignHorizontal: TAlignHorizontal; AlignVertical: TAlignVertical; Target: TDrawTarget);
begin
  case StretchMode of
    smFit:
  end;
end;

procedure TCustomPrintJob.DrawTabbedText(TheCanvas: TCanvas; X,Y: Integer; S: string);
var
  TM: TTextMetric;
  Tab: Integer;
begin
  GetTextMetrics(TheCanvas.Handle,TM);
  Tab:=TM.tmAveCharWidth*8;
  TabbedTextOut(TheCanvas.Handle,X,Y,PChar(S),Length(S),1,Tab,0);
end;

function TCustomPrintJob.DPIX: Integer;
begin
  if PrinterOK then Result:=GetDeviceCaps(Printer.Handle,LOGPIXELSX)
  else Result:=300;
end;

function TCustomPrintJob.DPIY: Integer;
begin
  if PrinterOK then Result:=GetDeviceCaps(Printer.Handle,LOGPIXELSY)
  else Result:=300;
end;

function TCustomPrintJob.InchToMm(Inches: Double): Double;
begin
  Result:=MmInInch*Inches;
end;

function TCustomPrintJob.MmToInch(Millimeters: Double): Double;
begin
  Result:=Millimeters/MmInInch;
end;

function TCustomPrintJob.InchToPix(Inches: Double; Direction: TDirection): Double;
begin
  if Direction=dirHorizontal then Result:=Inches*DPIX
  else Result:=Inches*DPIY;
end;

function TCustomPrintJob.PixToInch(Pixels: Double; Direction: TDirection): Double;
begin
  if Direction=dirHorizontal then Result:=Pixels/DPIX
  else Result:=Pixels/DPIY;
end;

function TCustomPrintJob.MmToPix(Millimeters: Double; Direction: TDirection): Double;
begin
  if Direction=dirHorizontal then Result:=Millimeters*DPIX/MmInInch
  else Result:=Millimeters*DPIY/MmInInch;
end;

function TCustomPrintJob.PixToMm(Pixels: Double; Direction: TDirection): Double;
begin
  if Direction=dirHorizontal then Result:=Pixels*MmInInch/DPIX
  else Result:=Pixels*MmInInch/DPIY;
end;

function TCustomPrintJob.GetAborted: Boolean;
begin
  Result:=Printer.Aborted;
end;

procedure TCustomPrintJob.SetPageCount(const Value: Integer);
var
  TheValue: Integer;
begin
  TheValue:=Value;
  if TheValue<1 then TheValue:=1;
  if TheValue<>PageCount then
  begin
    FPageCount:=TheValue;
    Update;
  end;
end;

procedure TCustomPrintJob.SetMargins(const Value: TMargins);
begin
  CheckMargins(Value);
  FMargins.Assign(Value);
  Update;
end;

procedure TCustomPrintJob.SetMarginsUnits(const Value: TUnits);
begin
  {$IFNDEF PSTRIAL}
  if Value<>FMarginsUnits then
  begin
    FMarginsUnits:=Value;
    Update;
  end;
  {$ENDIF}
end;

procedure TCustomPrintJob.SetMarginsError(const Value: TMarginsError);
begin
  if Value<>FMarginsError then
  begin
    FMarginsError:=Value;
    if FMarginsError<>meNone then CheckMargins(Margins);
  end;
end;

procedure TCustomPrintJob.CheckMargins(const Value: TMargins);
const
  ErrorStr = 'One or more margins are set outside the printable area of the page.';
  AnswerStr = #13'Do you want to fix them?';
var
  L,T,R,B: Integer;
  IMarginsError: TMarginsError;
  LR,RR,TR,BR: Boolean;
begin
  if not (csReading in ComponentState) then
  begin
    IMarginsError:=FMarginsError;
    if (csDesigning in ComponentState) and (IMarginsError<>meNone) then IMarginsError:=meAutoFix;
    if (IMarginsError<>meNone) and PrinterOK then
    begin
      with GetMarginRect do
      begin
        L:=GetDeviceCaps(Printer.Handle,PHYSICALOFFSETX);
        LR:=Left<L;
        T:=GetDeviceCaps(Printer.Handle,PHYSICALOFFSETY);
        TR:=Top<T;
        R:=GetDeviceCaps(Printer.Handle,PHYSICALOFFSETX)+Printer.PageWidth;
        RR:=Right>R;
        B:=GetDeviceCaps(Printer.Handle,PHYSICALOFFSETY)+Printer.PageHeight;
        BR:=Bottom>B;
      end;
      if LR or RR or TR or BR then
        case IMarginsError of
          meMessageBox:
            if Application.MessageBox(
              ErrorStr+AnswerStr,
              PChar(Application.Title),
              MB_YESNO or MB_ICONEXCLAMATION)<>ID_YES then Exit;
          meException: raise EPrintJobException.Create(ErrorStr);
          meNone: Exit;
        end;
      if LR then Value.Left:=ConvertUnits(L,unPixels,MarginsUnits,dirHorizontal,PhysicalPageWidth);
      if TR then Value.Top:=ConvertUnits(T,unPixels,MarginsUnits,dirVertical,PhysicalPageHeight);
      if RR then Value.Right:=ConvertUnits(PhysicalPageWidth-R,unPixels,MarginsUnits,dirHorizontal,PhysicalPageWidth);
      if BR then Value.Bottom:=ConvertUnits(PhysicalPageHeight-B,unPixels,MarginsUnits,dirVertical,PhysicalPageHeight);
      if LR or RR or TR or BR then FMargins.Assign(Value);
    end;
  end;
end;

procedure TCustomPrintJob.SetHeader(const Value: Double);
begin
  {$IFNDEF PSTRIAL}
  if Value<>FHeader then
  begin
    FHeader:=Value;
    Update;
  end;
  {$ENDIF}
end;

procedure TCustomPrintJob.SetHeaderUnits(const Value: TUnits);
begin
  {$IFNDEF PSTRIAL}
  if Value<>FHeaderUnits then
  begin
    FHeaderUnits:=Value;
    Update;
  end;
  {$ENDIF}
end;

procedure TCustomPrintJob.SetFooter(const Value: Double);
begin
  {$IFNDEF PSTRIAL}
  if Value<>FFooter then
  begin
    FFooter:=Value;
    Update;
  end;
  {$ENDIF}
end;

procedure TCustomPrintJob.SetFooterUnits(const Value: TUnits);
begin
  {$IFNDEF PSTRIAL}
  if Value<>FFooterUnits then
  begin
    FFooterUnits:=Value;
    Update;
  end;
  {$ENDIF}
end;

procedure TCustomPrintJob.SetPageMode(const Value: TPageMode);
begin
  {$IFNDEF PSTRIAL}
  if FPageMode<>Value then
  begin
    FPageMode:=Value;
    ResetToDefaultPage;
    Update;
  end;
  {$ENDIF}
end;

procedure TCustomPrintJob.SetPageWidth(const Value: Double);
begin
  {$IFNDEF PSTRIAL}
  if FPageWidth<>Value then
  begin
    if FPageMode=pmCustom then FPageWidth:=Value
    else ResetToDefaultPage;
    Update;
  end;
  {$ENDIF}
end;

procedure TCustomPrintJob.SetPageHeight(const Value: Double);
begin
  {$IFNDEF PSTRIAL}
  if FPageHeight<>Value then
  begin
    if FPageMode=pmCustom then FPageHeight:=Value
    else ResetToDefaultPage;
    Update;
  end;
  {$ENDIF}
end;

procedure TCustomPrintJob.SetPageUnits(const Value: TUnits);
begin
  {$IFNDEF PSTRIAL}
  if Value<>FPageUnits then
  begin
    FPageUnits:=Value;
    ResetToDefaultPage;
    Update;
  end;
  {$ENDIF}
end;

procedure TCustomPrintJob.SetOrientation(const Value: TPageOrientation);
begin
  {$IFNDEF PSTRIAL}
  if Value<>FOrientation then
  begin
    FOrientation:=Value;
    ResetToDefaultPage;
    Update;
  end;
  {$ENDIF}
end;

procedure TCustomPrintJob.SetOptions(const Value: TJobOptionsSet);
begin
  {$IFNDEF PSTRIAL}
  if Value<>FOptions then
  begin
    FOptions:=Value;
    Update;
  end;
  {$ENDIF}
end;

procedure TCustomPrintJob.SetRelativeCoords(const Value: Boolean);
begin
  if Value<>FRelativeCoords then
  begin
    FRelativeCoords:=Value;
    Update;
  end;
end;

procedure TCustomPrintJob.SetDefaultDrawing(const Value: TDrawAreas);
begin
  if Value<>FDefaultDrawing then
  begin
    FDefaultDrawing:=Value;
    Update;
  end;
end;

function TCustomPrintJob.GetUpdateLocked: Boolean;
begin
  Result:=FUpdateLocker>0;
end;

function TCustomPrintJob.GetUpdateJobsLocked: Boolean;
begin
  Result:=FUpdateJobsLocker>0;
end;

function TCustomPrintJob.GetUpdateControlsLocked: Boolean;
begin
  Result:=FUpdateControlsLocker>0;
end;

function TCustomPrintJob.GetDrawLocked: Boolean;
begin
  Result:=FDrawLocker>0;
end;

function TCustomPrintJob.GetPhysicalPageWidth: Integer;
begin
  if PrinterOK then Result:=GetDeviceCaps(Printer.Handle,PHYSICALWIDTH)
  else Result:=2000;
end;

function TCustomPrintJob.GetPhysicalPageHeight: Integer;
begin
  if PrinterOK then Result:=GetDeviceCaps(Printer.Handle,PHYSICALHEIGHT)
  else Result:=3000;
end;

procedure TCustomPrintJob.Loaded;
begin
  inherited;
  CheckMargins(Margins);
end;

procedure TCustomPrintJob.PhysicalOffset(var R: TRect);
begin
  OffsetRect(
    R,
    -GetDeviceCaps(Printer.Handle,PHYSICALOFFSETX),
    -GetDeviceCaps(Printer.Handle,PHYSICALOFFSETY));
end;

procedure Register;
begin
  RegisterComponents('Print Suite', [TPrintJob]);
end;

{$IFDEF PSTRIAL}
initialization
  MessageBox(
    0,
    'You are using trial version of Greatis Print Suite Pro with some functional limitations.'#13+
      'To get full-functional product visit http://www.greatis.com/delphicb/printsuite/order.html',
    'Greatis Print Suite Pro - Trial Version',
    MB_OK or MB_ICONEXCLAMATION);
{$ENDIF}
end.