gmclasses.pas

GmPrintSuite 2.96.7] a

  //----------------------------------------------------------------------------

  // *** TGmPaperImage ***

  TGmPaperImage = class(TPaintBox)
  private
    FDragDrawing: Boolean;
    FDragDrawRect: TRect;
    FDragDrawShape: TGmDragDrawing;
    FDrawPage: Boolean;
    FDrawPpi: integer;
    FFastDraw: Boolean;
    FGrid: TGmPageGrid;
    FGutters: TRect;
    FMargins: TGmMargins;
    FPaperSizeInch: TGmSize;
    FPage: TObject;
    FShadow: TGmShadow;
    FUpdateCount: integer;
    FMouseValuePoint: TGmValuePoint;
    FDragValuePoint: TGmValuePoint;
    FZoom: integer;
    // events...
    FOnMouseEnter: TNotifyEvent;
    FOnMouseLeave: TNotifyEvent;
    FOnPageDragDrop: TGmPageDragDropEvent;
    FOnPageDragOver: TGmPageDragOverEvent;
    FOnPageMouseDown: TGmPageMouseEvent;
    FOnPageMouseMove: TGmPageMouseMoveEvent;
    FOnPageMouseUp: TGmPageMouseEvent;
    FOnPaintPage: TNotifyEvent;
    function CalcCursorPos: TPoint;
    function GetDragDrawInchRect: TGmRect;
    function GetIsUpdating: Boolean;
    function GetPageExtent(Ppi: integer): TSize;
    procedure Changed(Sender: TObject);
    procedure DrawPaper(Ppi: integer; OutlineOnly: Boolean);
    procedure DrawDragOutline;
    procedure SetDrawPpi(Value: integer);
    procedure SetGrid(Value: TGmPageGrid);
    procedure SetGutters(Value: TRect);
    procedure SetMargins(Value: TGmMargins);
    procedure SetPage(Value: TObject);
    procedure SetPaperSizeInch(ASize: TGmSize);
    procedure SetShadow(Value: TGmShadow);
    procedure SetZoom(Value: integer);
    procedure XYtoInchValuePoint(x, y: integer; var Value: TGmValuePoint);
  protected

    procedure DragOver(Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function PageRect: TRect; virtual;
    procedure BeginUpdate;
    procedure ClipPaper;
    procedure DragDrawStop;
    procedure DragDrawStart;
    procedure DragDrop(Source: TObject; X, Y: Integer); override;
    procedure EndUpdate;
    property CursorPos: TPoint read CalcCursorPos;
    property DragDrawRect: TRect read FDragDrawRect;
    property DragDrawInchRect: TGmRect read GetDragDrawInchRect;
    property DragDrawShape: TGmDragDrawing read FDragDrawShape write FDragDrawShape default gmDragRectangle;
    property DrawPpi: integer read FDrawPpi write SetDrawPpi default 600;
    property DrawPage: Boolean read FDrawPage write FDrawPage default True;
    property FastDraw: Boolean read FFastDraw write FFastDraw default False;
    property IsDragDrawing: Boolean read FDragDrawing;
    property IsUpdating: Boolean read GetIsUpdating;
    property Grid: TGmPageGrid read FGrid write SetGrid;
    property Gutters: TRect read FGutters write SetGutters;
    property Margins: TGmMargins read FMargins write SetMargins;
    property Page: TObject read FPage write SetPage;
    property PageExtent[Ppi: integer]: TSize read GetPageExtent;
    property PaperSizeInch: TGmSize read FPaperSizeInch write SetPaperSizeInch;
    property Shadow: TGmShadow read FShadow write SetShadow;
    property Zoom: integer read FZoom write SetZoom default 20;
    // events...
    property OnDragOver;
    property OnDragDrop;
    property OnMouseDown;
    property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
    property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    {$IFDEF D6+}
    property OnMouseWheel;
    property OnMouseWheelDown;
    property OnMouseWheelUp;
    {$ENDIF}
    property OnPageDragDrop: TGmPageDragDropEvent read FOnPageDragDrop write FOnPageDragDrop;
    property OnPageDragOver: TGmPageDragOverEvent read FOnPageDragOver write FOnPageDragOver;
    property OnPageMouseDown: TGmPageMouseEvent read FOnPageMouseDown write FOnPageMouseDown;
    property OnPageMouseMove: TGmPageMouseMoveEvent read FOnPageMouseMove write FOnPageMouseMove;
    property OnPageMouseUp: TGmPageMouseEvent read FOnPageMouseUp write FOnPageMouseUp;
    property OnPaintPage: TNotifyEvent read FOnPaintPage write FOnPaintPage;
  end;

implementation

uses GmFuncs, GmObjects, GmPageList, GmConst, GmPrinter, ComObj, Math,
  SysUtils;

//----------------------------------------------------------------------------

// *** TGmComponent ***

function TGmComponent.GetAbout: string;
begin
  Result := GetStrVersion(Self);
end;

function TGmComponent.GetVersion: Extended;
begin
  Result := GMPS_VERSION;
end;

procedure TGmComponent.SetAbout(const Value: string);
begin
  // does nothing. (needed for published properties)
end;


//----------------------------------------------------------------------------

// *** TGmScrollingWinControl ***

constructor TGmScrollingWinControl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := [csCaptureMouse, csClickEvents, csSetCaption, csDoubleClicks];
  ParentColor := False;
  if not ParentColor then
    Color := $C0C0C0;
  FBorderStyle := bsSingle;
  DoubleBuffered := True;
end;

function TGmScrollingWinControl.GetAbout: string;
begin
  Result := GetStrVersion(Self);
end;

function TGmScrollingWinControl.GetVersion: Extended;
begin
  Result := GMPS_VERSION;
end;

procedure TGmScrollingWinControl.SetBorderStyle(Value: TBorderStyle);
begin
  if Value <> FBorderStyle then
  begin
    FBorderStyle := Value;
    RecreateWnd;
  end;
end;

procedure TGmScrollingWinControl.CreateParams(var Params: TCreateParams);
const
  BorderStyles: array[TBorderStyle] of DWORD = (0, WS_BORDER);
begin
  inherited CreateParams(Params);
  with Params do
  begin
    Style := Style or BorderStyles[FBorderStyle];
    if NewStyleControls and Ctl3D and (FBorderStyle = bsSingle) then
    begin
      Style := Style and not WS_BORDER;
      ExStyle := ExStyle or WS_EX_CLIENTEDGE;
    end;
  end;
end;

procedure TGmScrollingWinControl.SetAbout(const Value: string);
begin
  // does nothing. (needed for published properties)
end;

procedure TGmScrollingWinControl.CMCtl3DChanged(var Message: TMessage);
begin
  if NewStyleControls and (FBorderStyle = bsSingle) then RecreateWnd;
  inherited;
end;

//----------------------------------------------------------------------------

// *** TGmWinControl ***

constructor TGmWinControl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := [csCaptureMouse, csClickEvents, csSetCaption, csDoubleClicks];
  ParentColor := False;
  if not ParentColor then
    Color := $C0C0C0;
  FBorderStyle := bsSingle;
end;

function TGmWinControl.GetAbout: string;
begin
  Result := GetStrVersion(Self);
end;

function TGmWinControl.GetVersion: Extended;
begin
  Result := GMPS_VERSION;
end;

procedure TGmWinControl.SetAbout(const Value: string);
begin
  // does nothing. (needed for published properties)
end;

procedure TGmWinControl.SetBorderStyle(Value: TBorderStyle);
begin
  if Value <> FBorderStyle then
  begin
    FBorderStyle := Value;
    RecreateWnd;
  end;
end;

procedure TGmWinControl.CMCtl3DChanged(var Message: TMessage);
begin
  if NewStyleControls and (FBorderStyle = bsSingle) then RecreateWnd;
  inherited;
end;

procedure TGmWinControl.CreateParams(var Params: TCreateParams);
const
  BorderStyles: array[TBorderStyle] of DWORD = (0, WS_BORDER);
begin
  inherited CreateParams(Params);
  with Params do
  begin
    Style := Style or BorderStyles[FBorderStyle];
    if NewStyleControls and Ctl3D and (FBorderStyle = bsSingle) then
    begin
      Style := Style and not WS_BORDER;
      ExStyle := ExStyle or WS_EX_CLIENTEDGE;
    end;
  end;
end;

//----------------------------------------------------------------------------

// *** TGmComboBox ***

function TGmComboBox.GetAbout: string;
begin
  Result := GetStrVersion(Self);
end;

function TGmComboBox.GetVersion: Extended;
begin
  Result := GMPS_VERSION;
end;

procedure TGmComboBox.SetAbout(const Value: string);
begin
  // does nothing. (needed for published properties)
end;

//------------------------------------------------------------------------------

// *** TGmValue ***

constructor TGmValue.Create(const AChangeEvent: TNotifyEvent = nil);
begin
  inherited Create;
  FOnChange := AChangeEvent;
end;

constructor TGmValue.CreateValue(Value: Extended; Measurement: TGmMeasurement);
begin
  Create(nil);
  FInches := ConvertValue(Value, Measurement, gmInches);
end;

procedure TGmValue.Assign(Source: TPersistent);
begin
  if (Source is TGmValue) then
  begin
    FInches := (Source as TGmValue).AsInches;
    Changed;
  end
  else
    inherited Assign(Source);
end;

function TGmValue.GetAsMillimeters: Extended;
begin
  Result := ConvertValue(FInches, gmInches, gmMillimeters);
end;

function TGmValue.GetAsPixels(Ppi: integer): integer;
begin
  Result := Round(FInches * Ppi);
end;

function TGmValue.GetAsCentimeters: Extended;
begin
  Result := ConvertValue(FInches, gmInches, gmCentimeters);
end;

function TGmValue.GetAsGmUnits: integer;
begin
  Result := Round(ConvertValue(FInches, gmInches, gmUnits));
end;

function TGmValue.GetAsTwips: integer;
begin
  Result := Round(ConvertValue(FInches, gmInches, gmTwips));
end;

function TGmValue.GetGmValue(Measurement: TGmMeasurement): Extended;
begin
  Result := ConvertValue(FInches, gmInches, Measurement);
end;

procedure TGmValue.Changed;
begin
  if Assigned(FOnChange) then FOnChange(Self);
end;

procedure TGmValue.SetAsCentimeters(Value: Extended);
begin
  AsInches := ConvertValue(Value, gmCentimeters, gmInches);
end;

procedure TGmValue.SetAsGmUnits(Value: integer);
begin
  AsInches := ConvertValue(Value, gmUnits, gmInches);
end;

procedure TGmValue.SetAsInches(Value: Extended);
begin
  if FInches = Value then Exit;
  FInches := Value;
  Changed;
end;

procedure TGmValue.SetAsMillimeters(Value: Extended);
begin
  AsInches := ConvertValue(Value, gmMillimeters, gmInches);
end;

procedure TGmValue.SetAsPixels(Ppi: integer; Value: integer);
begin
  SetAsInches(Value * Ppi);
end;

procedure TGmValue.SetAsTwips(Value: integer);
begin
  AsInches := ConvertValue(Value, gmTwips, gmInches);
end;

procedure TGmValue.SetGmValue(Measurement: TGmMeasurement; Value: Extended);
begin
  AsInches := ConvertValue(Value, Measurement, gmInches);
end;

//------------------------------------------------------------------------------

constructor TGmCustomValueSize.Create;
begin
  inherited Create;
  FHeight := TGmValue.Create(ValueChanged);
  FWidth := TGmValue.Create(ValueChanged);
end;

destructor TGmCustomValueSize.Destroy;
begin
  FHeight.Free;
  FWidth.Free;
  inherited Destroy;
end;

procedure TGmCustomValueSize.Assign(Source: TPersistent);
begin
  if (Source is TGmValueSize) then
  begin
    FWidth.AsInches := (Source as TGmValueSize).Width.AsInches;
    FHeight.AsInches := (Source as TGmValueSize).Height.AsInches;
  end
  else
    inherited Assign(Source);
end;

procedure TGmCustomValueSize.ValueChanged(Sender: TObject);
begin
  if Assigned(FOnChange) then FOnChange(Self);
end;

//------------------------------------------------------------------------------

// *** TGmValueRect ***

constructor TGmValueRect.Create;
begin
  inherited Create;
  FTopLeft := TGmValuePoint.Create;
  FBottomRight := TGmValuePoint.Create;
end;

destructor TGmValueRect.Destroy;
begin
  FTopLeft.Free;
  FBottomRight.Free;
  inherited Destroy;
end;

function TGmValueRect.GetAsInchRect: TGmRect;
begin
  Result.Left   := FTopLeft.X.AsInches;
  Result.Top    := FTopLeft.Y.AsInches;
  Result.Right  := FBottomRight.X.AsInches;
  Result.Bottom := FBottomRight.Y.AsInches;
end;

function TGmValueRect.GetValue(index: integer): TGmValue;
begin
  Result := nil;
  case Index of
    1: Result := FTopLeft.X;
    2: Result := FTopLeft.Y;
    3: Result := FBottomRight.X;
    4: Result := FBottomRight.Y;
  end;
end;

procedure TGmValueRect.SetAsInchRect(Value: TGmRect);
begin
  FTopLeft.X.AsInches := Value.Left;
  FTopLeft.Y.AsInches := Value.Top;
  FBottomRight.X.AsInches := Value.Right;
  FBottomRight.Y.AsInches := Value.Bottom;
end;

procedure TGmValueRect.SetValue(index: integer; Value: TGmValue);
begin
  case Index of
    1: FTopLeft.X.Assign(Value);
    2: FTopLeft.Y.Assign(Value);
    3: FBottomRight.X.Assign(Value);
    4: FBottomRight.Y.Assign(Value);
  end;
end;

//------------------------------------------------------------------------------

// *** TGmBaseObject ***

constructor TGmBaseObject.Create(AResourceTable: TGmResourceTable);
begin
  inherited Create;
  FResourceTable := AResourceTable;
  FObjectID := GetObjectID;
  FPrintThisObject := True;
  FTag := -1;
end;

procedure TGmBaseObject.Draw(ACanvas: TCanvas; var Data: TGmObjectDrawData);
begin
  if IsPrinterCanvas(ACanvas) then
  begin
    if FPrintThisObject then
      DrawToCanvas(ACanvas, Data);
  end
  else
    DrawToCanvas(ACanvas, Data);
end;

procedure TGmBaseObject.DrawToCanvas(ACanvas: TCanvas; var Data: TGmObjectDrawData);
begin
  // overridden in decendant classes
end;

procedure TGmBaseObject.LoadFromStream(Stream: TStream);
var
  Values: TGmValueList;
begin
  Values := TGmValueList.Create;
  try
    Values.LoadFromStream(Stream);
    LoadFromValueList(Values);
  finally
    Values.Free;
  end;
end;

procedure TGmBaseObject.OffsetObject(x, y: Extended; Measurement: TGmMeasurement);
begin
  // overridden in decendant classes
end;

procedure TGmBaseObject.SaveToStream(Stream: TStream);
var