diff --git a/components/fpvectorial/fpvwmf.pas b/components/fpvectorial/fpvwmf.pas index 966ac16ebd..6dabd5a11b 100644 --- a/components/fpvectorial/fpvwmf.pas +++ b/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; diff --git a/components/fpvectorial/wmfvectorialreader.pas b/components/fpvectorial/wmfvectorialreader.pas index 0921d29b43..53476538b2 100644 --- a/components/fpvectorial/wmfvectorialreader.pas +++ b/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 := 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); diff --git a/components/fpvectorial/wmfvectorialwriter.pas b/components/fpvectorial/wmfvectorialwriter.pas index 8acb1f41af..0df5b08e69 100644 --- a/components/fpvectorial/wmfvectorialwriter.pas +++ b/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 - 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);