{Version 9.45} {*********************************************************} {* STYLEUN.PAS *} {*********************************************************} { Copyright (c) 1995-2008 by L. David Baldwin Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. Note that the source modules, HTMLGIF1.PAS, PNGZLIB1.PAS, DITHERUNIT.PAS, and URLCON.PAS are covered by separate copyright notices located in those modules. } {$i htmlcons.inc} unit StyleUn; interface uses SysUtils, Classes, {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, Types, LclType, HtmlMisc, {$ENDIF} Graphics, Controls, Forms, Dialogs; const IntNull = -12345678; Auto = -12348765; AutoParagraph = -12348766; ParagraphSpace = 14; {default spacing between paragraphs, etc.} {$ifdef Delphi6_Plus} varInt = [varInteger, varByte, varSmallInt, varShortInt, varWord, varLongWord]; {$else} varInt = [varInteger]; {$endif} EastEurope8859_2 = 31; {for 8859-2} CRLF = #$D#$A; type AlignmentType = (ANone, ATop, AMiddle, ABaseline, ABottom, ALeft, ARight, AJustify, ASub, ASuper); BorderStyleType = (bssNone, bssSolid, bssInset, bssOutset, bssGroove, bssRidge, bssDashed, bssDotted, bssDouble); ListBulletType = (lbBlank, lbCircle, lbDecimal, lbDisc, lbLowerAlpha, lbLowerRoman, lbNone, lbSquare, lbUpperAlpha, lbUpperRoman); ClearAttrType = (clrNone, clLeft, clRight, clAll); PositionType = (posStatic, posAbsolute, posRelative); VisibilityType = (viInherit, viHidden, viVisible); TextTransformType = (txNone, txUpper, txLower, txCaps); PositionRec = record PosType: (pTop, pCenter, pBottom, pLeft, pRight, PPercent, pDim); Value: integer; RepeatD: boolean; Fixed: boolean; end; PtPositionRec = array[1..2] of PositionRec; {$ifdef Ver90} TFontCharSet = integer; {dummy for Delphi 2} {$endif} ThtFontInfo = class iName: string; iSize: double; iStyle: TFontStyles; iColor: TColor; ibgColor: TColor; iCharSet: TFontCharSet; iCharExtra: Variant; end; FIIndex = (LFont, VFont, HLFont, HVFont); TFontInfoArray = class Ar: array[LFont..HVFont] of ThtFontInfo; constructor Create; destructor Destroy; override; procedure Assign(Source: TFontInfoArray); end; SetOfChar = Set of Char; TMyFont = class(TFont) public bgColor: TColor; tmHeight, tmDescent, tmExternalLeading, tmAveCharWidth, tmMaxCharWidth, tmCharset: integer; CharExtra: integer; procedure Assign(Source: TPersistent); override; procedure AssignToCanvas(Canvas: TCanvas); destructor Destroy; override; constructor Create; end; PropIndices = ( FontFamily, FontSize, FontStyle, FontWeight, TextAlign, TextDecoration, LetterSpacing, BorderStyle, Color, BackgroundColor, BorderColor, MarginTop, MarginRight, MarginBottom, MarginLeft, PaddingTop, PaddingRight, PaddingBottom, PaddingLeft, BorderTopWidth, BorderRightWidth, BorderBottomWidth, BorderLeftWidth, BorderTopColor, BorderRightColor, BorderBottomColor, BorderLeftColor, BorderTopStyle, BorderRightStyle, BorderBottomStyle, BorderLeftStyle, Width, Height, TopPos, BottomPos, RightPos, LeftPos, Visibility, LineHeight, BackgroundImage, BackgroundPosition, BackgroundRepeat, BackgroundAttachment, VerticalAlign, Position, ZIndex, ListStyleType, ListStyleImage, Float, Clear, TextIndent, PageBreakBefore, PageBreakAfter, PageBreakInside, TextTransform, WordWrap, FontVariant, BorderCollapse, OverFlow, Display); TVMarginArray = array[BackgroundColor..LeftPos] of Variant; TMarginArray = array[BackgroundColor..LeftPos] of integer; TStyleList = class; TProperties = class(TObject) private TheFont: TMyFont; InLink: boolean; DefFontname: string; procedure AddPropertyByIndex(Index: PropIndices; PropValue: string); procedure GetSingleFontInfo(var Font: ThtFontInfo); procedure CalcLinkFontInfo(Styles: TStyleList; I: integer); procedure CombineX(Styles: TStyleList; const Tag, AClass, AnID, PSeudo, ATitle: string; AProp: TProperties); public PropTag, PropClass, PropID, PropPseudo, PropTitle: string; PropStyle: TProperties; FontBG: TColor; CharSet: TFontCharSet; CodePage: integer; EmSize, ExSize: integer; {# pixels for Em and Ex dimensions} Props: array[Low(PropIndices)..High(PropIndices)] of Variant; Originals: array[Low(PropIndices)..High(PropIndices)] of boolean; FIArray: TFontInfoArray; ID: integer; constructor Create; destructor Destroy; override; procedure Copy(Source: TProperties); procedure CopyDefault(Source: TProperties); procedure Inherit(Tag: string; Source: TProperties); procedure Assign(const Item: Variant; Index: PropIndices); procedure AssignCharSet(CS: TFontCharset); procedure AssignUTF8; procedure Combine(Styles: TStyleList; const Tag, AClass, AnID, Pseudo, ATitle: string; AProp: TProperties); procedure Update(Source: TProperties; Styles: TStyleList; I: integer); function GetFont: TMyFont; procedure GetFontInfo(AFI: TFontInfoArray); procedure GetVMarginArray(var MArray: TVMarginArray); function GetBackgroundImage(var Image: string): boolean; procedure GetBackgroundPos(EmSize, ExSize: integer; var P: PtPositionRec); function GetLineHeight(NewHeight:integer): integer; function GetTextIndent(var PC: boolean): integer; function GetTextTransform: TextTransformType; function GetFontVariant: string; procedure GetPageBreaks(var Before, After, Intact: boolean); function GetVertAlign(var Align: AlignmentType): boolean; function GetFloat(var Align: AlignmentType): boolean; function GetClear(var Clr: ClearAttrType): boolean; function GetOriginalForegroundColor: TColor; function GetBackgroundColor: TColor; function GetBorderStyle: BorderStyleType; function BorderStyleNotBlank: boolean; function GetListStyleType: ListBulletType; function GetListStyleImage: string; function GetPosition: PositionType; function GetVisibility: VisibilityType; function GetZIndex: integer; function DisplayNone: boolean; function Collapse: boolean; procedure SetFontBG; procedure AddPropertyByName(const PropName, PropValue: string); function IsOverflowHidden: boolean; end; TStyleList = Class(TStringList) private MasterList: TObject; SeqNo: integer; public DefProp: TProperties; constructor Create(AMasterList: TObject); destructor Destroy; override; procedure Clear; override; function GetSeqNo: string; procedure Initialize(const FontName, PreFontName: string; PointSize: integer; AColor, AHotspot, AVisitedColor, AActiveColor: TColor; LinkUnderline: boolean; ACharSet: TFontCharSet; MarginHeight, MarginWidth: integer); procedure AddModifyProp(const Selector, Prop, Value: string); function AddObject(const S: string; AObject: TObject): Integer; override; function AddDuplicate(const Tag: string; Prop: TProperties): TProperties; procedure ModifyLinkColor(Psuedo: string; AColor: TColor); {$ifdef Quirk} procedure FixupTableColor(BodyProp: TProperties); {$endif} end; const PropWords: array[Low(PropIndices)..High(PropIndices)] of string = ('font-family', 'font-size', 'font-style', 'font-weight', 'text-align', 'text-decoration', 'letter-spacing', 'border-style', 'color', 'background-color', 'border-color', 'margin-top', 'margin-right', 'margin-bottom', 'margin-left', 'padding-top', 'padding-right','padding-bottom', 'padding-left', 'border-top-width', 'border-right-width','border-bottom-width', 'border-left-width', 'border-top-color', 'border-right-color','border-bottom-color', 'border-left-color', 'border-top-style', 'border-right-style','border-bottom-style', 'border-left-style', 'width', 'height', 'top', 'bottom', 'right', 'left', 'visibility', 'line-height', 'background-image', 'background-position', 'background-repeat', 'background-attachment', 'vertical-align', 'position', 'z-index', 'list-style-type', 'list-style-image', 'float', 'clear', 'text-indent', 'page-break-before', 'page-break-after', 'page-break-inside', 'text-transform', 'word-wrap', 'font-variant', 'border-collapse', 'overflow', 'display'); procedure ConvMargArray(const VM: TVMarginArray; BaseWidth, BaseHeight, EmSize, ExSize: integer; BStyle: BorderStyleType; var AutoCount: integer; var M: TMarginArray); procedure ConvVertMargins(const VM: TVMarginArray; BaseHeight, EmSize, ExSize: Integer; var M: TMarginArray; var TopAuto, BottomAuto: boolean); procedure ConvMargArrayForCellPadding(const VM: TVMarginArray; EmSize, ExSize: Integer; var M: TMarginArray); procedure ConvInlineMargArray(const VM: TVMarginArray; BaseWidth, BaseHeight, EmSize, ExSize: Integer; {BStyle: BorderStyleType;} var M: TMarginArray); function ColorFromString(S: string; NeedPound: boolean; var Color: TColor): boolean; function ReadURL(Item: Variant): string; function ReadFontName(S: string): string; function AlignmentFromString(S: string): AlignmentType; {$ifndef Ver130} {$ifndef Delphi6_Plus} procedure FreeAndNil(var Obj); {$endif} {$endif} implementation uses {$ifdef Delphi6_Plus} Variants, {$endif} htmlsubs, htmlun2, readhtml; var DefPointSize: double; {$ifndef Ver130} {$ifndef Delphi6_Plus} procedure FreeAndNil(var Obj); var P: TObject; begin P := TObject(Obj); TObject(Obj) := nil; {clear the reference before destroying the object} P.Free; end; {$endif} {$endif} {----------------AlignmentFromString} function AlignmentFromString(S: string): AlignmentType; begin S := LowerCase(S); if S = 'top' then Result := ATop else if (S = 'middle') or (S = 'absmiddle') or (S = 'center') then Result := AMiddle else if S = 'left' then Result := ALeft else if S = 'right' then Result := ARight else if (S = 'bottom') then Result := ABottom else if (S = 'baseline') then Result := ABaseline else if (S = 'justify') then Result := AJustify else Result := ANone; end; function FontSizeConv(const Str: string; OldSize: double): double; forward; function LengthConv(const Str: string; Relative: boolean; Base, EmSize, ExSize, Default: integer): integer; forward; function FindPropIndex(const PropWord:string; var PropIndex: PropIndices): boolean; var I: PropIndices; begin Result := True; for I := Low(PropIndices) to High(PropIndices)do if PropWord = PropWords[I] then begin PropIndex := I; Exit; end; Result := False; end; {----------------ReadURL} function ReadURL(Item: Variant): string; var I: integer; S: string; begin Result := ''; if VarType(Item) = VarString then begin S := Item; I := Pos('url(', S); if I > 0 then begin S := System.Copy(S, 5, Length(S)); I := Pos(')', S); if I > 0 then S := System.Copy(S, 1, I-1); if Length(S) > 2 then if S[1] in ['''', '"'] then begin Delete(S, Length(S), 1); Delete(S, 1, 1); end; Result := S; end; end; end; {----------------TMyFont.Assign} procedure TMyFont.Assign(Source: TPersistent); begin if Source is TMyFont then begin bgColor := TMyFont(Source).bgColor; tmHeight := TMyFont(Source).tmHeight; tmDescent := TMyFont(Source).tmDescent; tmExternalLeading := TMyFont(Source).tmExternalLeading; tmAveCharWidth := TMyFont(Source).tmAveCharWidth; tmMaxCharWidth := TMyFont(Source).tmMaxCharWidth; tmCharset := TMyFont(Source).tmCharset; CharExtra := TMyFont(Source).CharExtra; end; inherited Assign(Source); end; procedure TMyFont.AssignToCanvas(Canvas: TCanvas); begin Canvas.Font := Self; SetTextCharacterExtra(Canvas.Handle, CharExtra); end; destructor TMyFont.destroy; begin inherited; end; constructor TmyFont.Create; begin inherited; end; var Sequence: integer; {----------------TProperties.Create} constructor TProperties.Create; var I: PropIndices; begin inherited Create; ID := Sequence; Inc(Sequence); FontBG := clNone; for I := MarginTop to LeftPos do Props[I] := IntNull; Props[ZIndex] := 0; end; destructor TProperties.Destroy; begin TheFont.Free; FIArray.Free; inherited; end; {----------------TProperties.Copy} procedure TProperties.Copy(Source: TProperties); var I: PropIndices; begin for I := Low(I) to High(I) do Props[I] := Source.Props[I]; end; {----------------TProperties.CopyDefault} procedure TProperties.CopyDefault(Source: TProperties); var I: PropIndices; begin for I := Low(I) to High(I) do Props[I] := Source.Props[I]; AssignCharSet(Source.CharSet); DefFontname := Source.DefFontname; PropTag := 'default'; end; procedure TProperties.Inherit(Tag: string; Source: TProperties); {copy the properties that are inheritable} var I: PropIndices; Span, HBF: boolean; begin Span := Source.PropTag = 'span'; HBF := (Source.PropTag = 'thead') or (Source.PropTag = 'tbody') or (Source.PropTag = 'tfoot'); for I := Low(I) to High(I) do if Span and (I <> BorderStyle) then {Borderstyle already acted on} Props[I] := Source.Props[I] else if HBF then begin Props[I] := Source.Props[I]; {tr gets them all} Originals[I] := Source.Originals[I]; end else if (I = WordWrap) and (Tag = 'table') then {table doesn't inherit word wrap} Props[WordWrap] := 'normal' else case I of MarginTop..LeftPos: Props[I] := IntNull; BackgroundColor, BorderColor, BorderStyle, Clear, Float, BackgroundImage, BackgroundPosition, BackgroundRepeat, BackgroundAttachment, Position, PageBreakBefore, PageBreakAfter, PageBreakInside, BorderCollapse, OverFlow, Display: ; {do nothing} else Props[I] := Source.Props[I]; end; DefFontname := Source.DefFontname; FontBG := Source.FontBG; CharSet := Source.CharSet; CodePage := Source.CodePage; PropTitle := Source.PropTitle; InLink := Source.InLink; if InLink then begin if not Assigned(FIArray) then FIArray := TFontInfoArray.Create; FIArray.Assign(Source.FIArray); end; EmSize := Source.EmSize; {actually this is calculated later } ExSize := EmSize div 2; {apparently correlates with what browsers are doing} end; {----------------TProperties.Update} procedure TProperties.Update(Source: TProperties; Styles: TStyleList; I: integer); {Change the inherited properties for this item to those of Source} var Index: PropIndices; begin for Index := Low(Index) to High(Index) do if not Originals[Index] then Props[Index] := Source.Props[Index]; TheFont.Free; {may no longer be good} TheFont := Nil; if Assigned(FIArray) then if Source.Inlink then FIArray.Assign(Source.FIArray) else if PropPseudo = 'link' then {an tag} CalcLinkFontInfo(Styles, I) else begin {an tag has been removed} FIArray.Free; FIArray := Nil; Inlink := False; end; end; {----------------TProperties.Assign} procedure TProperties.Assign(const Item: Variant; Index: PropIndices); {Assignment should be made in order of importance as the first one in predominates} var I: FIIndex; begin if not Originals[Index] then begin Props[Index] := Item; Originals[Index] := True; if InLink then case Index of Color: for I := LFont to HVFont do FIArray.Ar[I].iColor := Item; FontSize: for I := LFont to HVFont do FIArray.Ar[I].iSize := Item; FontFamily: for I := LFont to HVFont do FIArray.Ar[I].iName := Item; end; end; end; function TProperties.GetBackgroundImage(var Image: string): boolean; begin if (VarType(Props[BackgroundImage]) = VarString) then if (Props[BackgroundImage] = 'none') then begin Image := ''; Result := True; end else begin Image := ReadUrl(Props[BackgroundImage]); Result := Image <> ''; end else Result := False; end; procedure TProperties.AssignCharSet(CS: TFontCharset); const {EastEurope8859_2 = 31; } SetValues: array[1..20] of integer = (ANSI_CHARSET, DEFAULT_CHARSET, SYMBOL_CHARSET, MAC_CHARSET, SHIFTJIS_CHARSET, HANGEUL_CHARSET, JOHAB_CHARSET, GB2312_CHARSET, CHINESEBIG5_CHARSET, GREEK_CHARSET, TURKISH_CHARSET, VIETNAMESE_CHARSET, HEBREW_CHARSET, ARABIC_CHARSET, BALTIC_CHARSET, RUSSIAN_CHARSET, THAI_CHARSET, EASTEUROPE_CHARSET, OEM_CHARSET, EastEurope8859_2); { SetValues: array[1..19] of integer = (0, 1, 2, 77, 128, 129, 130, 134, 136, 161, 162, 163, 177, 178, 186, 204, 222, 238, 255); } CodePages: array[1..20] of integer = (1252, CP_ACP, 0, CP_MACCP, 932, 949, 1361, 936, 950, 1253, 1254, 1258, 1255, 1256, 1257, 1251, 874, 1250, CP_OEMCP, 28592); {28592 for 8859-2, east european} var I: integer; Save: THandle; tm : TTextmetric; DC: HDC; Font: TFont; IX: FIIndex; begin if CS = EastEurope8859_2 then begin CharSet := EASTEUROPE_CHARSET; CodePage := 28592; if Assigned(FIArray) then for IX := LFont to HVFont do FIArray.Ar[IX].iCharset := CharSet; Exit; end; {the following makes sure the CharSet is available. It also translates "Default_CharSet" into the actual local character set} Font := TFont.Create; Font.Name := ''; Font.CharSet := CS; DC := GetDC(0); try Save := SelectObject(DC, Font.Handle); GetTextMetrics(DC, tm); if CS <> Default_Charset then {leave default as is} CharSet := tm.tmCharSet else CharSet := Default_CharSet; if Assigned(FIArray) then for IX := LFont to HVFont do FIArray.Ar[IX].iCharset := CharSet; SelectObject(DC, Save); Finally ReleaseDC(0, DC); Font.Free; end; for I := 1 to 19 do if SetValues[I] = tm.tmCharSet then begin CodePage := CodePages[I]; break; end; end; procedure TProperties.AssignUTF8; {Called by DoMeta in Readhtml.pas to make the properties using UTF-8 for conversions.} begin CodePage := CP_UTF8; Charset := ANSI_CHARSET; end; {----------------TProperties.GetBackgroundPos} procedure TProperties.GetBackgroundPos(EmSize, ExSize: integer; var P: PtPositionRec); var S: array[1..2] of string; Tmp: string; I, N, XY: integer; begin if (VarType(Props[BackgroundPosition]) <> VarString) then begin P[1].PosType := pDim; P[1].Value := 0; P[2] := P[1]; end else begin Tmp := Trim(Props[BackgroundPosition]); N := Pos(' ', Tmp); if N > 0 then begin S[1] := System.Copy(Tmp, 1, N-1); S[2] := Trim(system.Copy(Tmp, N+1, 255)); N := 2; end else begin S[1] := Tmp; N := 1; end; I := 1; XY := 1; {X} while I <= N do begin P[XY].PosType := pDim; if S[I] = 'center' then P[XY].PosType := pCenter else if Pos('%', S[I]) > 0 then P[XY].PosType := pPercent else if S[I] = 'left' then begin if XY = 2 then {entered in reverse direction} P[2] := P[1]; P[1].PosType := pLeft; end else if S[I] = 'right' then begin if XY = 2 then P[2] := P[1]; P[1].PosType := pRight; end else if S[I] = 'top' then begin P[2].PosType := pTop; if XY = 1 then Dec(XY); {read next one into X} end else if S[I] = 'bottom' then begin P[2].PosType := pBottom; if XY = 1 then Dec(XY); end; if P[XY].PosType in [pDim, pPercent] then begin P[XY].Value := LengthConv(S[I], False, 100, EmSize, ExSize, 0); end; Inc(I); Inc(XY); end; if N = 1 then if XY = 2 then P[2].PosType := pCenter else P[1].PosType := pCenter; {single entry but it was a Y} end; P[1].RepeatD := True; P[2].RepeatD := True; if (VarType(Props[BackgroundRepeat]) = VarString) then begin Tmp := Trim(Props[BackgroundRepeat]); if Tmp = 'no-repeat' then begin P[1].RepeatD := False; P[2].RepeatD := False; end else if Tmp = 'repeat-x' then P[2].RepeatD := False else if Tmp = 'repeat-y' then P[1].RepeatD := False; end; P[1].Fixed := False; if (VarType(Props[BackgroundAttachment]) = VarString) and (Trim(Props[BackgroundAttachment]) = 'fixed') then P[1].Fixed := True; P[2].Fixed := P[1].Fixed; end; function TProperties.GetVertAlign(var Align: AlignmentType): boolean; {note: 'top' should have a catagory of its own} var S: string; begin if (VarType(Props[VerticalAlign]) = VarString) then begin Result := True; S := Props[VerticalAlign]; if (S = 'top') or (S = 'text-top') then Align := ATop else if S = 'middle' then Align := AMiddle else if S = 'baseline' then Align := ABaseline else if (S = 'bottom') then Align := ABottom else if (S = 'sub') then Align := ASub else if (S = 'super') then Align := ASuper else Result := False; end else Result := False; end; function TProperties.IsOverflowHidden: boolean; begin Result := (VarType(Props[OverFlow]) = VarString) and (Props[OverFlow] = 'hidden'); end; function TProperties.GetFloat(var Align: AlignmentType): boolean; var S: string; begin if (VarType(Props[Float]) = VarString) then begin Result := True; S := Props[Float]; if (S = 'left') then Align := ALeft else if S = 'right' then Align := ARight else if S = 'none' then Align := ANone else Result := False; end else Result := False; end; function TProperties.GetClear(var Clr: ClearAttrType): boolean; var S: string; begin if (VarType(Props[Clear]) = VarString) then begin Result := True; S := Props[Clear]; if (S = 'left') then Clr := clLeft else if S = 'right' then Clr := clRight else if S = 'both' then Clr := clAll else if S = 'none' then Clr := clrNone else Result := False; Props[Clear] := Unassigned; {allow only one read} end else Result := False; end; function TProperties.GetListStyleType: ListBulletType; const S: array[Low(ListBulletType)..High(ListBulletType)] of string = ('blank', 'circle', 'decimal', 'disc', 'lower-alpha', 'lower-roman', 'none', 'square', 'upper-alpha', 'upper-roman'); var I: ListBulletType; begin if VarType(Props[ListStyleType]) = VarString then for I := Low(ListBulletType) to High(ListBulletType) do if S[I] = Props[ListStyleType] then begin Result := I; Exit; end; Result := lbBlank; end; function TProperties.GetListStyleImage: string; begin Result := ReadURL(Props[ListStyleImage]) end; function TProperties.GetPosition: PositionType; begin Result := posStatic; if VarType(Props[Position]) = VarString then begin if Props[Position] = 'absolute' then Result := posAbsolute else if Props[Position] = 'relative' then Result := posRelative; end; end; function TProperties.GetVisibility: VisibilityType; begin Result := viVisible; if VarType(Props[Visibility]) in varInt then if Props[Visibility] = viHidden then Result := viHidden; end; function TProperties.GetZIndex: integer; begin Result := 0; if VarType(Props[ZIndex]) in VarInt then Result := Props[ZIndex] else if VarType(Props[ZIndex]) = VarString then Result := StrToIntDef(Props[ZIndex], 0); end; function TProperties.DisplayNone: boolean; begin Result := (VarType(Props[Display]) = VarString) and (Props[Display] = 'none'); end; function TProperties.Collapse: boolean; begin Result := (VarType(Props[BorderCollapse]) = VarString) and (Props[BorderCollapse] = 'collapse'); end; function TProperties.GetLineHeight(NewHeight:integer): integer; var V: double; Code: integer; begin if VarType(Props[LineHeight]) = varString then begin Val(Props[LineHeight], V, Code); if Code = 0 then {a numerical entry with no 'em', '%', etc. Use the new font height} Result := Round(V*NewHeight) else {note: 'normal' yields -1 in the next statement} Result := LengthConv(Props[LineHeight], True, EmSize, EmSize, ExSize, -1); end else Result := -1; end; function TProperties.GetTextIndent(var PC: boolean): integer; var I: integer; begin PC := False; if VarType(Props[TextIndent]) = varString then begin I := Pos('%', Props[TextIndent]); if I > 0 then begin PC := True; {return value in percent} Result := LengthConv(Props[TextIndent], True, 100, 0, 0, 0); end else Result := LengthConv(Props[TextIndent], False, 0, EmSize, EmSize, 0); end else Result := 0; end; function TProperties.GetTextTransform: TextTransformType; begin try if VarType(Props[TextTransform]) in VarInt then Result := Props[TextTransform] else Result := txNone; except Result := txNone; end; end; function TProperties.GetFontVariant: string; begin try if VarType(Props[FontVariant]) = varString then Result := Props[FontVariant] else Result := 'normal'; except Result := 'normal'; end; end; procedure TProperties.GetPageBreaks(var Before, After, Intact: boolean); begin Before := (VarType(Props[PageBreakBefore]) = varString) and (Props[PageBreakBefore] = 'always'); After := (VarType(Props[PageBreakAfter]) = varString) and (Props[PageBreakAfter] = 'always'); Intact := (VarType(Props[PageBreakInside]) = varString) and (Props[PageBreakInside] = 'avoid'); end; function TProperties.GetBackgroundColor: TColor; begin if (VarType(Props[BackgroundColor]) in varInt) and Originals[BackgroundColor] then {Originals to prevent fonts from getting inherited background color} Result := Props[BackgroundColor] else Result := clNone; end; function TProperties.GetOriginalForegroundColor: TColor; begin {return a color only if it hasn't been inherited} if (VarType(Props[Color]) in varInt) and Originals[Color] then Result := Props[Color] else Result := clNone; end; function BorderStyleFromString(const S: string): BorderStyleType; const Ar: array[1..9] of string = ('none', 'solid', 'inset', 'outset','groove', 'ridge', 'dashed', 'dotted', 'double'); Ar1: array[1..9] of BorderStyleType = (bssNone, bssSolid, bssInset, bssOutset, bssGroove, bssRidge, bssDashed, bssDotted, bssDouble); var I: integer; begin Result := bssNone; for I := 1 to 9 do if S = Ar[I] then begin Result := Ar1[I]; break; end; end; function TProperties.GetBorderStyle: BorderStyleType; begin Result := bssNone; if VarType(Props[BorderStyle]) = VarString then Result := BorderStyleFromString(Props[BorderStyle]); end; function TProperties.BorderStyleNotBlank: boolean; {was a border of some type (including bssNone) requested?} begin Result := VarType(Props[BorderStyle]) = VarString; end; procedure TProperties.SetFontBG; {called for font tags like , , etc. Sets the font background color.} begin if (VarType(Props[BackgroundColor]) in varInt) and Originals[BackgroundColor] then FontBG := Props[BackgroundColor]; end; procedure ConvVertMargins(const VM: TVMarginArray; BaseHeight, EmSize, ExSize: Integer; var M: TMarginArray; var TopAuto, BottomAuto: boolean); function Convert(V: Variant; var IsAutoParagraph: boolean): integer; begin IsAutoParagraph := False; if VarType(V) = VarString then Result := LengthConv(V, False, BaseHeight, EmSize, ExSize, 0) {Auto will be 0} else if VarType(V) in varInt then begin if V = IntNull then Result := 0 else if V = AutoParagraph then begin Result := ParagraphSpace; IsAutoParagraph := True; end else Result := V; end else Result := 0; end; begin M[MarginTop] := Convert(VM[MarginTop], TopAuto); M[MarginBottom] := Convert(VM[MarginBottom], BottomAuto); end; {----------------ConvMargArray} procedure ConvMargArray(const VM: TVMarginArray; BaseWidth, BaseHeight, EmSize, ExSize: Integer; BStyle: BorderStyleType; var AutoCount: integer; var M: TMarginArray); {This routine does not do MarginTop and MarginBottom as they are done by ConvVertMargins} var I: PropIndices; Base: integer; begin AutoCount := 0; {count of 'auto's in width items} for I := Low(VM) to High(VM) do begin case I of Height, TopPos: Base := BaseHeight else Base := BaseWidth; end; case I of BackgroundColor, BorderColor: begin if VarType(VM[I]) <= VarNull then M[I] := clNone else M[I] := VM[I]; end; BorderTopWidth..BorderLeftWidth: begin if VM[PropIndices(Ord(BorderTopStyle) + (Ord(I)-Ord(BorderTopWidth)))] = bssNone then M[I] := 0 else begin if VarType(VM[I]) = VarString then begin if VM[I] = 'thin' then M[I] := 2 else if VM[I] = 'medium' then M[I] := 4 else if VM[I] = 'thick' then M[I] := 6 else M[I] := LengthConv(VM[I], False, BaseWidth, EmSize, ExSize, 4); {Auto will be 4} end else if (VarType(VM[I]) in varInt) then begin if (VM[I] = IntNull) then M[I] := 4 else M[I] := VM[I]; end; end; end; Height, PaddingTop..PaddingLeft: begin if VarType(VM[I]) = VarString then begin M[I] := LengthConv(VM[I], False, Base, EmSize, ExSize, 0); {Auto will be 0} if (I = Height) and (Pos('%', VM[I]) > 0) then {include border in % heights} M[I] := M[I] - M[BorderTopWidth] - M[BorderBottomWidth] - M[PaddingTop] - M[PaddingBottom]; end else if VarType(VM[I]) in varInt then begin if VM[I] = IntNull then M[I] := 0 else M[I] := VM[I]; end else M[I] := 0; end; TopPos, RightPos, BottomPos, LeftPos: begin if VarType(VM[I]) = VarString then M[I] := LengthConv(VM[I], False, Base, EmSize, ExSize, Auto) {Auto will be Auto} else if VarType(VM[I]) in varInt then begin if VM[I] = IntNull then M[I] := Auto else M[I] := VM[I]; end else M[I] := Auto; end; MarginLeft, MarginRight: begin if VarType(VM[I]) = VarString then begin if VM[I] = 'auto' then begin M[I] := Auto; Inc(AutoCount); end else M[I] := LengthConv(VM[I], False, BaseWidth, EmSize, ExSize, 0); end else if VarType(VM[I]) in varInt then begin if VM[I] = IntNull then M[I] := 0 else M[I] := VM[I]; end else M[I] := 0; end; Width: begin if VarType(VM[I]) = VarString then M[I] := LengthConv(VM[I], False, BaseWidth, EmSize, ExSize, Auto) else if VarType(VM[I]) in varInt then begin if VM[I] = IntNull then M[I] := Auto else M[I] := VM[I]; end else M[I] := Auto; if M[I] = Auto then Inc(AutoCount); end; MarginTop, MarginBottom: ; {do nothing} else begin if VarType(VM[I]) = VarString then M[I] := LengthConv(VM[I], False, BaseWidth, EmSize, ExSize, 0) else if VarType(VM[I]) in varInt then begin if VM[I] = IntNull then M[I] := 0 else M[I] := VM[I]; end else M[I] := 0; end; end; end; end; procedure ConvMargArrayForCellPadding(const VM: TVMarginArray; EmSize, ExSize: Integer; var M: TMarginArray); {Return negative for no entry or percent entry} var I: PropIndices; begin for I := PaddingTop to PaddingLeft do if VarType(VM[I]) = VarString then M[I] := LengthConv(VM[I], False, -100, EmSize, ExSize, 0) {Auto will be 0} else if VarType(VM[I]) in varInt then begin if VM[I] = IntNull then M[I] := -1 else M[I] := VM[I]; end else M[I] := -1; end; {----------------ConvInlineMargArray} procedure ConvInlineMargArray(const VM: TVMarginArray; BaseWidth, BaseHeight, EmSize, ExSize: Integer; {BStyle: BorderStyleType;} var M: TMarginArray); {currently for images, form controls. BaseWidth/Height and BStyle currently not supported} var I: PropIndices; begin for I := Low(VM) to High(VM) do case I of Height, Width: begin if VarType(VM[I]) = VarString then M[I] := LengthConv(VM[I], False, BaseWidth, EmSize, ExSize, Auto) {Auto will be Auto} else if VarType(VM[I]) in varInt then begin if VM[I] = IntNull then M[I] := IntNull else M[I] := VM[I]; end else M[I] := IntNull; end; MarginLeft, MarginRight, MarginTop, MarginBottom: begin if VarType(VM[I]) = VarString then M[I] := LengthConv(VM[I], False, BaseWidth, EmSize, ExSize, 0) {auto is 0} else if VarType(VM[I]) in varInt then begin if VM[I] = IntNull then M[I] := IntNull else M[I] := VM[I]; end else M[I] := IntNull; end; BorderTopWidth..BorderLeftWidth: begin if VM[PropIndices(Ord(BorderTopStyle) + (Ord(I)-Ord(BorderTopWidth)))] = bssNone then M[I] := 0 else begin if VarType(VM[I]) = VarString then begin if VM[I] = 'thin' then M[I] := 2 else if VM[I] = 'medium' then M[I] := 4 else if VM[I] = 'thick' then M[I] := 6 else M[I] := LengthConv(VM[I], False, BaseWidth, EmSize, ExSize, 4); {Auto will be 4} end else if (VarType(VM[I]) in varInt) then begin if (VM[I] = IntNull) then M[I] := 4 else M[I] := VM[I]; end; end; end; else ; {remaining items unsupported/unused} end; end; {----------------TProperties.Combine} procedure TProperties.Combine(Styles: TStyleList; const Tag, AClass, AnID, PSeudo, ATitle: string; AProp: TProperties); {When called, this TProperties contains the inherited properties. Here we add the ones relevant to this item. AProp are TProperties gleaned from the Style= attribute. AClass may be a multiple class like class="ab.cd"} var BClass, S: string; I: integer; begin BClass := Trim(AClass); I := Pos('.', BClass); if I <= 0 then CombineX(Styles, Tag, BClass, AnID, PSeudo, '', AProp) {0 or 1 Class} else begin {more than one class} repeat S := System.Copy(BClass, 1, I-1); CombineX(Styles, Tag, S, AnID, PSeudo, '', Nil); Delete(BClass, 1, I); BClass := Trim(BClass); I := Pos('.', BClass); until I <= 0; CombineX(Styles, Tag, BClass, AnID, PSeudo, '', AProp); CombineX(Styles, Tag, AClass, AnID, PSeudo, '', AProp); end; PropTag := Tag; PropClass := AClass; PropID := AnID; PropPseudo := Pseudo; PropStyle := AProp; if ATitle <> '' then PropTitle := ATitle; if PSeudo = 'link' then begin if not Assigned(FIArray) then FIArray := TFontInfoArray.Create; CalcLinkFontInfo(Styles, PropStack.Count-1); InLink := True; end; end; {----------------TProperties.CombineX} procedure TProperties.CombineX(Styles: TStyleList; const Tag, AClass, AnID, PSeudo, ATitle: string; AProp: TProperties); {When called, this TProperties contains the inherited properties. Here we add the ones relevant to this item. AProp are TProperties gleaned from the Style= attribute.} var OldSize: double; IX: integer; NoHoverVisited: boolean; procedure Merge(Source: TProperties); var Index: PropIndices; I: FIIndex; Wt: integer; S1: string; begin for Index := Low(Index) to High(PropIndices) do if (VarType(Source.Props[Index]) <> varEmpty) and (Vartype(Source.Props[Index]) <> varNull) then case Index of MarginTop..LeftPos: if VarType(Source.Props[Index]) = VarString then begin Props[Index] := Source.Props[Index]; Originals[Index] := True; end else if Source.Props[Index] <> IntNull then begin Props[Index] := Source.Props[Index]; Originals[Index] := True; end; FontFamily, FontSize, FontStyle, FontWeight, Color, BackgroundColor, TextDecoration, LetterSpacing: begin Originals[Index] := True; Props[Index] := Source.Props[Index]; if InLink then for I := LFont to HVFont do with FIArray.Ar[I] do case Index of FontFamily: begin S1 := ReadFontName(Props[FontFamily]); if S1 <> '' then iName := S1; end; FontSize: iSize := FontSizeConv(Props[FontSize], iSize); Color: iColor := Props[Color]; BackgroundColor: ibgColor := Props[BackgroundColor]; FontStyle: if (Props[FontStyle] = 'italic') or (Props[FontStyle] = 'oblique') then iStyle := iStyle + [fsItalic] else if Props[FontStyle] = 'normal' then iStyle := iStyle - [fsItalic]; FontWeight: if Pos('bold', Props[FontWeight]) > 0 then iStyle := iStyle + [fsBold] else if Pos('normal', Props[FontWeight]) > 0 then iStyle := iStyle - [fsBold] else begin Wt := StrToIntDef(Props[FontWeight], 0); if Wt >= 600 then iStyle := iStyle + [fsBold]; end; TextDecoration: if Props[TextDecoration] = 'underline' then iStyle := iStyle + [fsUnderline] else if Props[TextDecoration] = 'line-through' then iStyle := iStyle + [fsStrikeOut] else if Props[TextDecoration] = 'none' then iStyle := iStyle - [fsStrikeOut, fsUnderline]; LetterSpacing: iCharExtra := Props[LetterSpacing]; end; end else begin Props[Index] := Source.Props[Index]; Originals[Index] := True; {it's defined for this item, not inherited} end; end; end; function CheckForContextual(I: integer): boolean; {process contextual selectors} var J, K, N: integer; A: array[1..10] of record Tg, Cl, ID, PS: string; gt: boolean; end; MustMatchParent: Boolean; procedure Split(S: string); var I, J: integer; begin N := 1; {N is number of selectors in contextual string} I := Pos(' ', S); while (I > 0) and (N < 10) do begin A[N].Tg := System.Copy(S, 1, I-1); Delete(S, 1, I); S := Trim(S); Inc(N); I := Pos(' ', S); end; A[N].Tg := S; if (N >= 2) and (Length(A[2].Tg) > 0) then repeat Delete(A[2].Tg, 1, 1); {remove the sort digit} until (length(A[2].Tg)=0) or not (A[2].Tg[1] in ['0'..'9']); for I := 1 to N do begin J := Pos('>', A[I].Tg); if I > 1 then A[I-1].gt := J > 0; if J > 0 then Delete(A[I].Tg, J, 1); J := Pos(':', A[I].Tg); if J > 0 then begin A[I].PS := System.Copy(A[I].Tg, J+1, Length(A[I].Tg)); A[I].Tg := System.Copy(A[I].Tg, 1, J-1); end else A[I].PS := ''; J := Pos('#', A[I].Tg); if J > 0 then begin A[I].ID := System.Copy(A[I].Tg, J+1, Length(A[I].Tg)); A[I].Tg := System.Copy(A[I].Tg, 1, J-1); end else A[I].ID := ''; J := Pos('.', A[I].Tg); if J > 0 then begin A[I].Cl := System.Copy(A[I].Tg, J+1, Length(A[I].Tg)); A[I].Tg := System.Copy(A[I].Tg, 1, J-1); end else A[I].Cl := ''; end; end; function PartOf(const S1, S2: string): boolean; {see if all classes in S1 are present in S2. Classes are separated by '.'} var SL1, SL2: TStringList; J, X: integer; function FormStringList(S: string): TStringList; {construct a TStringList from classes in string S} var I: integer; begin Result := TStringList.Create; Result.Sorted := True; I := Pos('.', S); while I >= 1 do begin Result.Add(System.Copy(S, 1, I-1)); Delete(S, 1, I); I := Pos('.', S); end; Result.Add(S); end; begin {PartOf} SL1 := FormStringList(S1); try SL2 := FormStringList(S2); try Result := True; {assume all will be found} for J := 0 to SL1.Count-1 do If not SL2.Find(SL1[J], X) then begin Result := False; {one is missing, return False} Break; end; finally SL2.Free; end; finally SL1.Free; end; end; begin Result := False; Split(Styles[I]); //split contextual selectors into parts in array A if (A[1].Tg <> Tag) and (A[1].Cl <> AClass) and (A[1].PS <> PSeudo) then Exit else Result := True; if (N > 1) //it's a contextual selector. N is count of selectors and ((A[1].Tg = Tag) or (A[1].Tg = '')) and ((A[1].Cl = AClass) or (A[1].Cl = '')) and ((A[1].ID = AnID) or (A[1].ID = '')) and ((A[1].PS = PSeudo) or (A[1].PS = '') and (PSeudo = 'link')) then begin //look thru the stack to see if this contextual selector is appropriate K := 2; //K is selector index in the sequence J := PropStack.Count-2; // start on stack item below this one MustMatchParent := A[1].gt; while (K <= N) and (J >= 1) do begin with PropStack[J] do if ((A[K].Tg = PropTag) or (A[K].Tg = '')) and ((A[K].Cl = PropClass) or (A[K].Cl = '') or PartOf(A[K].Cl, PropClass)) and ((A[K].ID = PropID) or (A[K].ID = '')) and ((A[K].PS = PropPseudo) or (A[K].PS = '')) then begin if K = N then //all parts of contextual selector match Merge(Styles.Objects[I] as TProperties); MustMatchParent := A[K].gt; Inc(K); end else if MustMatchParent then Break; {Didn't match} Dec(J); end; end end; procedure MergeItems(Const Item: string); {look up items in the Style list. If found, merge them in this TProperties. Items may be duplicated in which case the last has priority. Items may be simple tags like 'p', 'blockquote', 'em', etc or they may be more complex like p.class, em#id, a.class:link, etc} var X: integer; begin if Styles.Find(Item, X) then begin Merge(Styles.Objects[X] as TProperties); Inc(X); while (X < Styles.Count) and (Styles[X] = Item) do begin //duplicates, last one has highest priority Merge(Styles.Objects[X] as TProperties); Inc(X); end; end; end; begin {$ifdef Quirk} if (Tag = 'td') or (Tag = 'th') then OldSize := DefPointSize else {$endif} if (VarType(Props[FontSize]) = VarDouble) and (Props[FontSize] > 0.0) then {should be true} OldSize := Props[FontSize] else OldSize := DefPointSize; {Some hover and visited items adequately taken care of when link processed} NoHoverVisited := (Pseudo = '') or ((Pseudo <> 'hover') and (Pseudo <> 'visited')); // in the following, lowest priority on top, highest towards bottom. if (Tag = 'a') and (Pseudo <> '') then MergeItems('::'+Pseudo); {default Pseudo definition} if NoHoverVisited then MergeItems(Tag); if Pseudo <> '' then MergeItems(':'+Pseudo); if (AClass <> '') and NoHoverVisited then MergeItems('.'+AClass); if (AClass <> '') and NoHoverVisited then MergeItems(Tag+'.'+AClass); if Pseudo <> '' then MergeItems(Tag+':'+Pseudo); if (AClass <> '') and (PSeudo <> '') then MergeItems('.'+AClass+':'+Pseudo); if (AClass <> '') and (Pseudo <> '') then MergeItems(Tag+'.'+AClass+':'+Pseudo); if AnID <> '' then begin MergeItems('#'+AnID); MergeItems(Tag+'#'+AnID); if (AClass <> '') then MergeItems('.'+AClass+'#'+AnID); if (Pseudo <> '') then begin MergeItems('#'+AnID+':'+Pseudo); MergeItems(Tag+'#'+AnID+':'+Pseudo); end; if (AClass <> '') then MergeItems(Tag+'.'+AClass+'#'+AnID); MergeItems('.'+AClass+'#'+AnID+':'+Pseudo); MergeItems(Tag+'.'+AClass+'#'+AnID+':'+Pseudo); end; {process the entries in Styles to see if they are contextual selectors} Styles.Find(Tag, IX); //place to start while (IX < Styles.Count) and (Pos(Tag, Styles[IX]) = 1) and CheckForContextual(IX) do Inc(IX); Styles.Find('.'+AClass, IX); //place to start while (IX < Styles.Count) and (Pos('.'+AClass, Styles[IX]) = 1) and CheckForContextual(IX) do Inc(IX); Styles.Find(':'+PSeudo, IX); //place to start while (IX < Styles.Count) and (Pos(':'+PSeudo, Styles[IX]) = 1) and CheckForContextual(IX) do Inc(IX); If Assigned(AProp) then //the Style= attribute Merge(AProp); if not ((VarType(Props[FontSize]) = VarDouble) or (VarType(Props[FontSize]) in varInt)) then {if still a string, hasn't been converted} Props[FontSize] := FontSizeConv(Props[FontSize], OldSize); end; function TProperties.GetFont: TMyFont; var Font: ThtFontInfo; Save: THandle; SaveCharSet: TFontCharSet; tm : TTextmetric; DC: HDC; V: Variant; begin {call only if all things valid} if not Assigned(TheFont) then begin Font := ThtFontInfo.Create; try GetSingleFontInfo(Font); TheFont := TMyFont.Create; with TheFont, Font do begin Name := iName; Height := -Round(iSize * Screen.PixelsPerInch / 72); Style := iStyle; bgColor := ibgColor; Color := iColor; Charset := iCharSet; V := iCharExtra; end; finally Font.Free; end; {if this is a Symbol charset, then keep it that way. To check the font's real charset, use Default_Charset} SaveCharSet := TheFont.CharSet; TheFont.CharSet := Default_Charset; DC := GetDC(0); try Save := SelectObject(DC, TheFont.Handle); try GetTextMetrics(DC, tm); finally SelectObject(DC, Save); end; if tm.tmCharset = Symbol_Charset then TheFont.Charset := Symbol_CharSet else TheFont.Charset := SaveCharSet; {now get the info on the finalized font} if TheFont.Charset <> Default_Charset then {else already have the textmetrics} begin Save := SelectObject(DC, TheFont.Handle); try GetTextMetrics(DC, tm); finally SelectObject(DC, Save); end; end; finally ReleaseDC(0, DC); end; {calculate EmSize with current font rather than inherited} EmSize := tm.tmHeight-tm.tmInternalLeading; ExSize := EmSize div 2; {apparently correlates with what browsers are doing} TheFont.tmHeight := tm.tmHeight; TheFont.tmDescent := tm.tmDescent; TheFont.tmExternalLeading := tm.tmExternalLeading; TheFont.tmMaxCharWidth := tm.tmMaxCharWidth; TheFont.tmAveCharWidth := tm.tmAveCharWidth; TheFont.tmCharset := tm.tmCharset; if VarType(V) in VarInt then TheFont.CharExtra := V else if VarType(V) = VarString then if V = 'normal' then TheFont.CharExtra := 0 else TheFont.CharExtra := LengthConv(V, False, EmSize, EmSize, ExSize, 0) else TheFont.CharExtra := 0; end; Result := TMyFont.Create; Result.Assign(TheFont); end; {----------------ReadFontName} function ReadFontName(S: string): string; const AMax = 5; var S1: string; Done: boolean; function NextFontName: string; const Generic1: array[1..AMax] of string = ('serif', 'monospace', 'sans-serif', 'cursive', 'Helvetica'); Generic2: array[1..AMax] of string = ('Times New Roman', 'Courier New', 'Arial', 'Lucida Handwriting', 'Arial'); var I: integer; begin I := Pos(',', S); {read up to the comma} if I > 0 then begin Result := Trim(System.Copy(S, 1, I-1)); Delete(S, 1, I); end else begin {last item} Result := Trim(S); S := ''; end; for I := 1 to AMax do if CompareText(Result, Generic1[I]) = 0 then begin Result := Generic2[I]; break; end; if (Result <> '') and (Result[Length(Result)] in ['"', '''']) then SetLength(Result, Length(Result)-1); if (Result <> '') and (Result[1] in ['"', '''']) then Delete(Result, 1, 1); end; begin Done := False; S1 := NextFontName; while (S1 <> '') and not Done do begin {$IFDEF LCL} //Generic2 fonts won't be in Screen.Fonts with GTK2, so make // sure first font for family is selected. if Result = '' then Result := S1; {$ENDIF} Done := Screen.Fonts.IndexOf(S1) >= 0; if Done then Result := S1 else S1 := NextFontName; end; end; {----------------TProperties.GetSingleFontInfo} procedure TProperties.GetSingleFontInfo(var Font: ThtFontInfo); const AMax = 5; var S, S1: string; Done: boolean; Wt: integer; Style: TFontStyles; function NextFontName: string; const Generic1: array[1..AMax] of string = ('serif', 'monospace', 'sans-serif', 'cursive', 'Helvetica'); Generic2: array[1..AMax] of string = ('Times New Roman', 'Courier New', 'Arial', 'Lucida Handwriting', 'Arial'); var I: integer; begin I := Pos(',', S); {read up to the comma} if I > 0 then begin Result := Trim(System.Copy(S, 1, I-1)); Delete(S, 1, I); end else begin {last item} Result := Trim(S); S := ''; end; for I := 1 to AMax do if CompareText(Result, Generic1[I]) = 0 then begin Result := Generic2[I]; break; end; if (Result <> '') and (Result[Length(Result)] in ['"', '''']) then SetLength(Result, Length(Result)-1); if (Result <> '') and (Result[1] in ['"', '''']) then Delete(Result, 1, 1); end; begin {call only if all things valid} Font.ibgColor := FontBG; Font.iColor := Props[Color]; Style := []; if Pos('bold', Props[FontWeight]) > 0 then Style := [fsBold] else begin Wt := StrToIntDef(Props[FontWeight], 0); if Wt >= 600 then Style := [fsBold]; end; if (Props[FontStyle] = 'italic') or (Props[FontStyle] = 'oblique') then Style := Style + [fsItalic]; if Props[TextDecoration] = 'underline' then Style := Style + [fsUnderline] else if Props[TextDecoration] = 'line-through' then Style := Style + [fsStrikeOut]; Font.iStyle := Style; Font.iSize := Props[FontSize]; Font.iCharset := CharSet; Font.iCharExtra := Props[LetterSpacing]; Done := False; S := Props[FontFamily]; S1 := NextFontName; while (S1 <> '') and not Done do begin {$IFDEF LCL} //Generic2 fonts won't be in Screen.Fonts with GTK2, so make // sure first font for family is selected. if Font.iName = '' then Font.iName := S1; {$ENDIF} Done := Screen.Fonts.IndexOf(S1) >= 0; if Done then begin Font.iName := S1; end else S1 := NextFontName; end; if Font.iName = '' then Font.iName := DefFontname; end; procedure TProperties.CalcLinkFontInfo(Styles: TStyleList; I: integer); {I is index in PropStack for this item} procedure InsertNewProp(N: integer; const Pseudo: string); begin PropStack.Insert(N, TProperties.Create); PropStack[N].Inherit('', PropStack[N-1]); PropStack[N].Combine(Styles, PropTag, PropClass, PropID, Pseudo, PropTitle, PropStyle); end; begin PropStack[I].SetFontBG; GetSingleFontInfo(FIArray.Ar[LFont]); InsertNewProp(I+1, 'visited'); PropStack[I+1].SetFontBG; PropStack[I+1].GetSingleFontInfo(FIArray.Ar[VFont]); InsertNewProp(I+2, 'hover'); PropStack[I+2].SetFontBG; PropStack[I+2].GetSingleFontInfo(FIArray.Ar[HVFont]); PropStack.Delete(I+2); PropStack.Delete(I+1); InsertNewProp(I+1, 'hover'); PropStack[I+1].SetFontBG; PropStack[I+1].GetSingleFontInfo(FIArray.Ar[HLFont]); PropStack.Delete(I+1); end; procedure TProperties.GetFontInfo(AFI: TFontInfoArray); begin AFI.Assign(FIArray); end; procedure TProperties.GetVMarginArray(var MArray: TVMarginArray); var I: PropIndices; begin for I := Low(Marray) to High(MArray) do case I of BorderTopStyle..BorderLeftStyle: if VarType(Props[I]) = VarString then MArray[I] := BorderStyleFromString(Props[I]) else MArray[I] := bssNone; else MArray[I] := Props[I]; end; end; procedure TProperties.AddPropertyByIndex(Index: PropIndices; PropValue: string); var NewColor: TColor; begin case Index of BorderColor: if ColorFromString(PropValue, False, NewColor) then begin Props[BorderColor] := NewColor; Props[BorderLeftColor] := NewColor; Props[BorderTopColor] := NewColor; Props[BorderRightColor] := NewColor; Props[BorderBottomColor] := NewColor; end; BorderTopColor .. BorderLeftColor: if ColorFromString(PropValue, False, NewColor) then Props[Index] := NewColor; Color, BackgroundColor: if ColorFromString(PropValue, False, NewColor) then Props[Index] := NewColor else if Index = Color then Props[Index] := clBlack else Props[Index] := clNone; MarginTop..BorderLeftWidth, Width..LeftPos: Props[Index] := PropValue; FontSize: Props[FontSize] := PropValue; Visibility: begin if PropValue = 'visible' then Props[Visibility] := viVisible else if PropValue = 'hidden' then Props[Visibility] := viHidden; end; TextTransform: begin if PropValue = 'uppercase' then Props[TextTransform] := txUpper else if PropValue = 'lowercase' then Props[TextTransform] := txLower else Props[TextTransform] := txNone; end; WordWrap: if PropValue = 'break-word' then Props[WordWrap] := PropValue else Props[WordWrap] := 'normal'; FontVariant: if PropValue = 'small-caps' then Props[FontVariant] := PropValue else if PropValue = 'normal' then Props[FontVariant] := 'normal'; BorderTopStyle..BorderLeftStyle: begin if PropValue <> 'none' then Props[BorderStyle] := PropValue; Props[Index] := PropValue; end; BorderStyle: begin Props[BorderStyle] := PropValue; Props[BorderTopStyle] := PropValue; Props[BorderRightStyle] := PropValue; Props[BorderBottomStyle] := PropValue; Props[BorderLeftStyle] := PropValue; end; else Props[Index] := PropValue; end; end; procedure TProperties.AddPropertyByName(const PropName, PropValue: string); var Index: PropIndices; begin if FindPropIndex(PropName, Index) then AddPropertyByIndex(Index, PropValue); end; constructor TStyleList.Create(AMasterList: TObject); begin inherited Create; MasterList := AMasterList; Sorted := True; Duplicates := dupAccept; SeqNo := 10; end; destructor TStyleList.Destroy; begin Clear; inherited Destroy; end; procedure TStyleList.Clear; var I: integer; begin for I := 0 to Count-1 do TProperties(Objects[I]).Free; SeqNo := 10; inherited; end; function TStyleList.GetSeqNo: string; begin {used to help sort contextual items by entry sequence} Result := IntToStr(SeqNo); Inc(SeqNo); end; {----------------TStyleList.AddModifyProp} procedure TStyleList.AddModifyProp(const Selector, Prop, Value: string); {strings are all lowercase here} var I: integer; PropIndex: PropIndices; Propty: TProperties; NewColor: TColor; NewProp: boolean; begin if FindPropIndex(Prop, PropIndex) then begin if not Find(Selector, I) then begin NewProp := True; Propty := TProperties.Create {newly created property} end else begin Propty := TProperties(Objects[I]); {modify existing property} NewProp := False; end; case PropIndex of Color: if ColorFromString(Value, False, NewColor) then begin if Selector = ':link' then begin {changed the defaults to be the same as link} ModifyLinkColor('hover', NewColor); ModifyLinkColor('visited', NewColor); end else if Selector = ':visited' then ModifyLinkColor('hover', NewColor); Propty.Props[PropIndex] := NewColor; end; BorderColor: if ColorFromString(Value, False, NewColor) then begin Propty.Props[BorderColor] := NewColor; Propty.Props[BorderLeftColor] := NewColor; Propty.Props[BorderTopColor] := NewColor; Propty.Props[BorderRightColor] := NewColor; Propty.Props[BorderBottomColor] := NewColor; end; BorderTopColor .. BorderLeftColor: if ColorFromString(Value, False, NewColor) then Propty.Props[PropIndex] := NewColor; BackgroundColor: if ColorFromString(Value, False, NewColor) then Propty.Props[PropIndex] := NewColor else Propty.Props[PropIndex] := clNone; Visibility: begin if Value = 'visible' then Propty.Props[Visibility] := viVisible else if Value = 'hidden' then Propty.Props[Visibility] := viHidden; end; TextTransform: begin if Value = 'uppercase' then Propty.Props[TextTransform] := txUpper else if Value = 'lowercase' then Propty.Props[TextTransform] := txLower else Propty.Props[TextTransform] := txNone; end; WordWrap: if Value = 'break-word' then Propty.Props[WordWrap] := Value else Propty.Props[WordWrap] := 'normal'; FontVariant: if Value = 'small-caps' then Propty.Props[FontVariant] := Value else if Value = 'normal' then Propty.Props[FontVariant] := 'normal'; BorderTopStyle..BorderLeftStyle: begin if Value <> 'none' then Propty.Props[BorderStyle] := Value; Propty.Props[PropIndex] := Value; end; BorderStyle: begin Propty.Props[BorderStyle] := Value; Propty.Props[BorderTopStyle] := Value; Propty.Props[BorderRightStyle] := Value; Propty.Props[BorderBottomStyle] := Value; Propty.Props[BorderLeftStyle] := Value; end; LineHeight: Propty.Props[PropIndex] := Value; else Propty.Props[PropIndex] := Value; end; if NewProp then AddObject(Selector, Propty); {it's a newly created property} if Pos(':hover', Selector) > 0 then TSectionList(MasterList).LinksActive := True; if Selector = 'a' then begin AddModifyProp('::link', Prop, Value); {also applies to ::link} end; {$ifdef Quirk} if (Selector = 'body') and (PropIndex = Color) then FixupTableColor(Propty); {$endif} end; end; {$ifdef Quirk} procedure TStyleList.FixupTableColor(BodyProp: TProperties); {if Quirk is set, make sure that the table color is defined the same as the body color} var Propty1: TProperties; I: integer; begin if Find('td', I) then begin Propty1 := TProperties(Objects[I]); Propty1.Props[Color] := BodyProp.Props[Color]; end; if Find('th', I) then begin Propty1 := TProperties(Objects[I]); Propty1.Props[Color] := BodyProp.Props[Color]; end; end; {$endif} function TStyleList.AddObject(const S: string; AObject: TObject): Integer; begin Result := inherited AddObject(S, AObject); TProperties(AObject).PropTag := S; end; function TStyleList.AddDuplicate(const Tag: string; Prop: TProperties): TProperties; begin Result := TProperties.Create; Result.Copy(Prop); AddObject(Tag, Result); end; procedure TStyleList.ModifyLinkColor(Psuedo: string; AColor: TColor); var I: integer; begin if Find('::'+Psuedo, I) then {the defaults} with TProperties(Objects[I]) do Props[Color] := AColor; end; procedure TStyleList.Initialize(const FontName, PreFontName: string; PointSize: integer; AColor, AHotspot, AVisitedColor, AActiveColor: TColor; LinkUnderline: boolean; ACharSet: TFontCharSet; MarginHeight, MarginWidth: integer); type ListTypes = (ul, ol, menu, dir, dl, dd, blockquote); const ListStr: array[Low(ListTypes)..High(ListTypes)] of string = ('ul', 'ol', 'menu', 'dir', 'dl', 'dd', 'blockquote'); var HIndex: integer; Properties: TProperties; J: ListTypes; F: double; begin Clear; DefPointSize := PointSize; Properties := TProperties.Create; with Properties do begin DefFontname := FontName; Props[FontFamily] := FontName; Props[FontSize] := PointSize*1.0; Props[FontStyle] := 'none'; Props[FontWeight] := 'normal'; Props[TextAlign] := 'left'; Props[TextDecoration] := 'none'; Props[TextTransform] := txNone; Props[WordWrap] := 'normal'; Props[FontVariant] := 'normal'; Props[Color] := AColor; Props[MarginTop] := MarginHeight; Props[MarginBottom] := MarginHeight; Props[MarginLeft] := MarginWidth; Props[MarginRight] := MarginWidth; Props[Visibility] := viVisible; Props[LetterSpacing] := 0; CharSet := ACharSet; end; AddObject('default', Properties); DefProp := Properties; {$ifdef Quirk} Properties := TProperties.Create; with Properties do begin Props[FontSize] := PointSize*1.0; Props[FontStyle] := 'none'; Props[FontWeight] := 'normal'; Props[Color] := AColor; end; AddObject('td', Properties); Properties := AddDuplicate('th', Properties); Properties.Props[FontWeight] := 'bold'; {$endif} Properties := TProperties.Create; with Properties do begin Props[Color] := AHotSpot or PalRelative; if LinkUnderline then Props[TextDecoration] := 'underline' else Props[TextDecoration] := 'none'; end; AddObject('::link', Properties); Properties := TProperties.Create; with Properties do Props[Color] := AVisitedColor or PalRelative; AddObject('::visited', Properties); Properties := TProperties.Create; with Properties do Props[Color] := AActiveColor or PalRelative; AddObject('::hover', Properties); Properties := TProperties.Create; AddObject('null', Properties); Properties := TProperties.Create; with Properties do begin Props[FontFamily] := PreFontName; Props[FontSize] := PointSize*10.0 / 12.0; Props[FontStyle] := 'none'; Props[FontWeight] := 'normal'; Props[TextDecoration] := 'none'; end; AddObject('pre', Properties); Properties := TProperties.Create; with Properties do begin Props[MarginTop] := AutoParagraph; Props[MarginBottom] := AutoParagraph; end; AddObject('p', Properties); Properties := TProperties.Create; with Properties do begin Props[MarginTop] := 0; end; AddObject('p 11pre', Properties); for J := Low(ListTypes) to High(ListTypes) do begin Properties := TProperties.Create; with Properties do begin Props[PaddingLeft] := 35; Props[MarginTop] := 0; Props[MarginBottom] := 0; case J of ol, ul, menu, dir: begin Props[ListStyleType] := 'blank'; Props[MarginTop] := AutoParagraph; Props[MarginBottom] := AutoParagraph; end; dl: begin Props[MarginLeft] := 0; Props[PaddingLeft] := 0; Props[ListStyleType] := 'none'; end; blockquote: begin Props[MarginTop] := AutoParagraph; Props[MarginBottom] := ParagraphSpace; end; dd: ; end; end; AddObject(ListStr[J], Properties); end; Properties := TProperties.Create; with Properties do begin Props[FontFamily] := PrefontName; Props[FontSize] := '0.833em'; {10.0 / 12.0;} end; AddObject('code', Properties); AddDuplicate('tt', Properties); AddDuplicate('kbd', Properties); AddDuplicate('samp', Properties); Properties := TProperties.Create; with Properties do begin Props[FontWeight] := 'bold'; end; AddObject('b', Properties); AddDuplicate('strong', Properties); {$ifndef Quirk} AddDuplicate('th', Properties); {$endif} Properties := TProperties.Create; with Properties do begin Props[FontSize] := '75%'; Props[VerticalAlign] := 'super'; end; AddObject('sup', Properties); Properties := TProperties.Create; with Properties do begin Props[FontSize] := '75%'; Props[VerticalAlign] := 'sub'; end; AddObject('sub', Properties); Properties := TProperties.Create; with Properties do begin Props[FontSize] := '1.25em'; end; AddObject('big', Properties); Properties := TProperties.Create; with Properties do begin Props[FontSize] := '0.75em'; end; AddObject('small', Properties); Properties := TProperties.Create; with Properties do begin Props[TextAlign] := 'none'; end; AddObject('table', Properties); Properties := TProperties.Create; with Properties do begin Props[FontStyle] := 'italic'; end; AddObject('i', Properties); AddDuplicate('em', Properties); AddDuplicate('cite', Properties); AddDuplicate('var', Properties); AddDuplicate('address', Properties); Properties := TProperties.Create; with Properties do begin Props[TextDecoration] := 'underline'; end; AddObject('u', Properties); Properties := TProperties.Create; with Properties do begin Props[TextDecoration] := 'line-through'; end; AddObject('s', Properties); AddDuplicate('strike', Properties); Properties := TProperties.Create; with Properties do begin Props[TextAlign] := 'center'; end; AddObject('center', Properties); AddDuplicate('caption', Properties); Properties := TProperties.Create; with Properties do begin Props[FontFamily] := 'Arial Unicode MS, Arial'; Props[FontSize] := '10pt'; Props[FontStyle] := 'none'; Props[FontWeight] := 'normal'; Props[TextAlign] := 'left'; Props[TextDecoration] := 'none'; Props[Color] := AColor; end; AddObject('input', Properties); AddDuplicate('select', Properties); Properties := AddDuplicate('textarea', Properties); if IsWin32Platform then Properties.Props[FontFamily] := 'Arial Unicode MS, Arial' else Properties.Props[FontFamily] := PreFontName; Properties := TProperties.Create; with Properties do begin Props[MarginLeft] := 0; Props[MarginRight] := 0; Props[MarginTop] := 10; Props[MarginBottom] := 10; end; AddObject('hr', Properties); for HIndex := 1 to 6 do begin Properties := TProperties.Create; F := PointSize / 12.0; with Properties do begin case HIndex of 1: Props[FontSize] := 24.0*F; 2: Props[FontSize] := 18.0*F; 3: Props[FontSize] := 14.0*F; 4: Props[FontSize] := 12.0*F; 5: Props[FontSize] := 10.0*F; 6: Props[FontSize] := 8.0*F; end; Props[MarginTop] := 19; Props[MarginBottom] := Props[MarginTop]; Props[FontWeight] := 'bold'; end; AddObject('h'+IntToStr(HIndex), Properties); end; end; const NumColors = 177; //176; Colors: array[1..NumColors] of string[20] = ('transparent', 'black', 'maroon', 'green', 'olive', 'navy', 'purple', 'teal', 'gray', 'silver', 'red', 'lime', 'yellow', 'blue', 'fuchsia', 'aqua', 'white', 'aliceblue', 'antiquewhite', 'aquamarine', 'azure', 'beige', 'bisque', 'blanchedalmond', 'blueviolet', 'brown', 'burlywood', 'cadetblue', 'chartreuse', 'chocolate', 'coral', 'cornflowerblue', 'cornsilk', 'crimson', 'cyan', 'darkblue', 'darkcyan', 'darkgoldenrod', 'darkgray', 'darkgreen', 'darkkhaki', 'darkmagenta', 'darkolivegreen', 'darkorange', 'darkorchid', 'darkred', 'darksalmon', 'darkseagreen', 'darkslateblue', 'darkslategray', 'darkturquoise', 'darkviolet', 'deeppink', 'deepskyblue', 'dimgray', 'dodgerblue', 'firebrick', 'floralwhite', 'forestgreen', 'gainsboro', 'ghostwhite', 'gold', 'goldenrod', 'greenyellow', 'honeydew', 'hotpink', 'indianred', 'indigo', 'ivory', 'khaki', 'lavender', 'lavenderblush', 'lawngreen', 'lemonchiffon', 'lightblue', 'lightcoral', 'lightcyan', 'lightgoldenrodyellow', 'lightgreen', 'lightgray', 'lightpink', 'lightsalmon', 'lightseagreen', 'lightskyblue', 'lightslategray', 'lightsteelblue', 'lightyellow', 'limegreen', 'linen', 'magenta', 'mediumaquamarine', 'mediumblue', 'mediumorchid', 'mediumpurple', 'mediumseagreen', 'mediumslateblue', 'mediumspringgreen', 'mediumturquoise', 'mediumvioletred', 'midnightblue', 'mintcream', 'mistyrose', 'moccasin', 'navajowhite', 'oldlace', 'olivedrab', 'orange', 'orangered', 'orchid', 'palegoldenrod', 'palegreen', 'paleturquoise', 'palevioletred', 'papayawhip', 'peachpuff', 'peru', 'pink', 'plum', 'powderblue', 'rosybrown', 'royalblue', 'saddlebrown', 'salmon', 'sandybrown', 'seagreen', 'seashell', 'sienna', 'skyblue', 'slateblue', 'slategray', 'snow', 'springgreen', 'steelblue', 'tan', 'thistle', 'tomato', 'turquoise', 'violet', 'wheat', 'whitesmoke', 'yellowgreen', 'darkyellow', 'grey', 'darkgrey', 'darkslategrey', 'dimgrey', 'lightgrey', 'lightslategrey', 'slategrey', 'background', 'activecaption', 'inactivecaption', 'menu', 'window', 'windowframe', 'menutext', 'windowtext', 'captiontext', 'activeborder', 'inactiveborder', 'appworkSpace', 'highlight', 'hightlighttext', 'buttonface', 'buttonshadow', 'graytext', 'buttontext', 'inactivecaptiontext', 'buttonhighlight', 'threeddarkshadow', 'threedlightshadow', 'infotext', 'infobackground', 'scrollbar', 'threedface', 'threedhighlight', 'threedshadow'); ColorValues: array[1..NumColors] of TColor = (clNone, clBLACK, clMAROON, clGREEN, clOLIVE, clNAVY, clPURPLE, clTEAL, clGRAY, clSILVER, clRED, clLIME, clYELLOW, clBLUE, clFUCHSIA, clAQUA, clWHITE, $FFF8F0, $D7EBFA, $D4FF7F, $FFFFF0, $DCF5F5, $C4E4FF, $CDEBFF, $E22B8A, $2A2AA5, $87B8DE, $A09E5F, $00FF7F, $1E69D2, $507FFF, $ED9564, $DCF8FF, $3614DC, $FFFF00, $8B0000, $8B8B00, $0B86B8, $A9A9A9, $006400, $6BB7BD, $8B008B, $2F6B55, $008CFF, $CC3299, $00008B, $7A96E9, $8FBC8F, $8B3D48, $4F4F2F, $D1CE00, $D30094, $9314FF, $FFBF00, $696969, $FF901E, $2222B2, $F0FAFF, $228B22, $DCDCDC, $FFF8F8, $00D7FF, $20A5DA, $2FFFAD, $F0FFF0, $B469FF, $5C5CCD, $82004B, $F0FFFF, $8CE6F0, $FAE6E6, $F5F0FF, $00FC7C, $CDFAFF, $E6D8AD, $8080F0, $FFFFE0, $D2FAFA, $90EE90, $D3D3D3, $C1B6FF, $7AA0FF, $AAB220, $FACE87, $998877, $DEC4B0, $E0FFFF, $32CD32, $E6F0FA, $FF00FF, $AACD66, $CD0000, $D355BA, $DB7093, $71B33C, $EE687B, $9AFA00, $CCD148, $8515C7, $701919, $FAFFF5, $E1E4FF, $B5E4FF, $ADDEFF, $E6F5FD, $238E6B, $00A5FF, $0045FF, $D670DA, $AAE8EE, $98FB98, $EEEEAF, $9370DB, $D5EFFF, $B9DAFF, $3F85CD, $CBC0FF, $DDA0DD, $E6E0B0, $8F8FBC, $E16941, $13458B, $7280FA, $60A4F4, $578B2E, $EEF5FF, $2D52A0, $EBCE87, $CD5A6A, $908070, $FAFAFF, $7FFF00, $B48246, $8CB4D2, $D8BFD8, $4763FF, $D0E040, $EE82EE, $B3DEF5, $F5F5F5, $32CD9A, $008080, // added clgray, $A9A9A9, $4F4F2F, $696969, $D3D3D3, $998877, $908070, clBackground, clActiveCaption, clInactiveCaption, clMenu, clWindow, clWindowFrame, clMenuText, clWindowText, clCaptionText, clActiveBorder, clInactiveBorder, clAppWorkSpace, clHighlight, clHighlightText, clBtnFace, clBtnShadow, clGrayText, clBtnText, clInactiveCaptionText, clBtnHighlight, cl3DDkShadow, clBtnHighlight, clInfoText, clInfoBk, clScrollBar, clBtnFace, cl3DLight, clBtnShadow); var ColorStrings: TStringList; procedure SortColors; var I: integer; begin // Put the Colors into a sorted StringList for faster access. if ColorStrings = nil then begin ColorStrings := TStringList.Create; with ColorStrings do begin for I := 1 to NumColors do ColorStrings.AddObject(Colors[I], Pointer(ColorValues[I])); Sort; end; end; end; {Translate StyleSheet color string to Color. If NeedPound is true, a '#' sign is required to preceed a hexidecimal value.} function ColorFromString(S: string; NeedPound: boolean; var Color: TColor): boolean; const LastS: string = '?&%@'; LastColor: TColor = 0; var I, Rd, Bl: integer; S1: string; function FindRGBColor(S: string): boolean; type Colors = (red, green, blue); var A: array[red..blue] of string; C: array[red..blue] of integer; I, J: integer; K: Colors; begin I := Pos('(', S); J := Pos(')', S); if (I > 0) and (J > 0) then begin S := copy(S, 1, J-1); S := Trim(Copy(S, I+1, 255)); for K := Red to Green do begin I := Pos(',', S); A[K] := Trim(copy(S, 1, I-1)); S := Trim(Copy(S, I+1, 255)); end; A[Blue] := S; for K := Red to Blue do begin I := Pos('%', A[K]); if I > 0 then begin Delete(A[K], I, 1); try C[K] := Round(StrToFloat(A[K]) * 2.55); except C[K] := 0; end; end else C[K] := StrToIntDef(A[K], 0); C[K] := IntMax(0, IntMin(255, C[K])); end; Color := (C[Blue] shl 16) or (C[Green] shl 8) or C[Red]; Result := True; end else Result := False; end; begin if S = '' then begin Result := False; Exit; end; S := Lowercase(Trim(S)); if S = LastS then begin {inquiries often come in pairs, this saves some recomputing} Color := LastColor; Result := True; Exit; end; if (Length(S) > 0) and (S[1] <> '#') and (Pos('rgb(', S) = 0) then if ColorStrings.Find(S, I) then begin Color := TColor(ColorStrings.Objects[I]); Result := True; LastS := S; LastColor := Color; Exit; end; S1 := S; I := Pos('rgb', S); if (I > 0) then Result := FindRGBColor(Copy(S, I+3, 255)) else begin try I := Pos('#', S); if I > 0 then while I > 0 do {sometimes multiple ##} begin Delete(S, 1, I); I := Pos('#', S); end else if NeedPound then begin Result := False; Exit; end; S := Trim(S); if Length(S) <= 3 then for I := Length(S) downto 1 do Insert(S[I], S, I); {double each character} Color := StrToInt('$'+S); {but bytes are backwards!} Rd := Color and $FF; Bl := Color and $FF0000; Color := (Color and $00FF00) + (Rd shl 16) + (Bl shr 16) or PalRelative; Result := True; except Result := False; end; end; if Result then begin LastS := S1; LastColor := Color; end; end; { TFontInfoArray } constructor TFontInfoArray.Create; var I: FIIndex; begin inherited Create; for I := LFont to HVFont do Ar[I] := ThtFontInfo.Create; end; destructor TFontInfoArray.Destroy; var I: FIIndex; begin for I := LFont to HVFont do Ar[I].Free; inherited; end; procedure TFontInfoArray.Assign(Source: TFontInfoArray); var I: FIIndex; begin for I := LFont to HVFont do begin Ar[I].iName := Source.Ar[I].iName; Ar[I].iSize := Source.Ar[I].iSize; Ar[I].iStyle := Source.Ar[I].iStyle; Ar[I].iColor := Source.Ar[I].iColor; Ar[I].ibgColor := Source.Ar[I].ibgColor; Ar[I].iCharSet := Source.Ar[I].iCharSet; Ar[I].iCharExtra := Source.Ar[I].iCharExtra; end; end; {$HINTS OFF} {----------------FontSizeConv} function FontSizeConv(const Str: string; OldSize: double): double; {given a font-size string, return the point size} var V, PPI: double; S1, S2: string; I, J: integer; begin PPI := Screen.PixelsPerInch; Val(Str, V, I); J := Pos('e', Str); {'e' would be legal for Val but not for us} if (J <> 0) and (I > J) then I := J; if I > 0 then begin S1 := Copy(Str, 1, I-1); S2 := Trim(Copy(Str, I, Length(Str)-I+1)); end else begin S1 := Str; S2 := ''; end; {S1 has the number, S2 the units} Val(S1, V, I); if S2 = 'in' then V := 72.0*V else if S2 = 'cm' then V := 72.0*V/2.54 else if S2 = 'mm' then V := 72.0*V/25.4 else if S2 = 'pt' then else if S2 = 'px' then V := V*72.0/PPI else if S2 = 'pc' then V := V*12.0 else if S2 = 'em' then V := V*OldSize else if S2 = 'ex' then V := V*OldSize/2.0 {1/2 of em} else if S2 = '%' then V := V*OldSize/100.0 else if S2 = '' then V := V*72.0/PPI {pixels by default} else if S2 = 'smaller' then V := 0.75*OldSize else if S2 = 'larger' then V := 1.25*OldSize else if S2 = 'xx-small' then V := DefPointSize/1.5 else if S2 = 'x-small' then V := DefPointSize/1.2 else if S2 = 'small' then V := DefPointSize else if S2 = 'medium' then V := DefPointSize*1.2 else if S2 = 'large' then V := DefPointSize*1.5 else if S2 = 'x-large' then V := DefPointSize*2.0 else if S2 = 'xx-large' then V := DefPointSize*3.0 else V := DefPointSize; {error, return 12pt} Result := V; end; {----------------LengthConv} function LengthConv(const Str: string; Relative: boolean; Base, EmSize, ExSize, Default: integer): integer; {given a length string, return the appropriate pixel value. Base is the base value for percentage. EmSize, ExSize for units relative to the font. Relative makes a numerical entry relative to Base. Default returned if no match.} var V, PPI: double; S1, S2: string; I, J: integer; begin PPI := Screen.PixelsPerInch; Val(Str, V, I); J := Pos('e', Str); {'e' would be legal for Val but not for us} if (J <> 0) and (I > J) then I := J; if I > 0 then begin S1 := Copy(Str, 1, I-1); S2 := Trim(Copy(Str, I, Length(Str)-I+1)); end else begin S1 := Str; S2 := ''; end; {S1 has the number, S2 the units} Val(S1, V, I); if S2 = 'in' then V := PPI*V else if S2 = 'cm' then V := PPI*V/2.54 else if S2 = 'mm' then V := PPI*V/25.4 else if S2 = 'pt' then V := V*PPI/72.0 else if S2 = 'px' then else if S2 = 'pc' then V := V*PPI/6.0 else if S2 = 'em' then V := V*EmSize else if S2 = 'ex' then V := V*ExSize else if S2 = '%' then V := V*Base/100.0 else if S2 = '' then if Relative then V := V*Base {relative} else V := V {same as pixels, at least for margins} else V := Default; Result := Round(V); end; Initialization SortColors; Finalization ColorStrings.Free; end.