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 | |
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.
-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 | ||||
-rw-r--r-- | docview/src/SettingsUnit.pas | 2 |
6 files changed, 185 insertions, 992 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; diff --git a/docview/src/SettingsUnit.pas b/docview/src/SettingsUnit.pas index 77c72cce..6b49aee1 100644 --- a/docview/src/SettingsUnit.pas +++ b/docview/src/SettingsUnit.pas @@ -55,7 +55,7 @@ Const NumFontSettings = 1; -Type +type TIndexStyle = ( isAlphabetical, isFileOnly, isFull ); TToolbarStyle = ( tsNone, tsImages, tsText, tsImagesAndText ); TGlobalSearchLocation = ( gsHelpPaths, gsFixedDrives, gsSelectedHelpPaths, gsCustom ); |