styleun.pas

查看html文件的控件

{Version 9.4}
{*********************************************************}
{*                     STYLEUN.PAS                       *}
{*              Copyright (c) 2001 - 2006 by             *}
{*                   L. David Baldwin                    *}
{*                 All rights reserved.                  *}
{*********************************************************}

{$i htmlcons.inc}
                                  
unit StyleUn;

interface

uses
  Windows, Messages, SysUtils, Classes, 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, 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', '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 }