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

fpvectorial: Improved rendering of text in wmf.

Browse Source
This commit is contained in:
wp_xyz 2023-01-12 13:49:02 +01:00
parent d4d30d7e31
commit cbf86becca
3 changed files with 84 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
components/fpvectorial/fpvwmf.pas
View File

@ -148,7 +148,7 @@ type
TWMFExtTextRecord = packed record
Y: SmallInt;
X: SmallInt;
Len: SmallInt;
Len: SmallInt; // String length
Options: Word;
// Optional bounding rect and text follow
end;

70
components/fpvectorial/wmfvectorialreader.pas
View File

@ -9,7 +9,9 @@
- see the empty case items in "TWMFVectorialReader.ReadRecords"
Issues:
- Text often truncated, last character missing
- Text often truncated ( -- fixed)
- last character missing (-- fixed)
- Background color not applied
Author: Werner Pamler
}
@ -50,6 +52,7 @@ type
FCurrBrush: TvBrush;
FCurrFont: TvFont;
FCurrPalette: TFPPalette;
FCurrBkColor: TFPColor;
FCurrTextColor: TFPColor;
FCurrTextAlign: Word;
FCurrBkMode: Word;
@ -78,6 +81,7 @@ type
procedure ReadArc(APage: TvVectorialpage; const AParams: TParamArray);
procedure ReadBkColor(APage: TvVectorialPage; const AParams: TParamArray);
procedure ReadBkMode(APage: TvVectorialPage; const AValue: Word);
procedure ReadBkMode(APage: TvVectorialPage; const AParams: TParamArray);
procedure ReadChord(APage: TvVectorialpage; const AParams: TParamArray);
function ReadColor(const AParams: TParamArray; AIndex: Integer): TFPColor;
procedure ReadExtTextOut(APage: TvVectorialPage; const AParams: TParamArray);
@ -206,6 +210,7 @@ begin
Underline := false;
StrikeThrough := false;
end;
FCurrBkColor := colWhite;
FCurrTextColor := colBlack;
FCurrTextAlign := 0; // Left + Top
FCurrPolyFillMode := ALTERNATE;
@ -433,6 +438,7 @@ begin
TObject(obj).Free;
FObjList[idx] := nil;
// Do not delete from list because this will confuse the obj indexes.
// Only mark the deleted obj item as nil so that the index can be re-used.
end;
end;
@ -467,7 +473,7 @@ end;
procedure TvWMFVectorialReader.ReadBkColor(APage: TvVectorialPage;
const AParams: TParamArray);
begin
APage.BackgroundColor := ReadColor(AParams, 0);
FCurrBkColor := ReadColor(AParams, 0);
end;
procedure TvWMFVectorialReader.ReadBkMode(APage: TvVectorialPage;
@ -476,6 +482,12 @@ begin
FCurrBkMode := AValue;
end;
procedure TvWMFVectorialReader.ReadBkMode(APage: TvVectorialPage;
const AParams: TParamArray);
begin
ReadBkMode(APage, AParams[0]);
end;
procedure TvWMFVectorialReader.ReadChord(APage: TvVectorialPage;
const AParams: TParamArray);
var
@ -548,10 +560,9 @@ begin
angle := DegToRad(FCurrFont.Orientation);
case FCurrTextAlign and $0018 of
0:
offs := Point(0, 0); //Rotate2DPoint(Point(0, +FCurrRawFontHeight), Point(0, 0), angle);
offs := Point(0, 0); //Rotate2DPoint(Point(0, +FCurrRawFontHeight), Point(0, 0), angle); // wp --- the TA_BASELINE case seems to be correct, this one must be wrong...
TA_BASELINE:
// offs := Rotate2DPoint(Point(0, -FCurrRawFontHeight*6 div 5), Point(0, 0), angle);
offs := Rotate2DPoint(Point(0, +FCurrRawFontHeight), Point(0, 0), angle);
offs := Point(0, 0); // wp: was Rotate2DPoint(Point(0, +FCurrRawFontHeight), Point(0, 0), angle);
TA_BOTTOM:
offs := Rotate2DPoint(Point(0, -FCurrRawFontHeight*7 div 5), Point(0, 0), angle);
end;
@ -560,6 +571,7 @@ begin
txt := APage.AddText(ScaleX(x + offs.X), ScaleY(y + offs.Y), s);
// Select the font
txt.Font := FCurrFont;
txt.Font.Color := FCurrTextColor;
// Set horizontal text alignment.
case FCurrTextAlign and (TA_RIGHT or TA_CENTER) of
TA_RIGHT : txt.TextAnchor := vtaEnd;
@ -567,12 +579,15 @@ begin
else txt.TextAnchor := vtaStart;
end;
case FCurrBkMode of
BM_TRANSPARENT : txt.Brush.Style := bsClear;
BM_OPAQUE : txt.Brush.Style := bsSolid;
end;
// Opaque flag
if opts and ETO_OPAQUE <> 0 then
begin
txt.Brush.Style := bsSolid;
txt.Brush.Color := FCurrBkColor;
end
else
txt.Brush.Style := bsClear;
// to do: draw text background (if opts and ETO_OPAQUE <> 0 )
// to do: take care of clipping (if opts and ETO_CLIPPED <> 0)
end;
@ -947,7 +962,7 @@ begin
META_SETBKCOLOR:
ReadBkColor(page, params);
META_SETBKMODE:
;
ReadBkMode(page, params);
META_SETLAYOUT:
;
META_SETMAPMODE:
@ -1094,7 +1109,6 @@ var
rasterImg: TvRasterImage = nil;
memImg: TFPMemoryImage = nil;
dibRec: PWMFStretchDIBRecord;
hasCoreHdr: Boolean;
begin
dibRec := PWMFStretchDIBRecord(@AParams[0]);
memImg := TFPMemoryImage.Create(0, 0); //w, h);
@ -1178,18 +1192,11 @@ end;
function TvWMFVectorialReader.ReadString(const AParams: TParamArray;
AStartIndex, ALength: Integer): String;
var
s: ansistring;
i, j: Integer;
s: ansistring = '';
begin
SetLength(s, ALength);
i := AStartIndex;
j := 1;
while j < ALength do begin
Move(AParams[i], s[j], SIZE_OF_WORD);
inc(i);
inc(j, 2);
end;
if odd(ALength) then SetLength(s, ALength-1);
Move(AParams[AStartIndex], s[1], ALength);
// Note: ALength is the true string length. No need to remove the padding byte added to odd-length strings.
Result := ISO_8859_1ToUTF8(s);
end;
@ -1210,11 +1217,10 @@ var
s: String;
txt: TvText;
offs: TPoint;
txtHeight: Integer;
begin
{ Record layout:
word - String length
even number of bytes - String, no trailing zero
even number of bytes - String, no trailing zero, but padded to even length
smallInt - yStart
smallInt - xStart }
@ -1232,15 +1238,15 @@ begin
// TO DO: More testing of text positioning.
case FCurrTextAlign and $0018 of
0:
offs := Point(0, 0);
offs := Point(0, 0); // TA_BASELINE seems to be correct (2023-01-11) --> case 0 must be wrong...
TA_BASELINE:
offs := Rotate2DPoint(Point(0, FCurrRawFontHeight), Point(0, 0), DegToRad(FCurrFont.Orientation));
offs := Point(0, 0); //wp: was Rotate2DPoint(Point(0, FCurrRawFontHeight), Point(0, 0), DegToRad(FCurrFont.Orientation));
TA_BOTTOM:
offs := Rotate2DPoint(Point(0, -FCurrRawFontHeight*7 div 5), Point(0, 0), DegToRad(FCurrFont.Orientation));
end;
// Pass the text to fpvectorial
txt := APage.AddText(ScaleX(x + offs.x), ScaleY(y + offs.y), s);
txt := APage.AddText(ScaleX(x + offs.x), ScaleY(y - offs.y), s);
// Select the font
txt.Font := FCurrFont;
// Font color
@ -1252,10 +1258,12 @@ begin
else txt.TextAnchor := vtaStart;
end;
// Set background style
case FCurrBkMode of
BM_TRANSPARENT : txt.Brush.Style := bsClear;
BM_OPAQUE : txt.Brush.Style := bsSolid;
end;
if FCurrBkMode = BM_OPAQUE then
begin
txt.Brush.Style := bsSolid;
txt.Brush.Color := FCurrBkColor;
end else
txt.Brush.Style := bsClear;
end;
procedure TvWMFVectorialReader.ReadWindowExt(const AParams: TParamArray);

75
components/fpvectorial/wmfvectorialwriter.pas
View File

@ -7,8 +7,8 @@
Coordinates:
- wmf has y=0 at top, y grows downward (like with standard canvas).
- fpv has y=0 at bottom and y grows upwards if page.UseTopLeftCoordinates is
false or like wmf otherwise.
- fpv has y=0 at bottom and y grows upward if page.UseTopLeftCoordinates is
false, or like wmf otherwise.
Issues:
- Text background is opaque although it should be transparent.
@ -78,7 +78,7 @@ type
function ScaleSizeY(y: Double): Integer;
procedure UpdateBounds(x, y: Integer);
procedure WriteBkColor(AStream: TStream; APage: TvVectorialPage);
procedure WriteBkColor(AStream: TStream; AColor: TFPColor);
procedure WriteBkMode(AStream: TStream; AMode: Word);
procedure WriteBrush(AStream: TStream; ABrush: TvBrush);
procedure WriteCircle(AStream: TStream; ACircle: TvCircle);
@ -288,6 +288,7 @@ begin
Underline := false;
StrikeThrough := false;
end;
FCurrBkMode := BM_TRANSPARENT;
end;
destructor TvWMFVectorialWriter.Destroy;
@ -388,11 +389,11 @@ begin
FLogicalBounds.Bottom := Max(Y, FLogicalBounds.Bottom);
end;
procedure TvWMFVectorialWriter.WriteBkColor(AStream: TStream; APage: TvVectorialPage);
procedure TvWMFVectorialWriter.WriteBkColor(AStream: TStream; AColor: TFPColor);
var
rec: TWMFColorRecord;
begin
rec := MakeWMFColorRecord(APage.BackgroundColor);
rec := MakeWMFColorRecord(AColor);
WriteWMFRecord(AStream, META_SETBKCOLOR, rec, SizeOf(rec));
end;
@ -515,7 +516,7 @@ begin
else if AEntity is TvEllipse then
WriteEllipse(AStream, TvEllipse(AEntity))
else if AEntity is TvText then
WriteText(AStream, TvText(AEntity))
WriteExtText(AStream, TvText(AEntity))
else if AEntity is TPath then
WritePath(AStream, TPath(AEntity));
end;
@ -529,19 +530,27 @@ procedure TvWMFVectorialWriter.WriteExtText(AStream: TStream; AText: TvText);
var
s: String;
rec: TWMFExtTextRecord;
i, n: Integer;
i, n, strLen, corrLen: Integer;
P: TPoint;
offs: TPoint;
brush: TvBrush;
opts: Word;
begin
brush := AText.Brush;
opts := 0;
if brush.Style <> bsClear then
begin
opts := opts or ETO_OPAQUE;
WriteBkColor(AStream, brush.Color);
end;
(*
if (brush.Style = bsClear) and (FCurrBkMode = BM_OPAQUE) then
WriteBkMode(AStream, BM_TRANSPARENT)
else begin
if FCurrBkMode = BM_TRANSPARENT then
WriteBkMode(AStream, BM_OPAQUE);
WriteBrush(AStream, AText.Brush);
end;
end; *)
WriteFont(AStream, AText.Font);
@ -549,21 +558,23 @@ begin
WriteTextAnchor(AStream, AText.TextAnchor);
s := UTF8ToISO_8859_1(AText.Value.Text);
n := SizeOf(TWMFExtTextRecord) + Length(s);
if odd(n) then begin
inc(n);
strLen := Length(s);
corrLen := strLen;
if odd(corrLen) then begin
s := s + #0;
inc(corrLen);
end;
n := SizeOf(TWMFExtTextRecord) + corrLen;
rec.X := ScaleX(AText.X);
rec.Y := ScaleY(AText.Y);
// No vertical offset required because text alignment is TA_BASELINE.
rec.Options := 0; // no clipping, no background
rec.Len := UTF8Length(s);
rec.Options := opts; // no clipping so far
rec.Len := strLen; // true string length
WriteWMFRecord(AStream, META_EXTTEXTOUT, rec, n);
AStream.Position := AStream.Position - Length(s);
WriteWMFParams(AStream, s[1], Length(s));
AStream.Position := AStream.Position - corrLen;
WriteWMFParams(AStream, s[1], corrLen);
end;
procedure TvWMFVectorialWriter.WriteFont(AStream: TStream; AFont: TvFont);
@ -649,7 +660,7 @@ begin
WriteWindowExt(AStream);
WriteWindowOrg(AStream);
WriteMapMode(AStream);
WriteBkColor(AStream, APage);
WriteBkColor(AStream, APage.BackgroundColor);
WriteBkMode(AStream, BM_TRANSPARENT);
WriteTextAlign(AStream, TA_BASELINE or TA_LEFT);
@ -864,11 +875,9 @@ end;
procedure TvWMFVectorialWriter.WriteText(AStream: TStream; AText: TvText);
var
s: String;
n: Integer;
len: SmallInt;
rec: TWMFPointRecord;
offs: TPoint;
P: TPoint;
strLen, corrLen: SmallInt;
recSize: DWord;
ptRec: TWMFPointRecord;
brush: TvBrush;
begin
brush := AText.Brush;
@ -885,16 +894,20 @@ begin
if (AText.TextAnchor <> FCurrTextAnchor) then
WriteTextAnchor(AStream, AText.TextAnchor);
recSize := SizeOf(TWMFPointRecord);
s := UTF8ToISO_8859_1(AText.Value.Text);
len := Length(s);
if odd(len) then begin
strLen := Length(s);
corrLen := strLen;
if odd(corrLen) then
begin
s := s + #0;
inc(len);
inc(corrLen);
end;
inc(recSize, SizeOf(corrLen) + corrLen);
rec.X := ScaleX(AText.X);
rec.Y := ScaleY(AText.Y);
// No vertical font height offset required because text alignment is TA_BASELINE
ptRec.X := ScaleX(AText.X);
ptRec.Y := ScaleY(AText.Y);
// No vertical font height offset required because fpv uses text alignment TA_BASELINE
{ The record structure is
- TWMFRecord
@ -902,10 +915,10 @@ begin
- String, no trailing zero
- y
- x }
WriteWMFRecord(AStream, META_TEXTOUT, SizeOf(len) + len + SizeOf(TWMFPointRecord));
WriteWMFParams(AStream, len, SizeOf(len));
WriteWMFParams(AStream, s[1], Length(s));
WriteWMFParams(AStream, rec, SizeOf(rec));
WriteWMFRecord(AStream, META_TEXTOUT, recSize);
WriteWMFParams(AStream, strLen, SizeOf(strLen));
WriteWMFParams(AStream, s[1], corrLen);
WriteWMFParams(AStream, ptRec, SizeOf(TWMFPointRecord));
end;
procedure TvWMFVectorialWriter.WriteTextAlign(AStream: TStream; AAlign: word);