diff options
author | Graeme Geldenhuys <graeme@mastermaths.co.za> | 2009-11-27 16:11:31 +0200 |
---|---|---|
committer | Graeme Geldenhuys <graeme@mastermaths.co.za> | 2011-07-23 09:41:00 +0200 |
commit | eb30643705f18067e4e5374fa272c71a604403ab (patch) | |
tree | effab28fcd34bac5858d31c434aa124c39805da9 /docview/components/richtext | |
parent | 3ad5f0455a6e61d59968d40c63bd8579e51f0bfb (diff) | |
download | fpGUI-eb30643705f18067e4e5374fa272c71a604403ab.tar.xz |
Major refactoring in the CanvasFontManager unit. Work-in-Progress!
The CanvasFontManager unit has totally been reworked to use the native
TfpgFont class instead of TLogicalFont, TFontFace etc... The code is
a lot more simplified now and DocView can actually display content
but there are some width wrapping issues and AV's on changing topics.
This will be fixed next.
Diffstat (limited to 'docview/components/richtext')
-rw-r--r-- | docview/components/richtext/CanvasFontManager.pas | 966 | ||||
-rw-r--r-- | docview/components/richtext/RichTextDisplayUnit.pas | 19 | ||||
-rw-r--r-- | docview/components/richtext/RichTextLayoutUnit.pas | 53 | ||||
-rw-r--r-- | docview/components/richtext/RichTextStyleUnit.pas | 130 | ||||
-rw-r--r-- | docview/components/richtext/RichTextView.pas | 7 |
5 files changed, 184 insertions, 991 deletions
diff --git a/docview/components/richtext/CanvasFontManager.pas b/docview/components/richtext/CanvasFontManager.pas index 063f759b..7024f062 100644 --- a/docview/components/richtext/CanvasFontManager.pas +++ b/docview/components/richtext/CanvasFontManager.pas @@ -14,133 +14,54 @@ Uses Const // This defines the fraction of a pixel that // font character widths will be given in - FontWidthPrecisionFactor = 1; // 256 seems to be specific to OS/2 API DefaultTopicFontName = 'Arial'; - DefaultTopicFontSize = '10'; + DefaultTopicFontSize = 10; DefaultTopicFixedFontName = 'Courier New'; - DefaultTopicFixedFontSize = '10'; + DefaultTopicFixedFontSize = 10; DefaultTopicFont = DefaultTopicFontName + '-' + DefaultTopicFontSize; DefaultTopicFixedFont = DefaultTopicFixedFontName + '-' + DefaultTopicFixedFontSize; - -Type - {Standard Font types} - TFontType=(ftBitmap,ftOutline); - +type {Standard Font Attributes} - TFontAttributes=Set Of(faItalic,faUnderScore,faOutline,faStrikeOut,faBold); + TFontAttributes = set of (faBold, faItalic, faUnderScore, faOutline, faStrikeOut); {Standard Font pitches} TFontPitch=(fpFixed,fpProportional); - {Standard Font character Set} - TFontCharSet=(fcsSBCS,fcsDBCS,fcsMBCS); {Single,Double,mixed Byte} - - // a user-oriented specification of a font; not an actual structure in the INF file - TFontSpec = record - FaceName: string[ 64 ]; - PointSize: integer; // if 0 then use x/y size - XSize: integer; - YSize: integer; - Attributes: TFontAttributes; // set of faBold, faItalic etc - end; - - // NOTE: Char widths are in 1/FontWidthPrecisionFactor units - TCharWidthArray = array[ #0..#255 ] of longint; - TPCharWidthArray = ^TCharWidthArray; - - // Used internally for storing full info on font - TLogicalFont = class(TObject) - public - FaceName: string; // user-selected name - UseFaceName: string; // after substitutions. - - // Selected bits of FONTMETRICS - fsSelection: word; //USHORT; - - FontType: TFontType; - FixedWidth: boolean; - PointSize: integer; - ID: integer; - Attributes: TFontAttributes; - - // this can be nil if not already fetched - pCharWidthArray: TPCharWidthArray; - lMaxbaselineExt: longint; //LONG; - lAveCharWidth: longint; //LONG; - lMaxCharInc: longint; //LONG; - lMaxDescender: longint; //LONG; - public - constructor Create; - destructor Destroy; override; - end; - - - TFontFace = class(TObject) - public - Name: string; - FixedWidth: boolean; - FontType: TFontType; - Sizes: TList; // relevant for bitmap fonts only - contains TLogicalFont objects - constructor Create; - destructor Destroy; override; - end; - TCanvasFontManager = class(TObject) private FWidget: TfpgWidget; - protected FCanvas: TfpgCanvas; - FLogicalFonts: TList; - FCurrentFontSpec: TFontSpec; - FDefaultFontSpec: TFontSpec; - FCurrentFont: TLogicalFont; - FAllowBitmapFonts: boolean; - function CreateFont( const FontSpec: TFontSpec ): TLogicalFont; - function GetFont( const FontSpec: TFontSpec ): TLogicalFont; - procedure RegisterFont( Font: TLogicalFont ); - procedure SelectFont( Font: TLogicalFont; Scale: longint ); - // Retrieve character widths for current font - procedure LoadMetrics; - // load metrics if needed - procedure EnsureMetricsLoaded; + function GetCurrentFont: TfpgFont; + procedure SetDefaultFont(const AValue: TfpgFont); + protected + FDefaultFont: TfpgFont; public - constructor Create(Canvas: TfpgCanvas; AllowBitmapFonts: boolean; AWidget: TfpgWidget); reintroduce; + constructor Create(ACanvas: TfpgCanvas; AWidget: TfpgWidget); reintroduce; destructor Destroy; override; - // Set the font for the associated canvas. - procedure SetFont( const FontSpec: TFontSpec ); - // Retrieve the width of the given char, in the current font - function CharWidth( const C: Char ): longint; function AverageCharWidth: longint; - function MaximumCharWidth: longint; - function IsFixed: boolean; - function CharHeight: longint; function CharDescender: longint; + function CharHeight: longint; + function CharWidth( const C: Char ): longint; // Retrieve the width of the given char, in the current font + function IsFixed: boolean; + function MaximumCharWidth: longint; procedure DrawString(var Point: TPoint; const Length: longint; const S: PChar); + procedure SetFont(const AFontDesc: TfpgString); property Canvas: TfpgCanvas read FCanvas; + property CurrentFont: TfpgFont read GetCurrentFont; + property DefaultFont: TfpgFont read FDefaultFont write SetDefaultFont; property Widget: TfpgWidget read FWidget; - property DefaultFontSpec: TFontSpec read FDefaultFontSpec write FDefaultFontSpec; end; -// Convert a Sibyl font to a FontSpec (Color is left the same) -procedure FPGuiFontToFontSpec( Font: TfpgFont; Var FontSpec: TFontSpec ); - - // Thoughts on how it works.... +// Get the font attributes of a fpGUI font +function GetFPGuiFontAttributes(const AFont: TfpgFont): TFontAttributes; +function GetFPGuiFont(const AFontNameSize: string; const Attrs: TFontAttributes): TfpgFont; +procedure ApplyFontAttributes(var AFontDesc: string; const Attrs: TFontAttributes); - // SelectFont looks for an existing logical font that - // matches the request. If found selects that logical font - // onto the canvas. - - // If not found it creates a logical font and selects that onto - // the canvas. - - // For bitmap fonts the logical font definition includes pointsize - // For outline fonts the defn is only face+attr; in this case - // selectfont also ses the 'CharBox' according to the point size. implementation @@ -153,53 +74,7 @@ uses ; -var - FontFaces: TList = nil; // of TFontface - DefaultOutlineFixedFace: TFontFace; - DefaultOutlineProportionalFace: TFontFace; - -// TFontFace -//------------------------------------------------------------------------ - -constructor TFontface.Create; -begin - Sizes := TList.Create; - FontType := ftOutline; // in fpGUI we treat all fonts as scalable (preference) -end; - -destructor TFontface.Destroy; -begin - Sizes.Free; -end; - -// TLogicalFont -//------------------------------------------------------------------------ - -constructor TLogicalFont.Create; -begin - FontType := ftOutline; - PointSize := 10; - Attributes := []; - FixedWidth := False; - UseFaceName := ''; - FaceName := ''; -end; - -// frees allocated memory, if any. -// Note - does not delete the Gpi Logical Font -destructor TLogicalFont.Destroy; -begin - if pCharWidthArray <> nil then - FreeMem( pCharWidthArray, - sizeof( TCharWidthArray ) ); - - inherited Destroy; -end; - - -// Convert a fpGUI Toolkit font to a FontSpec -//------------------------------------------------------------------------ -procedure FPGuiFontToFontSpec( Font: TfpgFont; Var FontSpec: TFontSpec ); +function GetFPGuiFontAttributes(const AFont: TfpgFont): TFontAttributes; var s: string; facename: string; @@ -207,15 +82,16 @@ var c: char; token: string; prop, propval: string; - desc: string; + lDesc: string; + lFontSize: integer; function NextC: char; begin Inc(cp); - if cp > length(desc) then + if cp > length(lDesc) then c := #0 else - c := desc[cp]; + c := lDesc[cp]; Result := c; end; @@ -230,22 +106,20 @@ var end; begin + Result := []; cp := 0; - desc := Font.FontDesc; + lDesc := AFont.FontDesc; + // find fontface NextC; NextToken; - FontSpec.FaceName := token; - FontSpec.Attributes := []; - FontSpec.XSize := Font.TextWidth('v'); - FontSpec.YSize := Font.Height; // find font size if c = '-' then begin NextC; NextToken; - FontSpec.PointSize := StrToIntDef(token, 10); + lFontSize := StrToIntDef(token, DefaultTopicFontSize); end; // find font attributes @@ -255,207 +129,60 @@ begin NextToken; prop := UpperCase(token); propval := ''; - if c = '=' then begin NextC; NextToken; propval := UpperCase(token); end; - // convert fontdesc attributes to fontspec attributes + // convert fontdesc attributes to standard font attributes if prop = 'BOLD' then - include(FontSpec.Attributes, faBold) + include(Result, faBold) else if prop = 'ITALIC' then - include(FontSpec.Attributes, faItalic) + include(Result, faItalic) else if prop = 'UNDERLINE' then - include(FontSpec.Attributes, faUnderScore) - end; -end; - -// Find a font face with the given name -//------------------------------------------------------------------------ -function FindFaceName( const name: string ): TFontFace; -Var - FaceIndex: LongInt; - Face: TFontFace; -begin - for FaceIndex := 0 to FontFaces.Count - 1 do - begin - Face := TFontFace(FontFaces[ FaceIndex ]); - - if pos(UpperCase(name), UpperCase(Face.Name)) > 0 then - begin - Result := Face; - exit; - end; - end; - Result := nil; -end; - -// Return the first font face of type = Outline (scalable) -//------------------------------------------------------------------------ -function GetFirstOutlineFace( FixedWidth: boolean ): TFontFace; -Var - FaceIndex: LongInt; - Face: TFontFace; -begin - for FaceIndex := 0 to FontFaces.Count - 1 do - begin - Face := TFontFace(FontFaces[ FaceIndex ]); - - if ( Face.FixedWidth = FixedWidth ) - and ( Face.FontType = ftOutline ) then - begin - Result := Face; - exit; - end; + include(Result, faUnderScore) + else if prop = 'OUTLINE' then + include(Result, faOutline) + else if prop = 'STRIKEOUT' then + include(Result, faStrikeOut) end; - Result := nil; end; -// Find the bitmap font which best matches the given pointsize. -//------------------------------------------------------------------------ -function GetClosestBitmapFixedFont( const PointSize: longint ): TLogicalFont; -Var - FaceIndex: Longint; - FontIndex: longint; - Face: TFontFace; - Font: TLogicalFont; -begin - Result := nil; - for FaceIndex := 0 to FontFaces.Count - 1 do - begin - Face := TFontFace(FontFaces[ FaceIndex ]); - - if Face.FontType = ftBitmap then - begin - for FontIndex := 0 to Face.Sizes.Count - 1 do - begin - Font := TLogicalFont(Face.Sizes[ FontIndex ]); - if Font.FixedWidth then - begin - if ( Result = nil ) - or ( Abs( Font.PointSize - PointSize ) - < Abs( Result.PointSize - PointSize ) ) then - Result := Font; - end; - end; - end; - end; -end; - -// Pick some nice default fonts. -//------------------------------------------------------------------------ -procedure GetDefaultFonts; +function GetFPGuiFont(const AFontNameSize: string; const Attrs: TFontAttributes): TfpgFont; +var + s: string; begin - // courier new is common and reasonably nice - DefaultOutlineFixedFace := FindFaceName( DefaultTopicFixedFontName ); - if DefaultOutlineFixedFace = nil then - begin - DefaultOutlineFixedFace := GetFirstOutlineFace( true ); // first fixed outline face - end; - - DefaultOutlineProportionalFace := FindFaceName( DefaultTopicFontName ); - if DefaultOutlineProportionalFace = nil then - begin - DefaultOutlineProportionalFace := GetFirstOutlineFace( false ); // first prop outline face - end; + s := AFontNameSize; + ApplyFontAttributes(s, Attrs); + Result := fpgGetFont(s); end; -// Fetch the global list of font faces and sizes -//------------------------------------------------------------------------ -procedure GetFontList; -Var - Count: LongInt; - T: LongInt; - Font: TLogicalFont; - Face: TFontFace; - FamilyName: string; - fl: TStringList; - f: TfpgFont; +// Add attributes to font name +procedure ApplyFontAttributes(var AFontDesc: string; const Attrs: TFontAttributes); begin - fl := nil; - FontFaces := TList.Create; - fl := fpgApplication.GetFontFaceList; + if faItalic in Attrs then + if Pos(':Italic', AFontDesc) = 0 then + AFontDesc := AFontDesc + ':Italic'; - // Get font count - Count := fl.Count; - If Count > 0 Then - Begin - For T := 0 To Count - 1 Do - Begin - Font := TLogicalFont.Create; - Font.FaceName := fl[T]; - f := fpgGetFont(Font.FaceName + '-10'); - if (pos('COURIER', UpperCase(Font.FaceName)) > 0) or (pos('MONO', UpperCase(Font.FaceName)) > 0) then - Font.FixedWidth := True; - Font.lAveCharWidth := f.TextWidth('g'); - Font.lMaxbaselineExt := f.Height; - //Font.fsSelection := pfm^[ T ].fsSelection; - //Font.lMaxbaselineExt := pfm^[ T ].lMaxbaselineExt; - //Font.lAveCharWidth := pfm^[ T ].lAveCharWidth; - //Font.lMaxCharInc := pfm^[ T ].lMaxCharInc; - Font.ID := -1; // and always shall be so... - f.Free; + if faBold in Attrs then + if Pos(':Bold', AFontDesc) = 0 then + AFontDesc := AFontDesc + ':Bold'; - Face := FindFaceName( Font.FaceName ); - if Face = nil then - begin - // new face found - Face := TFontFace.Create; - Face.Name := Font.FaceName; // point to the actual face name string! - Face.FixedWidth := Font.FixedWidth; - Face.FontType := Font.FontType; - FontFaces.Add( Face ); - end; - Face.Sizes.Add( Font ); - End; - End; + if faOutline in Attrs Then + if Pos(':Outline', AFontDesc) = 0 then + AFontDesc := AFontDesc + ':Outline'; - fl.Free; - // pick some for defaults - GetDefaultFonts; -end; - -// Add .subscript to font name for attributes -//------------------------------------------------------------------------ -Function ModifyFontName( const FontName: string; - const Attrs: TFontAttributes ): String; -Begin - Result := FontName; - If faItalic in Attrs Then - Result := Result + '.Italic'; - If faBold in Attrs Then - Result := Result + '.Bold'; - If faOutline in Attrs Then - Result := Result + '.Outline'; - If faStrikeOut in Attrs Then - Result := Result + '.Strikeout'; - If faUnderScore in Attrs Then - Result := Result + '.Underscore'; -End; + if faStrikeOut in Attrs Then + if Pos(':Strikeout', AFontDesc) = 0 then + AFontDesc := AFontDesc + ':Strikeout'; -// Create a font without attributes -//------------------------------------------------------------------------ -function CreateFontBasic( const FaceName: string; const PointSize: integer ): TLogicalFont; -var - PPString: string; -begin - Result := TLogicalFont.Create; - if FindFaceName( FaceName ) = nil then - Exit; //==> - Result.PointSize := PointSize; // will use later if the result was an outline font... - Result.FaceName := FaceName; - - // OK now we have found the font face... - PPString := IntToStr( PointSize) + '.' + FaceName; - - PPString := ModifyFontName( PPString, [] ); + if faUnderScore in Attrs Then + if Pos(':Underscore', AFontDesc) = 0 then + AFontDesc := AFontDesc + ':Underscore'; end; -// Provide outline substitutes for some common bitmap fonts -// From Mozilla/2 source. -//------------------------------------------------------------------------ +// Provide font name substitutes for some common bitmap fonts found in INF files function SubstituteBitmapFontToOutline( const FaceName: string ): string; begin if StringsSame( FaceName, 'Helv' ) then @@ -474,597 +201,105 @@ begin result := FaceName; // no substitution end; -// Ask OS/2 dummy font window to convert a font spec -// into a FONTMETRICS. -//------------------------------------------------------------------------ -//procedure AskOS2FontDetails( const FaceName: string; -// const PointSize: longint; -// const Attributes: TFontAttributes; -// var FontInfo: FONTMETRICS ); -//var -// PPString: string; -// PresSpace: HPS; -//begin -// // Hack from Sibyl code - we don't know WTF the algorithm is -// // for selecting between outline/bitmap and doing substitutions -// // so send it to a dummy window and find out the resulting details -// PPString := IntToStr( PointSize ) -// + '.' -// + FaceName; -// -// PPString := ModifyFontName( PPString, Attributes ); -// -// FontWindow.SetPPFontNameSize( PPString ); -// -// PresSpace := WinGetPS( FontWindow.Handle ); -// GpiQueryFontMetrics( PresSpace, -// SizeOf( FontInfo ), -// FontInfo ); -// WinReleasePS( PresSpace ); -//end; - // Look for the best match for the given face, size and attributes. // If FixedWidth is set then makes sure that the result is fixed -// (if there is any fixed font on the system at all!) -// This uses the OS/2 GPI and therefore makes some substitutions, -// such as Helv 8 (bitmap) for Helvetica 8 (outline) -//------------------------------------------------------------------------ -procedure FindBestFontMatch( const FaceName: string; - const PointSize: longint; - const Attributes: TFontAttributes; - const FixedWidth: boolean; - var FontInfo: string ); +procedure FindBestFontMatch( const FaceName: string; const PointSize: longint; + const Attributes: TFontAttributes; const FixedWidth: boolean; var FontDesc: string ); var - BestBitmapFontMatch: TLogicalFont; - fl: TStringList; + sl: TStringList; i: integer; begin - { TODO -oGraeme -cfonts : This hack is very quick and dirty. Needs to be refined a lot } - fl := fpgApplication.GetFontFaceList; - for i := 0 to fl.Count-1 do + FontDesc := ''; + sl := fpgApplication.GetFontFaceList; + for i := 0 to sl.Count-1 do begin - if Pos(FaceName, fl[i]) > 0 then - FontInfo := fl[i] + '-' + IntToStr(PointSize); + if Pos(FaceName, sl[i]) > 0 then + FontDesc := sl[i] + '-' + IntToStr(PointSize); end; - if Fontinfo = '' then - // nothing found so use default font of fpGUI - FontInfo := fpgApplication.DefaultFont.FontDesc; + ApplyFontAttributes(FontDesc, Attributes); + + // if nothing found, use default font of fpGUI + if FontDesc = '' then + FontDesc := fpgApplication.DefaultFont.FontDesc; end; -//------------------------------------------------------------------------ -// Font manager -//------------------------------------------------------------------------ -// constructor -//------------------------------------------------------------------------ -constructor TCanvasFontManager.Create(Canvas: TfpgCanvas; AllowBitmapFonts: boolean; - AWidget: TfpgWidget); +{ TCanvasFontManager } + +constructor TCanvasFontManager.Create(ACanvas: TfpgCanvas; AWidget: TfpgWidget); begin inherited Create; - if FontFaces = nil then - GetFontList; - FCanvas := Canvas; + FCanvas := ACanvas; FWidget := AWidget; - FLogicalFonts := TList.Create; - - // get system default font spec - // as default default ;) - FPGuiFontToFontSpec( fpgApplication.DefaultFont, FDefaultFontSpec ); - if FDefaultFontSpec.FaceName = '' then - raise Exception.Create('For some reason we could not create a FDefaultFontSpec instance'); - - // FCurrentFontSpec.FaceName := 'Arial'; - FCurrentFontSpec.FaceName := FDefaultFontSpec.FaceName; - FCurrentFont := nil; - FAllowBitmapFonts := AllowBitmapFonts; + FDefaultFont := fpgGetFont(Format('%s-%d', [DefaultTopicFont, DefaultTopicFontSize])); + FCanvas.Font := FDefaultFont; end; -// Destructor -//------------------------------------------------------------------------ destructor TCanvasFontManager.Destroy; -var - i: integer; - lFont: TLogicalFont; - lface: TFontFace; begin - // select default font so none of our logical fonts are in use FCanvas.Font := fpgApplication.DefaultFont; - - // delete each logical font and our record of it - for i := FLogicalFonts.Count-1 downto 0 do - begin - // TODO: This must be fixed. If we don't use try..except we sometimes get AV's on lFont.Free - // TODO: TLogicalFont must be totally removed from DocView. - try - lFont := TLogicalFont(FLogicalFonts[i]); - lFont.Free; - except - // do nothing - end; - end; - FLogicalFonts.Clear; - FLogicalFonts.Free; - - // TCanvasFontManager asked for FontFaces to be created, so lets take responsibility to destroy it. - for i := 0 to FontFaces.Count-1 do - begin - lface := TFontFace(Fontfaces[i]); - lface.Free; - end; - FontFaces.Clear; - FontFaces.Free; + FDefaultFont.Free; inherited Destroy; end; -// Create a logical font for the given spec -//------------------------------------------------------------------------ -function TCanvasFontManager.CreateFont( const FontSpec: TFontSpec ): TLogicalFont; -var - UseFaceName: string; - Face: TFontFace; - RemoveBoldFromSelection: boolean; - RemoveItalicFromSelection: boolean; - UseAttributes: TFontAttributes; - MatchAttributes: TFontAttributes; - BaseFont: TLogicalFont; - BaseFontIsBitmapFont: Boolean; - FontInfo: string; - FixedWidth: boolean; +procedure TCanvasFontManager.SetDefaultFont(const AValue: TfpgFont); begin -ProfileEvent('>>>> TCanvasFontManager.CreateFont >>>>'); - Face := nil; - RemoveBoldFromSelection := false; - RemoveItalicFromSelection := false; - - UseAttributes := FontSpec.Attributes; - - // see if the originally specified font is a fixed width one. - FixedWidth := false; - Face := FindFaceName( FontSpec.FaceName ); - if Face <> nil then - FixedWidth := Face.FixedWidth; - - Face := nil; - - if not FAllowBitmapFonts then - UseFaceName := SubstituteBitmapFontToOutline( FontSpec.FaceName ) - else - UseFaceName := FontSpec.FaceName; -ProfileEvent('UseFaceName=' + UseFaceName); - - if FontSpec.Attributes <> [] then - begin -profileevent('FontSpec.Attributes are not blank'); - BaseFontIsBitmapFont := false; - if FAllowBitmapFonts then - begin - // First see if the base font (without attributes) - // would be a bitmap font... - BaseFont := CreateFontBasic( UseFaceName, FontSpec.PointSize ); - if BaseFont <> nil then - begin - BaseFontIsBitmapFont := BaseFont.FontType = ftBitmap; - BaseFont.Destroy; - end; - end; - - If not BaseFontIsBitmapFont Then - begin -profileevent('we seem to be looking for a outline font'); - // Result is an outline font so look for specific bold/italic fonts - if ( faBold in FontSpec.Attributes ) - and ( faItalic in FontSpec.Attributes ) then - begin - Face := FindFaceName( UseFaceName + ' BOLD ITALIC' ); - if Face <> nil then - begin - Exclude( UseAttributes, faBold ); - Exclude( UseAttributes, faItalic ); - RemoveBoldFromSelection := true; - RemoveItalicFromSelection := true; - end; - end; - - if Face = nil then - if faBold in FontSpec.Attributes then - begin - Face := FindFaceName( UseFaceName + ' BOLD' ); - if Face <> nil then - begin - Exclude( UseAttributes, faBold ); - RemoveBoldFromSelection := true; - end; - end; - - if Face = nil then - if faItalic in FontSpec.Attributes then - begin - Face := FindFaceName( UseFaceName + ' ITALIC' ); - if Face <> nil then - begin - Exclude( UseAttributes, faItalic ); - RemoveItalicFromSelection := true; - end; - end; - end; - end; - - if Face <> nil then - // found a styled face, does it match fixed width? - if Face.FixedWidth <> FixedWidth then - // no so we don't want to use it. - Face := nil; - - if Face = nil then - // didn't find a styled face (or no styles set) - // so find unmodified, we will use simulation bits - Face := FindFaceName( UseFaceName ); - - // Oh shit! - if Face = nil then - // didn't find a styled face (or no styles set) - // so find unmodified, we will use simulation bits - Face := FindFaceName( 'Sans' ); // something very generic - - if not FAllowBitmapFonts then - if Assigned(Face) and (Face.FontType = ftBitmap) then - // we aren't allowed bitmaps, but that's what this - // face is. So use the default outline face of the - // appropriate width type - if FixedWidth then - Face := DefaultOutlineFixedFace - else - Face := DefaultOutlineProportionalFace; - - if Face = nil then - begin -profileevent('Could not find the specified font name. Bummer! + early exit'); - // Could not find the specified font name. Bummer. - Result := nil; + if FDefaultFont = AValue then exit; - end; - -profileevent('******* Now create the TLogicalFont instance'); - // OK now we have found the font face... - Result := TLogicalFont.Create; - Result.PointSize := FontSpec.PointSize; // will use later if the result was an outline font... - Result.FaceName := FontSpec.FaceName; - Result.UseFaceName := Face.Name; - Result.Attributes := FontSpec.Attributes; - Result.fsSelection := 0; - Result.FixedWidth := Face.FixedWidth; - - if FAllowBitmapFonts then - begin - if BaseFontIsBitmapFont then - MatchAttributes := [] - else - MatchAttributes := UseAttributes; - FindBestFontMatch( Face.Name, - FontSpec.PointSize, - MatchAttributes, - FixedWidth, - FontInfo ); - - Result.UseFaceName := FontInfo; - end - else - begin - // no bitmap fonts please. - Result.FontType := ftOutline - end; - - // store the baseline and average char width. - // For bitmap fonts, these tell GPI which font we really want - // For outline fonts, we are just storing them for later ref. - //Result.lMaxbaseLineExt := FontInfo.lMaxbaselineExt; - //Result.lAveCharWidth := FontInfo.lAveCharWidth; - //Result.lMaxCharInc := FontInfo.lMaxCharInc; - Result.lMaxBaseLineExt := FontSpec.YSize; - Result.lAveCharWidth := FontSpec.XSize; - Result.lMaxCharInc := FontSpec.XSize; - - // Set style flags - with Result do - begin - //If faBold in UseAttributes Then - // fsSelection := fsSelection or FM_SEL_BOLD; - //If faItalic in UseAttributes Then - // fsSelection := fsSelection or FM_SEL_ITALIC; - //If faUnderScore in UseAttributes Then - // fsSelection := fsSelection or FM_SEl_UNDERSCORE; - //If faStrikeOut in UseAttributes Then - // fsSelection := fsSelection or FM_SEl_STRIKEOUT; - //If faOutline in UseAttributes Then - // fsSelection := fsSelection or FM_SEl_OUTlINE; - end; - -profileevent(' Result.FaceName=' + Result.FaceName); -profileevent(' Result.PointSize=' + IntToStr(Result.PointSize)); -profileevent(' Result.UseFaceName=' + Result.UseFaceName); - - Result.pCharWidthArray := Nil; - ProfileEvent('<<<< TCanvasFontManager.CreateFont'); + FDefaultFont.Free; + FDefaultFont := AValue; end; -// Register the given logical font with GPI and store for later use -//------------------------------------------------------------------------ -procedure TCanvasFontManager.RegisterFont( Font: TLogicalFont ); -var -// fa: FATTRS; - rc: longint; +function TCanvasFontManager.GetCurrentFont: TfpgFont; begin - FLogicalFonts.Add( Font ); - Font.ID := FLogicalFonts.Count + 1; // add 1 to stay out of Sibyl's way - - //// Initialise GPI font attributes - //FillChar( fa, SizeOf( FATTRS ), 0 ); - //fa.usRecordLength := SizeOf( FATTRS ); - // - //// Copy facename and 'simulation' attributes from what we obtained - //// earlier - //fa.szFaceName := Font.pUseFaceName^; - //fa.fsSelection := Font.fsSelection; - // - //fa.lMatch := 0; // please Mr GPI be helpful and do clever stuff for us, we are ignorant - // - //fa.idRegistry := 0; // IBM magic number - //fa.usCodePage := 0; // use current codepage - // - //If Font.FontType = ftOutline then - // // Outline font wanted - // fa.fsFontUse := FATTR_FONTUSE_OUTLINE Or FATTR_FONTUSE_TRANSFORMABLE - //else - // // bitmap font - // fa.fsFontUse := 0; - // - //// don't need mixing with graphics (for now) - //fa.fsFontUse := fa.fsFontUse or FATTR_FONTUSE_NOMIX; - // - //// copy char cell width/height from the (valid) one we - //// found earlier in GetFont (will be zero for outline) - //fa.lMaxbaseLineExt := Font.lMaxbaselineExt; - //fa.lAveCharWidth := Font.lAveCharWidth; - // - //fa.fsType := 0; - // - //// create logical font - //rc := GpiCreateLogFont( FCanvas.Handle, - // nil, - // Font.ID, - // fa ); -end; - -// Select the given (existing) logical font -//------------------------------------------------------------------------ -procedure TCanvasFontManager.SelectFont( Font: TLogicalFont; - Scale: longint ); -var - f: TfpgFont; - s: string; -begin - // Select the logical font - s := Font.FaceName + '-' + IntToStr(Font.PointSize); - if faBold in Font.Attributes then - s := s + ':bold'; - if faItalic in Font.Attributes then - s := s + ':italic'; - if faUnderScore in Font.Attributes then - s := s + ':underline'; - - f := fpgGetFont(s); - FCanvas.Font := f; -end; - -// Get a font to match the given spec, creating or re-using an -// existing font as needed. -//------------------------------------------------------------------------ -function TCanvasFontManager.GetFont( const FontSpec: TFontSpec ): TLogicalFont; -var - AFont: TLogicalFont; - FontIndex: integer; - sub: string; -begin -ProfileEvent('DEBUG: TCanvasFontManager.GetFont >>>'); -ProfileEvent('Received FontSpec: Facename=' + FontSpec.FaceName); -ProfileEvent(' PointSize=' + IntToStr(FontSpec.PointSize)); -ProfileEvent('FLogicalFonts.Count=' + intToStr(FLogicalFonts.Count)); -try - for FontIndex := 0 to FLogicalFonts.Count - 1 do - begin - AFont := TLogicalFont(FLogicalFonts[ FontIndex ]); - if AFont.PointSize = FontSpec.PointSize then - begin - if ( AFont.PointSize > 0 ) - or ( ( AFont.lAveCharWidth = FontSpec.XSize ) - and ( AFont.lMaxbaselineExt = FontSpec.YSize ) ) then - begin - if AFont.Attributes = FontSpec.Attributes then - begin - // search name last since it's the slowest thing -//ProfileEvent(' AFont.UseFaceName=' + AFont.UseFaceName); -//ProfileEvent(' FontSpec.FaceName=' + FontSpec.FaceName); - if AFont.FaceName = FontSpec.FaceName then - begin - // Found a logical font already created - Result := AFont; - // done - exit; - end - else - begin - // Still nothing! Lets try known substitute font names - sub := SubstituteBitmapFontToOutline(FontSpec.FaceName); -ProfileEvent(' substitute font=' + sub); - if AFont.FaceName = sub then - begin - // Found a logical font already created - Result := AFont; - // done - profileevent('TCanvasFontManager.GetFont <<<<< exit early we found a font'); - exit; - end; - end; - end; - end; - end; - end; -except - { TODO -oGraeme -cknow bug : An Access Violation error occurs often here! No idea why? } - on E: Exception do - ProfileEvent('Unexpected error occured. Error: ' + E.Message); -end; - - ProfileEvent('Now we need to create a new logical font'); - // Need to create new logical font - Result := CreateFont( FontSpec ); - if Result <> nil then - begin - RegisterFont( Result ); - end; -ProfileEvent('DEBUG: TCanvasFontManager.GetFont <<<'); + Result := FCanvas.Font as TfpgFont; end; // Set the current font for the canvas to match the given // spec, creating or re-using fonts as needed. -//------------------------------------------------------------------------ -procedure TCanvasFontManager.SetFont( const FontSpec: TFontSpec ); -var - Font: TLogicalFont; - lDefaultFontSpec: TFontSpec; +procedure TCanvasFontManager.SetFont(const AFontDesc: TfpgString); begin -ProfileEvent('DEBUG: TCanvasFontManager.SetFont >>>>'); - // we don't need this any more, because we check FCurrentFont <> Font further down - // We also make sure we always set Canvas.Font - this fixes large display of Grids or Sample Code in Courier New font - //if (FCurrentFontSpec.FaceName = FontSpec.FaceName) and - // (FCurrentFontSpec.PointSize = FontSpec.PointSize) and - // (FCurrentFontSpec.Attributes = FontSpec.Attributes) then - // //same font - //begin - // exit; - //end; + if FCanvas.Font.FontDesc = AFontDesc then + Exit; // nothing to do so exit - Font := GetFont( FontSpec ); - - if Font = nil then + if FDefaultFont.FontDesc = AFontDesc then begin - // ack! Pfffbt! Couldn't find the font. - - // Try to get the default font - //writeln('---------- here goes nothing -------------'); - Font := GetFont( FDefaultFontSpec ); - if Font = nil then - begin - writeln('******* We should never get here!!!! Defaut font should always exist.'); - writeln('FDefaultFontSpec:'); - writeln(' FaceName=', FDefaultFontSpec.FaceName); - writeln(' Size=', FDefaultFontSpec.PointSize); - FPGuiFontToFontSpec( fpgApplication.DefaultFont, lDefaultFontSpec ); - Font := GetFont( lDefaultFontSpec ); - if Font = nil then - // WTF! We can't even get the default system font - raise Exception.Create( 'Could not access default font ' - + 'in place of ' - + FontSpec.FaceName - + ' ' - + IntToStr( FontSpec.PointSize ) ); - end; - + FCanvas.Font := FDefaultFont; + Exit; end; - SelectFont( Font, 1 ); - FCurrentFontSpec := FontSpec; - if FCurrentFont <> Font then - FCurrentFont.Free; - FCurrentFont := Font; -ProfileEvent('DEBUG: TCanvasFontManager.SetFont <<<<'); -end; - -// Get the widths of all characters for current font -// and other dimensions -//------------------------------------------------------------------------ -procedure TCanvasFontManager.LoadMetrics; -var - TheChar: Char; -begin - // Retrieve all character widths - if FCurrentFont.FontType = ftOutline then - begin - SelectFont( FCurrentFont, FontWidthPrecisionFactor ); - end; - - // allocate memory for storing the char widths - GetMem( FCurrentFont.pCharWidthArray, sizeof( TCharWidthArray ) ); - - for TheChar := #0 to #255 do - begin - FCurrentFont.pCharWidthArray^[ TheChar ] := Abs( FCurrentFont.pCharWidthArray^[ TheChar ] ); - end; - - if FCurrentFont.FontType = ftOutline then - begin - SelectFont( FCurrentFont, 1 ); - end - else - begin - // For bitmap fonts, multiply by 256 manually - for TheChar := #0 to #255 do - begin - FCurrentFont.pCharWidthArray^[ TheChar ] := FCurrentFont.pCharWidthArray^[ TheChar ]; - end; - end; -end; - -procedure TCanvasFontManager.EnsureMetricsLoaded; -begin - if FCurrentFont = nil then - raise( Exception.Create( 'No font selected before getting font metrics' ) ); - - if FCurrentFont.pCharWidthArray = Nil then - LoadMetrics; + FCanvas.Font := fpgGetFont(AFontDesc); end; function TCanvasFontManager.CharWidth( const C: Char ): longint; -var - f: TfpgFont; begin -// EnsureMetricsLoaded; -// Result := FCurrentFont.pCharWidthArray^[ C ]; - - { TODO -ograeme : This needs improvement: what about font attributes, and performance. } - f := fpgGetFont(FCurrentFont.FaceName + '-' + IntToStr(FCurrentFont.PointSize)); - Result := f.TextWidth(C); - f.Free; + Result := FCanvas.Font.TextWidth(C); end; function TCanvasFontManager.AverageCharWidth: longint; begin - EnsureMetricsLoaded; - Result := FCurrentFont.lAveCharWidth; + Result := FCanvas.Font.TextWidth('c'); end; function TCanvasFontManager.MaximumCharWidth: longint; begin - EnsureMetricsLoaded; - Result := FCurrentFont.lMaxCharInc; + Result := FCanvas.Font.TextWidth('W'); end; function TCanvasFontManager.CharHeight: longint; begin - EnsureMetricsLoaded; - Result := FCurrentFont.lMaxBaseLineExt; + Result := FCanvas.Font.Height; end; function TCanvasFontManager.CharDescender: longint; begin - EnsureMetricsLoaded; - Result := FCurrentFont.lMaxDescender; + Result := FCanvas.Font.Descent; end; function TCanvasFontManager.IsFixed: boolean; begin - Result := FCurrentFont.FixedWidth; + Result := FCanvas.Font.IsFixedWidth; end; procedure TCanvasFontManager.DrawString(var Point: TPoint; const Length: longint; const S: PChar); @@ -1086,3 +321,4 @@ end; end. + diff --git a/docview/components/richtext/RichTextDisplayUnit.pas b/docview/components/richtext/RichTextDisplayUnit.pas index b8e18264..5f5f8ac1 100644 --- a/docview/components/richtext/RichTextDisplayUnit.pas +++ b/docview/components/richtext/RichTextDisplayUnit.pas @@ -135,6 +135,7 @@ var Selected: boolean; NextSelected: boolean; NewMarginX: longint; + fStyle: string; procedure DrawTextBlock; begin @@ -172,7 +173,9 @@ ProfileEvent('DEBUG: DrawRichTextLine >>>'); StringToDraw := ''; Style := Line.Style; - FontManager.SetFont( Style.Font ); + fStyle := Style.FontNameSize; + ApplyFontAttributes(fStyle, Style.FontAttributes); + FontManager.SetFont( fStyle ); StartedDrawing := false; TextBlockStart := P; @@ -222,21 +225,17 @@ ProfileEvent('DEBUG: DrawRichTextLine >>>'); begin Bitmap := Layout.Images.Item[BitmapIndex].Image; - BitmapRect.Left := X div FontWidthPrecisionFactor; + BitmapRect.Left := X; BitmapRect.Top := Start.Y; BitmapRect.Right := Trunc(BitmapRect.Left - + Bitmap.Width - * Layout.HorizontalImageScale); + + Bitmap.Width * Layout.HorizontalImageScale); BitmapRect.Bottom := Trunc(BitmapRect.Top - + Bitmap.Height - * Layout.VerticalImageScale); + + Bitmap.Height * Layout.VerticalImageScale); FontManager.Canvas.StretchDraw(BitmapRect.Left, BitMapRect.Top, BitmapRect.Right-BitMapRect.Left, BitMapRect.Bottom-BitMapRect.Top, Bitmap); - inc( X, trunc( Bitmap.Width - * FontWidthPrecisionFactor - * Layout.HorizontalImageScale ) ); + inc( X, trunc( Bitmap.Width * Layout.HorizontalImageScale ) ); end; end else @@ -253,7 +252,7 @@ ProfileEvent('DEBUG: DrawRichTextLine >>>'); TextBlockStart := NextP; if ( Element.Tag.TagType = ttItalicOff ) - and ( faItalic in Style.Font.Attributes ) + and ( faItalic in Style.FontAttributes ) and ( not FontManager.IsFixed ) then // end of italic; add a space diff --git a/docview/components/richtext/RichTextLayoutUnit.pas b/docview/components/richtext/RichTextLayoutUnit.pas index 61ce150c..ccfb0ca4 100644 --- a/docview/components/richtext/RichTextLayoutUnit.pas +++ b/docview/components/richtext/RichTextLayoutUnit.pas @@ -131,9 +131,7 @@ end; // Create a layout of the specified rich text. constructor TRichTextLayout.Create(Text: PChar; Images: TfpgImageList; RichTextSettings: TRichTextSettings; FontManager: TCanvasFontManager; - AWidth: longint); -var - DefaultFontSpec: TFontSpec; + Width: longint); Begin ProfileEvent('DEBUG: TRichTextLayout.Create >>>>'); inherited Create; @@ -156,11 +154,7 @@ ProfileEvent('DEBUG: TRichTextLayout.Create 2'); //FVerticalImageScale := FFontManager.Canvas.VerticalResolution // / Screen.Canvas.VerticalResolution; - // use normal font for default font when specified fonts can't be found - FPGuiFontToFontSpec( RichTextSettings.NormalFont, DefaultFontSpec ); ProfileEvent('DEBUG: TRichTextLayout.Create 3'); - FFontManager.DefaultFontSpec := DefaultFontSpec; -ProfileEvent('DEBUG: TRichTextLayout.Create 4'); Layout; ProfileEvent('DEBUG: TRichTextLayout.Create <<<<'); End; @@ -432,7 +426,7 @@ ProfileEvent('DEBUG: TRichTextLayout.Layout >>>>'); CheckFontHeights( CurrentLine ); if ( CurrentElement.Tag.TagType = ttItalicOff ) - and ( faItalic in Style.Font.Attributes ) then + and ( faItalic in Style.FontAttributes ) then begin if not FFontManager.IsFixed then begin @@ -604,10 +598,8 @@ begin Result := Style.LeftMargin; taRight: - Result := Style.LeftMargin - + FLayoutWidth - - Style.RightMargin - - Line.Width; + Result := Style.LeftMargin + FLayoutWidth + - Style.RightMargin - Line.Width; taCenter: begin @@ -616,10 +608,8 @@ begin // |<-lm->[aaaaaaaaaaaaaaa]<-space-><-rm->| // |<-----line width------> | // space = layoutw-rm-linew - SpaceOnLine := FLayoutWidth - - Style.RightMargin - - Line.Width; // Note: line width includes left margin - Result := Style.LeftMargin + (SpaceOnLine div 2); + SpaceOnLine := FLayoutWidth - Style.RightMargin - Line.Width; // Note: line width includes left margin + Result := Style.LeftMargin + (SpaceOnLine div 2); end; end; end; @@ -639,15 +629,18 @@ Var Style: TTextDrawStyle; NewMarginX: longint; StartedDrawing: boolean; + fstyle: string; begin Line := TLayoutLine(FLines[ LineIndex ]); P := Line.Text; EndP := Line.Text + Line.Length; Style := Line.Style; - FFontManager.SetFont( Style.Font ); - StartedDrawing := false; + fStyle := Style.FontNameSize; + ApplyFontAttributes(fStyle, Style.FontAttributes); + FFontManager.SetFont( fStyle ); + StartedDrawing := false; Link := ''; if Line.LinkIndex <> -1 then CurrentLink := FLinks[ Line.LinkIndex ] @@ -703,14 +696,12 @@ begin else begin if ( Element.Tag.TagType = ttItalicOff ) - and ( faItalic in Style.Font.Attributes ) + and ( faItalic in Style.FontAttributes ) and ( not FFontManager.IsFixed ) then // end of italic; add a space // inc( X, FFontManager.CharWidth( ' ' ) ); - PerformStyleTag( Element.Tag, - Style, - X ); + PerformStyleTag( Element.Tag, Style, X ); NewMarginX := Style.LeftMargin; if NewMarginX > X then begin @@ -738,13 +729,16 @@ Var Line: TLayoutLine; Style: TTextDrawStyle; NewMarginX: longint; + fStyle: string; begin Line := TLayoutLine(FLines[ LineIndex ]); P := Line.Text; EndP := Line.Text + Line.Length; Style := Line.Style; - FFontManager.SetFont( Style.Font ); + fStyle := Style.FontNameSize; + ApplyFontAttributes(fStyle, Style.FontAttributes); + FFontManager.SetFont( fStyle ); StartedDrawing := false; @@ -767,7 +761,6 @@ begin if GetCharIndex( P ) - GetCharIndex( Line.Text ) >= Offset then begin - X := X; // found exit; end; @@ -780,14 +773,12 @@ begin teStyle: begin if ( Element.Tag.TagType = ttItalicOff ) - and ( faItalic in Style.Font.Attributes ) + and ( faItalic in Style.FontAttributes ) and ( not FFontManager.IsFixed ) then // end of italic; add a space // inc( X, FFontManager.CharWidth( ' ' ) ); - PerformStyleTag( Element.Tag, - Style, - X ); + PerformStyleTag( Element.Tag, Style, X ); NewMarginX := Style.LeftMargin; if NewMarginX > X then @@ -803,8 +794,6 @@ begin // went thru the whole line without finding the point, if not StartedDrawing then X := GetStartX( Style, Line ); - - X := X; end; function TRichTextLayout.GetLineFromPosition( YToFind: longint; @@ -1003,6 +992,6 @@ begin end; end; -Initialization -End. + +end. diff --git a/docview/components/richtext/RichTextStyleUnit.pas b/docview/components/richtext/RichTextStyleUnit.pas index cfdde684..ade745e6 100644 --- a/docview/components/richtext/RichTextStyleUnit.pas +++ b/docview/components/richtext/RichTextStyleUnit.pas @@ -9,7 +9,8 @@ uses type TTextDrawStyle = record - Font: TFontSpec; + FontNameSize: TfpgString; + FontAttributes: TFontAttributes; Color: TfpgColor; BackgroundColor: TfpgColor; Alignment: TTextAlignment; @@ -69,37 +70,23 @@ type public constructor Create(AOwner: TComponent); override; destructor Destroy; override; - property OnChange: TNotifyEvent read FOnChange write FOnChange; - procedure BeginUpdate; procedure EndUpdate; - - // Stream in/out - //Procedure ReadSCUResource( Const ResName: TResourceName; - // Var Data; - // DataLen: LongInt ); override; - //Function WriteSCUResource( Stream: TResourceStream ): boolean; override; - property Margins: TRect read FMargins write SetMargins; - property Heading1Font: TfpgFont read FHeading1Font write SetHeading1Font; property Heading2Font: TfpgFont read FHeading2Font write SetHeading2Font; property Heading3Font: TfpgFont read FHeading3Font write SetHeading3Font; property FixedFont: TfpgFont read FFixedFont write SetFixedFont; property NormalFont: TfpgFont read FNormalFont write SetNormalFont; - + property OnChange: TNotifyEvent read FOnChange write FOnChange; published - property DefaultBackgroundColor: TfpgColor read FDefaultBackgroundColor write SetDefaultBackgroundColor; property DefaultColor: TfpgColor read FDefaultColor write SetDefaultColor; - property DefaultAlignment: TTextAlignment read FDefaultAlignment write SetDefaultAlignment; property DefaultWrap: boolean read FDefaultWrap write SetDefaultWrap default True; property AtLeastOneWordBeforeWrap: boolean read FAtLeastOneWordBeforeWrap write SetAtLeastOneWordBeforeWrap; - property MarginSizeStyle: TMarginSizeStyle read FMarginSizeStyle write SeTMarginSizeStyle; property MarginChar: longint read FMarginChar write SetMarginChar; - // margins are exposed as individual properties here // since the Sibyl IDE cannot cope with editing a record property // within a class property (as in RichTextView) @@ -134,11 +121,15 @@ uses // , ACLProfile ; -Procedure ApplyStyle( var Style: TTextDrawStyle; FontManager: TCanvasFontManager ); +Procedure ApplyStyle(var Style: TTextDrawStyle; FontManager: TCanvasFontManager); +var + s: string; begin ProfileEvent('DEBUG: ApplyStyle >>>'); assert(FontManager <> nil, 'FontManager should not have been nil'); - FontManager.SetFont( Style.Font ); + s := Style.FontNameSize; + ApplyFontAttributes(s, Style.FontAttributes); + FontManager.SetFont(s); FontManager.Canvas.TextColor := Style.Color; ProfileEvent('DEBUG: ApplyStyle <<<'); end; @@ -166,31 +157,31 @@ begin ProfileEvent('DEBUG: ApplyStyleTag >>>'); case Tag.TagType of ttBold: - Include( Style.Font.Attributes, faBold ); + Include( Style.FontAttributes, faBold ); ttBoldOff: - Exclude( Style.Font.Attributes, faBold ); + Exclude( Style.FontAttributes, faBold ); ttItalic: - Include( Style.Font.Attributes, faItalic ); + Include( Style.FontAttributes, faItalic ); ttItalicOff: - Exclude( Style.Font.Attributes, faItalic ); + Exclude( Style.FontAttributes, faItalic ); ttUnderline: - Include( Style.Font.Attributes, faUnderscore ); + Include( Style.FontAttributes, faUnderscore ); ttUnderlineOff: - Exclude( Style.Font.Attributes, faUnderscore ); + Exclude( Style.FontAttributes, faUnderscore ); ttFixedWidthOn: - FPGuiFontToFontSpec( Settings.FFixedFont, Style.Font ); + Settings.FixedFont := GetFPGuiFont(Style.FontNameSize, Style.FontAttributes); ttFixedWidthOff: - FPGuiFontToFontSpec( Settings.FNormalFont, Style.Font ); + Settings.NormalFont := GetFPGuiFont(Style.FontNameSize, Style.FontAttributes); ttHeading1: - FPGuiFontToFontSpec( Settings.FHeading1Font, Style.Font ); + Settings.Heading1Font := GetFPGuiFont(Style.FontNameSize, Style.FontAttributes); ttHeading2: - FPGuiFontToFontSpec( Settings.FHeading2Font, Style.Font ); + Settings.Heading2Font := GetFPGuiFont(Style.FontNameSize, Style.FontAttributes); ttHeading3: - FPGuiFontToFontSpec( Settings.FHeading3Font, Style.Font ); + Settings.Heading3Font := GetFPGuiFont(Style.FontNameSize, Style.FontAttributes); ttHeadingOff: - FPGuiFontToFontSpec( Settings.FNormalFont, Style.Font ); + Settings.NormalFont := GetFPGuiFont(Style.FontNameSize, Style.FontAttributes); ttFont: begin @@ -201,39 +192,27 @@ ProfileEvent('DEBUG: ApplyStyleTag >>>'); tmpFontParts.Destroy; NewStyle := Style; - try - NewStyle.Font.FaceName := FontFaceName; - - if Pos( 'x', FontSizeString ) > 0 then - begin - tmpFontParts := TStringList.Create; - StrExtractStrings(tmpFontParts, FontSizeString, ['x'], #0); - XSizeStr := tmpFontParts[0]; - YSizeStr := tmpFontParts[1]; - tmpFontParts.Destroy; - - NewStyle.Font.XSize := StrToInt( XSizeStr ); - NewStyle.Font.YSize := StrToInt( YSizeStr ); - NewStyle.Font.PointSize := 0; - end - else - begin - NewStyle.Font.PointSize := StrToInt( FontSizeString ); - end; + NewStyle.FontNameSize := FontFaceName; - if ( NewStyle.Font.FaceName <> '' ) - and ( NewStyle.Font.PointSize >= 1 ) then - begin - Style := NewStyle; - end; + if Pos( 'x', FontSizeString ) > 0 then + begin + tmpFontParts := TStringList.Create; + StrExtractStrings(tmpFontParts, FontSizeString, ['x'], #0); + XSizeStr := tmpFontParts[0]; + YSizeStr := tmpFontParts[1]; + tmpFontParts.Destroy; + NewStyle.FontNameSize := NewStyle.FontNameSize + '-' + YSizeStr; + end + else + NewStyle.FontNameSize := NewStyle.FontNameSize + '-' + FontSizeString; - except - end; + if ( NewStyle.FontNameSize <> '' ) then + Style := NewStyle; end; ttFontOff: // restore default - FPGuiFontToFontSpec( Settings.FNormalFont, Style.Font ); + Settings.NormalFont := GetFPGuiFont(Style.FontNameSize, Style.FontAttributes); ttColor: GetTagColor( Tag.Arguments, Style.Color ); @@ -320,11 +299,12 @@ end; function GetDefaultStyle( const Settings: TRichTextSettings ): TTextDrawStyle; begin FillChar(Result, SizeOf(TTextDrawStyle), 0); - FPGuiFontToFontSpec( Settings.NormalFont, Result.Font ); - Result.Alignment := Settings.DefaultAlignment; - Result.Wrap := Settings.DefaultWrap; - Result.Color := Settings.DefaultColor; - Result.BackgroundColor := Settings.DefaultBackgroundColor; + Result.FontNameSize := DefaultTopicFont + '-10'; + Result.FontAttributes := []; + Result.Alignment := Settings.FDefaultAlignment; + Result.Wrap := Settings.FDefaultWrap; + Result.Color := Settings.FDefaultColor; + Result.BackgroundColor := Settings.FDefaultBackgroundColor; Result.LeftMargin := Settings.Margins.Left; Result.RightMargin := Settings.Margins.Right; end; @@ -492,14 +472,10 @@ end; Function FontSame( FontA: TfpgFont; FontB: TfpgFont ): boolean; begin - if ( FontA = nil ) - or ( FontB = nil ) then - begin - Result := FontA = FontB; - exit; - end; - - Result := FontA.FontDesc = FontB.FontDesc; + if ( FontA = nil ) or ( FontB = nil ) then + Result := False + else + Result := FontA.FontDesc = FontB.FontDesc; end; Procedure TRichTextSettings.AssignFont(var AFont: TfpgFont; NewFont: TfpgFont ); @@ -518,12 +494,7 @@ End; Procedure TRichTextSettings.SetHeading1Font( NewFont: TfpgFont ); begin -// ProfileEvent( 'TRichTextSettings.SetHeading1Font' ); AssignFont( FHeading1Font, NewFont ); - -// if FHeading1FOnt = nil then -// ProfileEvent( ' Set to nil' ); - end; Procedure TRichTextSettings.SetHeading2Font( NewFont: TfpgFont ); @@ -631,6 +602,9 @@ begin end; end; -Initialization - RegisterClasses( [ TRichTextSettings ] ); -End. + +initialization + RegisterClasses([TRichTextSettings]); + +end. + diff --git a/docview/components/richtext/RichTextView.pas b/docview/components/richtext/RichTextView.pas index 799d9f36..06b57dff 100644 --- a/docview/components/richtext/RichTextView.pas +++ b/docview/components/richtext/RichTextView.pas @@ -928,12 +928,7 @@ ProfileEvent('DEBUG: TRichTextView.CreateWnd >>>>'); if InDesigner then exit; - { TODO -ograeme : I disabled bitmap fonts } - FFontManager := TCanvasFontManager.Create( Canvas, - False, // allow bitmap fonts - Self - ); - + FFontManager := TCanvasFontManager.Create(Canvas, Self); FLastLinkOver := ''; FSelectionStart := -1; FSelectionEnd := -1; |