fpvectorial: Improved rendering of text in wmf.

components/fpvectorial/fpvwmf.pas

@@ -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;

components/fpvectorial/wmfvectorialreader.pas

@@ -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 := Point(0, 0);  // wp: was Rotate2DPoint(Point(0, +FCurrRawFontHeight), Point(0, 0), angle);
-      offs := 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
+  // Opaque flag
-    BM_TRANSPARENT : txt.Brush.Style := bsClear;
+  if opts and ETO_OPAQUE <> 0 then
-    BM_OPAQUE      : txt.Brush.Style := bsSolid;
+  begin
-  end;
+    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;
+  s: ansistring = '';
-  i, j: Integer;
 begin
   SetLength(s, ALength);
-  i := AStartIndex;
+  Move(AParams[AStartIndex], s[1], ALength);
-  j := 1;
+  // Note: ALength is the true string length. No need to remove the padding byte added to odd-length strings.
-  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);
   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
+  if FCurrBkMode = BM_OPAQUE then
-    BM_TRANSPARENT : txt.Brush.Style := bsClear;
+  begin
-    BM_OPAQUE      : txt.Brush.Style := bsSolid;
+    txt.Brush.Style := bsSolid;
-  end;
+    txt.Brush.Color := FCurrBkColor;
+  end else
+    txt.Brush.Style := bsClear;
 end;
 
 procedure TvWMFVectorialReader.ReadWindowExt(const AParams: TParamArray);

components/fpvectorial/wmfvectorialwriter.pas

@@ -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
+  - fpv has y=0 at bottom and y grows upward if page.UseTopLeftCoordinates is
-    false or like wmf otherwise.
+    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);
+  strLen := Length(s);
-  if odd(n) then begin
+  corrLen := strLen;
-    inc(n);
+  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.Options := opts;  // no clipping so far
-  rec.Len := UTF8Length(s);
+  rec.Len := strLen;    // true string length
 
   WriteWMFRecord(AStream, META_EXTTEXTOUT, rec, n);
-  AStream.Position := AStream.Position - Length(s);
+  AStream.Position := AStream.Position - corrLen;
-  WriteWMFParams(AStream, s[1], Length(s));
+  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;
+  strLen, corrLen: SmallInt;
-  len: SmallInt;
+  recSize: DWord;
-  rec: TWMFPointRecord;
+  ptRec: TWMFPointRecord;
-  offs: TPoint;
-  P: TPoint;
   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);
+  strLen := Length(s);
-  if odd(len) then begin
+  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);
+  ptRec.X := ScaleX(AText.X);
-  rec.Y := ScaleY(AText.Y);
+  ptRec.Y := ScaleY(AText.Y);
-  // No vertical font height offset required because text alignment is TA_BASELINE
+  // 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));
+  WriteWMFRecord(AStream, META_TEXTOUT, recSize);
-  WriteWMFParams(AStream, len, SizeOf(len));
+  WriteWMFParams(AStream, strLen, SizeOf(strLen));
-  WriteWMFParams(AStream, s[1], Length(s));
+  WriteWMFParams(AStream, s[1], corrLen);
-  WriteWMFParams(AStream, rec, SizeOf(rec));
+  WriteWMFParams(AStream, ptRec, SizeOf(TWMFPointRecord));
 end;
 
 procedure TvWMFVectorialWriter.WriteTextAlign(AStream: TStream; AAlign: word);