paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-06-05 19:38:19 +02:00
Code Issues Packages Projects Releases Wiki Activity

fpvectorial: Fix some bugs in wmf writer. TvPage.CalculateDocumentSize does not change TvPage.Width and .Height any more.

Browse Source
This commit is contained in:
wp_xyz 2023-01-22 17:31:27 +01:00
parent 9cc1d1622d
commit 6fcd0a3784
5 changed files with 144 additions and 104 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
components/fpvectorial/fpvectorial.pas
View File

@ -1486,11 +1486,14 @@ type
BackgroundColor: TFPColor;
AdjustPenColorToBackground: Boolean;
RenderInfo: TvRenderInfo; // Prepared by the reader with info on how to draw the page
public
{ Base methods }
constructor Create(AOwner: TvVectorialDocument); virtual;
destructor Destroy; override;
procedure Assign(ASource: TvPage); virtual;
procedure SetPageFormat(AFormat: TvPageFormat);
function RealWidth: Double;
function RealHeight: Double;
{ Data reading methods }
procedure CalculateDocumentSize; virtual;
function GetEntity(ANum: Cardinal): TvEntity; virtual; abstract;
@ -1520,6 +1523,7 @@ type
{ Debug methods }
procedure GenerateDebugTree(ADestRoutine: TvDebugAddItemProc; APageItem: Pointer); virtual; abstract;
property Owner: TvVectorialDocument read FOwner;
property UseTopLeftCoordinates: Boolean read FUseTopLeftCoordinates write FUseTopLeftCoordinates;
end;
@ -1536,7 +1540,6 @@ type
procedure AppendSegmentToTmpPath(ASegment: TPathSegment);
procedure CallbackDeleteEntity(data,arg:pointer);
public
Owner: TvVectorialDocument;
{ Base methods }
constructor Create(AOwner: TvVectorialDocument); override;
destructor Destroy; override;
@ -5937,8 +5940,8 @@ procedure TvCircle.CalculateBoundingBox(constref ARenderInfo: TvRenderInfo;
begin
ALeft := X - Radius;
ARight := X + Radius;
ATop := Y + Radius;
ABottom := Y - Radius;
ATop := Y - Radius * ARenderInfo.Page.GetTopLeftCoords_Adjustment;
ABottom := Y + Radius * ARenderInfo.Page.GetTopLeftCoords_Adjustment;
end;
function TvCircle.CreatePath: TPath;
@ -6322,7 +6325,7 @@ begin
ALeft := Min(ALeft, pts[j].x);
ARight := Max(ARight, pts[j].x);
mx := Max(mx, pts[j].y);
mn := Min(mx, pts[j].y);
mn := Min(mn, pts[j].y);
end;
if ARenderInfo.Page.UseTopLeftCoordinates then
begin
@ -6336,8 +6339,8 @@ begin
end else
begin
ALeft := X;
ATop := Y;
ARight := X + CX;
ATop := Y;
ABottom := Y + CY * ARenderInfo.Page.GetTopLeftCoords_Adjustment;
end;
end;
@ -8949,6 +8952,7 @@ begin
begin
lCurEntity := GetEntity(i);
lRenderInfo.Canvas := lBmp.Canvas;
lRenderInfo.Page := self;
lCurEntity.CalculateBoundingBox(lRenderInfo, lLeft, lTop, lRight, lBottom);
MinX := Min(MinX, lLeft);
MaxX := Max(MaxX, lRight);
@ -8963,8 +8967,18 @@ begin
end;
end;
lBmp.Free;
Width := abs(MaxX - MinX);
Height := abs(MaxY - MinY);
//Width := abs(MaxX - MinX);
//Height := abs(MaxY - MinY);
end;
function TvPage.RealWidth: Double;
begin
Result := abs(MaxX - MinX);
end;
function TvPage.RealHeight: Double;
begin
Result := abs(MaxY - MinY);
end;
procedure TvPage.AutoFit(ADest: TFPCustomCanvas; AWidth, AHeight, ARenderHeight: Integer;
@ -9137,7 +9151,7 @@ begin
FEntities := TFPList.Create;
FTmpPath := TPath.Create(Self);
Owner := AOwner;
FOwner := AOwner;
Clear();
BackgroundColor := colWhite;
RenderInfo.BackgroundColor := colWhite;

162
components/fpvectorial/tests/vtmain.lfm
View File

@ -1,36 +1,35 @@
object MainForm: TMainForm
Left = 324
Height = 690
Height = 717
Top = 125
Width = 900
Width = 905
Caption = 'Visual fpvectorial test'
ClientHeight = 690
ClientWidth = 900
ClientHeight = 717
ClientWidth = 905
OnCreate = FormCreate
OnDestroy = FormDestroy
ShowHint = True
LCLVersion = '2.3.0.0'
object GbTree: TGroupBox
Left = 4
Height = 682
Top = 4
Width = 344
Left = 8
Height = 701
Top = 8
Width = 336
Align = alClient
BorderSpacing.Around = 4
BorderSpacing.Around = 8
Caption = 'Test shapes and objects'
ClientHeight = 662
ClientWidth = 340
ClientHeight = 681
ClientWidth = 332
Font.Style = [fsBold]
ParentFont = False
TabOrder = 0
object Tree: TTreeView
Left = 4
Height = 650
Top = 4
Width = 332
Left = 6
Height = 669
Top = 6
Width = 320
Align = alClient
BorderSpacing.Bottom = 4
BorderSpacing.Around = 4
BorderSpacing.Around = 6
HideSelection = False
Images = ImageList
ParentFont = False
@ -46,48 +45,49 @@ object MainForm: TMainForm
end
object ScrollBox1: TScrollBox
Left = 352
Height = 690
Height = 717
Top = 0
Width = 548
HorzScrollBar.Increment = 54
HorzScrollBar.Page = 543
Width = 553
HorzScrollBar.Increment = 55
HorzScrollBar.Page = 553
HorzScrollBar.Smooth = True
HorzScrollBar.Tracking = True
VertScrollBar.Increment = 69
VertScrollBar.Page = 690
VertScrollBar.Page = 695
VertScrollBar.Smooth = True
VertScrollBar.Tracking = True
Align = alRight
BorderStyle = bsNone
ClientHeight = 690
ClientWidth = 548
ClientHeight = 717
ClientWidth = 553
TabOrder = 1
object AllTestsPanel: TPanel
Left = 4
Height = 682
Top = 4
Width = 536
Height = 683
Top = 8
Width = 537
Align = alTop
AutoSize = True
BorderSpacing.Right = 4
BorderSpacing.Top = 4
BorderSpacing.Right = 8
BorderSpacing.Around = 4
BevelOuter = bvNone
ClientHeight = 682
ClientWidth = 536
ClientHeight = 683
ClientWidth = 537
TabOrder = 0
object gbRenderTest: TGroupBox
AnchorSideLeft.Control = AllTestsPanel
AnchorSideBottom.Side = asrBottom
Left = 0
Height = 282
Height = 284
Top = 0
Width = 255
Width = 256
Anchors = [akTop, akLeft, akRight]
AutoSize = True
BorderSpacing.Right = 31
Caption = 'Render test'
ClientHeight = 262
ClientWidth = 251
ClientHeight = 264
ClientWidth = 252
Font.Style = [fsBold]
ParentFont = False
TabOrder = 0
@ -95,7 +95,7 @@ object MainForm: TMainForm
Left = 8
Height = 30
Top = 2
Width = 239
Width = 240
Align = alTop
BorderSpacing.Left = 8
BorderSpacing.Top = 2
@ -109,7 +109,7 @@ object MainForm: TMainForm
Left = 16
Height = 15
Top = 36
Width = 231
Width = 232
Align = alTop
BorderSpacing.Left = 16
BorderSpacing.Top = 4
@ -123,7 +123,7 @@ object MainForm: TMainForm
Left = 16
Height = 15
Top = 55
Width = 231
Width = 232
Align = alTop
BorderSpacing.Left = 16
BorderSpacing.Top = 4
@ -137,7 +137,7 @@ object MainForm: TMainForm
Left = 8
Height = 15
Top = 74
Width = 239
Width = 240
Align = alTop
BorderSpacing.Left = 8
BorderSpacing.Top = 4
@ -153,15 +153,15 @@ object MainForm: TMainForm
AnchorSideTop.Control = BtnSaveAsRef
AnchorSideTop.Side = asrBottom
AnchorSideBottom.Side = asrBottom
Left = 4
Left = 6
Height = 128
Top = 130
Width = 116
AutoSize = True
BorderSpacing.Left = 4
BorderSpacing.Left = 6
BorderSpacing.Top = 6
BorderSpacing.Right = 4
BorderSpacing.Bottom = 4
BorderSpacing.Right = 6
BorderSpacing.Bottom = 6
Caption = 'Origin at BOTTOM'
ClientHeight = 108
ClientWidth = 112
@ -176,7 +176,7 @@ object MainForm: TMainForm
Width = 100
BorderSpacing.Left = 6
BorderSpacing.Top = 2
BorderSpacing.Right = 4
BorderSpacing.Right = 6
BorderSpacing.Bottom = 6
OnPaint = PaintBoxPaint
end
@ -187,18 +187,18 @@ object MainForm: TMainForm
AnchorSideTop.Control = gbBottomLeft
AnchorSideBottom.Control = gbRenderTest
AnchorSideBottom.Side = asrBottom
Left = 128
Left = 130
Height = 128
Top = 130
Width = 114
Width = 116
Anchors = [akTop, akLeft, akBottom]
AutoSize = True
BorderSpacing.Left = 8
BorderSpacing.Right = 4
BorderSpacing.Bottom = 4
BorderSpacing.Right = 6
BorderSpacing.Bottom = 6
Caption = 'Origin at TOP'
ClientHeight = 108
ClientWidth = 110
ClientWidth = 112
ParentFont = False
TabOrder = 1
object TopLeftPaintbox: TPaintBox
@ -210,7 +210,7 @@ object MainForm: TMainForm
Width = 100
BorderSpacing.Left = 6
BorderSpacing.Top = 2
BorderSpacing.Right = 4
BorderSpacing.Right = 6
BorderSpacing.Bottom = 6
OnPaint = PaintBoxPaint
end
@ -240,13 +240,13 @@ object MainForm: TMainForm
AnchorSideRight.Side = asrBottom
AnchorSideBottom.Control = gbRenderTest
AnchorSideBottom.Side = asrBottom
Left = 286
Height = 282
Left = 287
Height = 284
Top = 0
Width = 250
Anchors = [akTop, akLeft, akRight, akBottom]
Caption = 'Reference image test'
ClientHeight = 262
ClientHeight = 264
ClientWidth = 246
Font.Style = [fsBold]
ParentFont = False
@ -299,15 +299,15 @@ object MainForm: TMainForm
AnchorSideTop.Side = asrBottom
AnchorSideBottom.Control = gbReferenceImageTest
AnchorSideBottom.Side = asrBottom
Left = 4
Left = 6
Height = 128
Top = 130
Width = 116
Anchors = [akLeft, akBottom]
AutoSize = True
BorderSpacing.Left = 4
BorderSpacing.Left = 6
BorderSpacing.Top = 8
BorderSpacing.Bottom = 4
BorderSpacing.Bottom = 6
Caption = 'Reference image'
ClientHeight = 108
ClientWidth = 112
@ -333,15 +333,15 @@ object MainForm: TMainForm
AnchorSideRight.Control = AllTestsPanel
AnchorSideRight.Side = asrBottom
Left = 0
Height = 313
Top = 298
Width = 536
Height = 312
Top = 300
Width = 537
Anchors = [akTop, akLeft, akRight]
AutoSize = True
BorderSpacing.Top = 16
Caption = 'Read/write test'
ClientHeight = 293
ClientWidth = 532
ClientHeight = 292
ClientWidth = 533
Font.Style = [fsBold]
ParentFont = False
TabOrder = 2
@ -349,7 +349,7 @@ object MainForm: TMainForm
Left = 8
Height = 15
Top = 2
Width = 516
Width = 517
Align = alTop
BorderSpacing.Left = 8
BorderSpacing.Top = 2
@ -363,7 +363,7 @@ object MainForm: TMainForm
Left = 8
Height = 45
Top = 72
Width = 516
Width = 517
Align = alTop
BorderSpacing.Left = 8
BorderSpacing.Top = 4
@ -377,17 +377,17 @@ object MainForm: TMainForm
AnchorSideLeft.Control = gbReadWriteTest
AnchorSideTop.Control = CbFileFormat
AnchorSideTop.Side = asrBottom
Left = 4
Height = 129
Left = 6
Height = 128
Top = 156
Width = 210
AutoSize = True
BorderSpacing.Left = 4
BorderSpacing.Left = 6
BorderSpacing.Top = 8
BorderSpacing.Right = 4
BorderSpacing.Right = 6
BorderSpacing.Bottom = 8
Caption = 'Written with origin at BOTTOM'
ClientHeight = 109
ClientHeight = 108
ClientWidth = 206
ParentFont = False
TabOrder = 0
@ -413,10 +413,10 @@ object MainForm: TMainForm
AnchorSideTop.Control = gbWRBottomLeft
Left = 6
Height = 100
Top = 3
Top = 2
Width = 100
BorderSpacing.Left = 6
BorderSpacing.Top = 3
BorderSpacing.Top = 2
BorderSpacing.Bottom = 6
OnPaint = PaintBoxPaint
end
@ -425,7 +425,7 @@ object MainForm: TMainForm
Left = 8
Height = 30
Top = 19
Width = 516
Width = 517
Align = alTop
BorderSpacing.Left = 8
BorderSpacing.Top = 2
@ -439,7 +439,7 @@ object MainForm: TMainForm
Left = 8
Height = 15
Top = 53
Width = 520
Width = 521
Align = alTop
BorderSpacing.Left = 8
BorderSpacing.Top = 4
@ -492,7 +492,7 @@ object MainForm: TMainForm
AnchorSideTop.Side = asrCenter
AnchorSideRight.Control = gbReadWriteTest
AnchorSideRight.Side = asrBottom
Left = 435
Left = 436
Height = 25
Top = 124
Width = 89
@ -511,8 +511,8 @@ object MainForm: TMainForm
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = CbFileFormat
AnchorSideTop.Side = asrBottom
Left = 222
Height = 129
Left = 224
Height = 128
Top = 156
Width = 213
AutoSize = True
@ -520,7 +520,7 @@ object MainForm: TMainForm
BorderSpacing.Top = 8
BorderSpacing.Bottom = 8
Caption = 'Written with origin at TOP'
ClientHeight = 109
ClientHeight = 108
ClientWidth = 209
ParentFont = False
TabOrder = 3
@ -531,7 +531,7 @@ object MainForm: TMainForm
AnchorSideTop.Side = asrCenter
Left = 114
Height = 25
Top = 41
Top = 40
Width = 91
AutoSize = True
BorderSpacing.Left = 8
@ -546,10 +546,10 @@ object MainForm: TMainForm
AnchorSideTop.Control = gbWRTopLeft
Left = 6
Height = 100
Top = 3
Top = 2
Width = 100
BorderSpacing.Left = 6
BorderSpacing.Top = 3
BorderSpacing.Top = 2
BorderSpacing.Bottom = 6
OnPaint = PaintBoxPaint
end
@ -563,14 +563,14 @@ object MainForm: TMainForm
AnchorSideRight.Side = asrBottom
Left = 0
Height = 55
Top = 627
Width = 536
Top = 628
Width = 537
Anchors = [akTop, akLeft, akRight]
AutoSize = True
BorderSpacing.Top = 16
Caption = 'Test results'
ClientHeight = 35
ClientWidth = 532
ClientWidth = 533
Font.Style = [fsBold]
ParentFont = False
TabOrder = 3

7
components/fpvectorial/tests/vtmain.pas
View File

@ -1190,7 +1190,12 @@ procedure TMainForm.TreeSelectionChanged(Sender: TObject);
begin
ShowRenderTestImages;
ShowRefImageTest;
ShowWriteReadTestImages;
try
ShowWriteReadTestImages;
except
on E:Exception do
MessageDlg(E.Message, mtError, [mbOK], 0);
end;
UpdateTestResults;
UpdateCmdStates;
end;

5
components/fpvectorial/wmfvectorialreader.pas
View File

@ -636,7 +636,10 @@ begin
FHasPlaceableMetaHeader := false;
n := AStream.Read(buf{%H-}, SizeOf(TPlaceableMetaHeader));
if n <> SizeOf(TPlaceableMetaHeader) then
raise Exception.Create('Error reading the wmf file header.');
begin
LogError('Error reading the wmf file header.');
exit;
end;
if placeableMetaHdr.Key = WMF_MAGIC_NUMBER then begin // yes!
FHasPlaceableMetaHeader := true;

44
components/fpvectorial/wmfvectorialwriter.pas
View File

@ -26,7 +26,7 @@ unit wmfvectorialwriter;
interface
uses
uses lazlogger,
Classes, SysUtils,
FPImage, FPCanvas,
fpvectorial, fpvWMF;
@ -55,6 +55,8 @@ type
FBBox: TRect; // in metafile units as specified by UnitsPerInch. NOTE: "logical" units can be different!
FLogicalMaxX: Word; // Max x coordinate used for scaling, in logical units
FLogicalMaxY: Word; // Max y coordinate used for scaling, in logical units
// FLogicalOffsetX: Word; // Position of zero in the range [0..LogicalMaxX]
// FLogicalOffsetY: Word;
FLogicalBounds: TRect; // Enclosing boundary rectangle in logical units
FScalingFactor: Double; // Conversion fpvectorial units to logical units
FMaxRecordSize: Int64;
@ -338,24 +340,37 @@ end;
procedure TvWMFVectorialWriter.PrepareScaling(APage: TvVectorialPage);
const
MAXINT16 = 32767;
MAXINT16 = 30000; // should be 32767, but avoid overflows...
var
maxx, maxy: Double;
w, h: Double;
begin
APage.CalculateDocumentSize;
w := Max(APage.Width, APage.RealWidth);
h := Max(APage.Height, APage.RealHeight);
FScalingFactor := round(ONE_INCH * 100); // 1 logical unit is 1/100 mm = 10 µm
maxx := APage.Width * FScalingFactor;
maxy := APage.Height * FScalingFactor;
maxx := w * FScalingFactor;
maxy := h * FScalingFactor;
// wmf is 16 bit only! --> reduce magnification if numbers get too big
if Max(maxx, maxy) > MAXINT16 then
begin
FScalingFactor := trunc(MAXINT16 / Max(APage.Width, APage.Height));
FLogicalMaxX := word(trunc(APage.Width * FScalingFactor));
FLogicalMaxY := word(trunc(APage.Height * FScalingFactor));
end else
begin
FLogicalMaxX := trunc(maxx);
FLogicalMaxY := trunc(maxy);
FScalingFactor := trunc(MAXINT16 / Max(w, h));
maxx := APage.Width * FScalingFactor;
maxy := APage.Height * FScalingFactor;
end;
FLogicalMaxX := trunc(maxx);
FLogicalMaxY := trunc(maxy);
(*
FLogicalOffsetX := 0;
FLogicalOffsetY := 0;
// Since the wmf coordinates are stored as word we must offset them in case
// of negative values.
if APage.MinX < 0 then
FLogicalOffsetX := word((trunc(-APage.MinX * FScalingFactor)));
if (APage.MinY < 0) then
FlogicalOffsetY := word((trunc(-APage.MinY * FScalingFactor)));
*)
end;
function TvWMFVectorialWriter.ScaleSizeX(x: Double): Integer;
@ -376,7 +391,8 @@ end;
function TvWMFVectorialWriter.ScaleY(y: Double): Integer;
begin
if FUseTopLeftCoordinates then
Result := ScaleSizeY(y) else
Result := ScaleSizeY(y)
else
Result := FLogicalMaxY - ScaleSizeY(y);
end;
@ -476,11 +492,13 @@ begin
end else
begin
rec.Top := c.y + r.y;
reC.Bottom := c.y - r.y;
rec.Bottom := c.y - r.y;
end;
UpdateBounds(rec.Left, rec.Top);
UpdateBounds(rec.Right, rec.Bottom);
DebugLn(['c.x=', c.x, ' cy=', c.y, ' r.x=', r.x, ' r.y=', r.y, ' rec.Left=', rec.Left, 'rec.Top=', rec.Top, ' c.x-r.x=', c.x-r.x, ' cy-r.y=', c.y - r.y]);
// WMF record header + parameters
WriteWMFRecord(AStream, META_ELLIPSE, rec, SizeOf(TWMFRectRecord));
end;