htmlsbs1.pas

查看html文件的控件

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

{$i htmlcons.inc}       

unit Htmlsbs1;

interface
uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, ExtCtrls, HTMLUn2, HTMLGif2, HTMLSubs, StyleUn;

Type

  TPage = class(TSectionBase)
  public
    function Draw1(Canvas: TCanvas; const ARect: TRect;
         IMgr: IndentManager; X, XRef, YRef : integer) : integer;  override;
    end;

  THorzLine = class(TSectionBase)          {a horizontal line, <hr>}
    VSize: integer;
    Color: TColor;
    Align: JustifyType;
    NoShade: boolean;
    BkGnd: boolean;
    Width, Indent: integer;   

    constructor Create(AMasterList: TSectionList; L: TAttributeList; Prop: TProperties);
    constructor CreateCopy(AMasterList: TSectionList; T: TSectionBase); override;
    procedure CopyToClipboard; override;
    function DrawLogic(Canvas : TCanvas; X, Y, XRef, YRef, AWidth, AHeight, BlHt: integer; IMgr: IndentManager;
             var MaxWidth: integer; var Curs: integer): integer; override;
    function Draw1(Canvas: TCanvas; const ARect: TRect;
         IMgr: IndentManager; X, XRef, YRef : integer) : integer;  override;
    end;

   TPreFormated = class(TSection)
  {section for preformated, <pre>}
  public
    procedure ProcessText(TagIndex: integer); override; 
    function DrawLogic(Canvas : TCanvas; X, Y, XRef, YRef, AWidth, AHeight, BlHt: integer; IMgr: IndentManager;
             var MaxWidth: integer; var Curs: integer): integer; override;
    procedure MinMaxWidth(Canvas: TCanvas; var Min, Max: integer); override;
    end;

  TOptionObj = class(TObject)   {used by TListBoxFormControlObj for <option> information}
  public
    Value: String;            {<option>  Value=  }
    Selected: boolean;        {set if Selected found in <option>}
    Attributes: TStringList;  {list of <option> attributes}
    destructor Destroy; override;
  end;


  ThtOptionStringList = class(TStringList)    
  private
    function GetValue(Index: integer): string;
    function GetSelected(Index: integer): boolean;
    procedure SetSelected(Index: integer; Value: boolean);
    function GetAttribute(Index: integer; const AttrName: string): string;
  public
    property Value[Index: integer]: string read GetValue;
    property Selected[Index: integer]: boolean read GetSelected write SetSelected;
    property AttributeValue[Index: integer; const AttrName: string]: string read GetAttribute;
    destructor Destroy; override;
  end;

  TListBoxFormControlObj = class(TFormControlObj)
  {Select with "Multiple" or Size > 1}
  private
    LBSize, Longest: integer;
    TheFont: TFont;
  private
    EnterItems: integer;
    EnterSelected: array[0..50] of boolean;
    {$ifdef OpOnChange}
    procedure OptionalOnChange(Sender: TObject);     
    {$endif}
  protected
    procedure DoOnChange; override;
    procedure SaveContents; override;
  public
    TheOptions: ThtOptionStringList;
    {TheOptions is the original Options list for reseting.  It does not reflect
     the current selected state.  The Strings part is the Items in the list/combobox.
     The Options part is TOptionObj defined above}

    constructor Create(AMasterList: TSectionList; Position: integer;
                     L: TAttributeList; Prop: TProperties);
    destructor Destroy; override;
    procedure ProcessProperties(Prop: TProperties); override;
    procedure Draw(Canvas: TCanvas; X1, Y1: integer); override;
    procedure AddStr(const WS: WideString; Selected: boolean; Attr: TStringList;
                 CodePage: integer);
    procedure ResetToValue; override;
    procedure SetHeightWidth(Canvas: TCanvas); override;
    function GetSubmission(Index: integer; var S: string): boolean; override;
    procedure SetData(Index: integer; const V: String); override;
  end;

  TComboFormControlObj = class(TListBoxFormControlObj)
  {Select with single selection and Size = 1}
  private
    EnterIndex: integer;
    {$ifdef OpOnChange}
    procedure OptionalOnChange(Sender: TObject);   
    {$endif}
  protected
    procedure DoOnChange; override;
    procedure SaveContents; override;
  public
    constructor Create(AMasterList: TSectionList; Position: integer;
                  L: TAttributeList; Prop: TProperties);
    procedure ProcessProperties(Prop: TProperties); override;
    procedure Draw(Canvas: TCanvas; X1, Y1: integer); override;
    procedure ResetToValue; override;
    procedure SetHeightWidth(ACanvas: TCanvas); override;
    function GetSubmission(Index: integer; var S: string): boolean; override;
    procedure SetData(Index: integer; const V: String); override;
  end;

  TTextAreaFormControlObj = class(TFormControlObj)
  private
    EnterContents: string;
  protected
    procedure DoOnChange; override;
    procedure SaveContents; override;
  public
    Wrap: (wrOff, wrSoft, wrHard);
    Rows, Cols: integer;
    TheText: string;
    constructor Create(AMasterList: TSectionList; Position: integer;
                   L: TAttributeList; Prop: TProperties);
    destructor Destroy; override;
    procedure ProcessProperties(Prop: TProperties);  override;
    procedure Draw(Canvas: TCanvas; X1, Y1: integer); override;
    procedure AddStr(const S: string);
    procedure ResetToValue; override;
    procedure SetHeightWidth(Canvas: TCanvas); override;
    function GetSubmission(Index: integer; var S: string): boolean; override;
    procedure SetData(Index: integer; const V: String); override;
  end;

  TFormControlList = class(TList)  {a list of TFormControlObj's}  {not TFreeList}
  Public
    function FindControl(Posn: integer): TFormControlObj;
    function GetHeightAt(Posn: integer; var FormAlign: AlignmentType) : Integer;
    function GetWidthAt(Posn: integer; var HSpcL, HSpcR: integer) : integer;
    function GetControlCountAt(Posn: integer): integer;
    procedure Decrement(N: integer);
    end;

Implementation

uses
  {$ifdef Delphi6_Plus}
  Variants,
  {$endif}
  ReadHTML, HTMLView;

{----------------TPage.Draw1}
function TPage.Draw1(Canvas: TCanvas; const ARect: TRect;
         IMgr: IndentManager; X, XRef, YRef : integer) : integer;
var
  YOffset, Y: integer;
begin
Result := inherited Draw1(Canvas, ARect, Imgr, X, XRef, YRef);
Y := YDraw;

with ParentSectionList do
  if Printing then
    begin
    YOffset := YOff;
    if (Y-YOffset > ARect.Top+5) and (Y-YOffset < ARect.Bottom) and
         (Y < PageBottom) then
      PageBottom := Y;
    end;
end;

{----------------THorzLine.Create}
constructor THorzLine.Create(AMasterList: TSectionList; L: TAttributeList;
                Prop: TProperties);
var
  LwName: string[10];
  I: integer;
  TmpColor: TColor;
begin
inherited Create(AMasterList);
VSize := 2;
Align := Centered;
Color := clNone;
for I := 0 to L.Count-1 do
  with TAttribute(L[I]) do
    case Which of
      SizeSy: if (Value > 0) and (Value <= 20) then
        begin
        VSize := Value;
        end;
      WidthSy:
        if Value > 0 then
          if Pos('%', Name) > 0 then
            begin
            if (Value <= 100) then
              Prop.Assign(IntToStr(Value)+'%', StyleUn.Width);
            end
          else
            Prop.Assign(Value, StyleUn.Width);
      ColorSy: if ColorFromString(Name, False, Color) then
                 Prop.Assign(Color, StyleUn.Color);
      AlignSy:
        begin
        LwName := Lowercase(Name);
        if LwName = 'left' then Align := Left
        else if LwName = 'right' then Align := Right;
        end;
      NoShadeSy: NoShade := True;
      end;

Prop.Assign(VSize, StyleUn.Height); {assigns if no property exists yet}
TmpColor := Prop.GetOriginalForegroundColor;
if TmpColor <> clNone then
  Color := TmpColor;
with Prop do
  if (varType(Props[TextAlign]) = VarString) and Originals[TextAlign] then
    if Props[TextAlign] = 'left' then
      Align := Left
    else if Props[TextAlign] = 'right' then
      Align := Right
    else if Props[TextAlign] = 'center' then
      Align := Centered;
end;

constructor THorzLine.CreateCopy(AMasterList: TSectionList; T: TSectionBase);
begin
inherited Create(AMasterList);
System.Move((T as THorzline).VSize, VSize, DWord(@BkGnd)-DWord(@VSize)+Sizeof(BkGnd));
end;

procedure THorzLine.CopyToClipboard;
begin
ParentSectionList.CB.AddTextCR('', 0);
end;

function THorzLine.DrawLogic(Canvas : TCanvas; X, Y, XRef, YRef, AWidth, AHeight, BlHt: integer; IMgr: IndentManager;
             var MaxWidth: integer; var Curs: integer): integer;
begin
YDraw := Y;
StartCurs := Curs;
{Note: VSize gets updated in THRBlock.FindWidth}
ContentTop := Y;
DrawTop := Y;
Indent := IntMax(X, IMgr.LeftIndent(Y));
Width := IntMin(X + AWidth - Indent, IMgr.RightSide(Y)-Indent);
MaxWidth := Width;
SectionHeight := VSize;
DrawHeight := SectionHeight;
ContentBot := Y+SectionHeight;
DrawBot := Y+DrawHeight;
Result := SectionHeight;
end;

{----------------THorzLine.Draw}
function THorzLine.Draw1(Canvas: TCanvas; const ARect: TRect;
     IMgr: IndentManager; X, XRef, YRef : integer) : integer;
var
  XR: integer;
  YT, YO, Y: integer;
  White, BlackBorder: boolean;
begin
Y := YDraw;  
Result := inherited Draw1(Canvas, ARect, IMgr, X, XRef, YRef);
YO := Y - ParentSectionList.YOff;
if (YO+SectionHeight >= ARect.Top) and (YO < ARect.Bottom) and
       (not ParentSectionList.Printing or (Y < ParentSectionList.PageBottom)) then
  with Canvas do
    begin
    YT := YO;
    XR := X+Width-1;
    if Color <> clNone then
      begin
      Brush.Color := Color or $2000000;
      Brush.Style := bsSolid;
      FillRect(Rect(X, YT, XR+1, YT+VSize));
      end
    else
      begin
      with ParentSectionList do
        begin
        White := Printing or ((Background and $FFFFFF = clWhite) or
            ((Background = clWindow) and (GetSysColor(Color_Window) = $FFFFFF)));
        BlackBorder := NoShade or (Printing and (GetDeviceCaps(Handle, BITSPIXEL) = 1) and
            (GetDeviceCaps(Handle, PLANES) = 1));
        end;
      if BlackBorder then              
        Pen.Color := clBlack
      else if White then
        Pen.Color := clSilver
      else Pen.Color := clBtnHighLight;
      MoveTo(XR, YT);
      LineTo(XR, YT+VSize-1);
      LineTo(X, YT+VSize-1);
      if BlackBorder then Pen.Color := clBlack
        else Pen.Color := clBtnShadow;
      LineTo(X, YT);
      LineTo(XR, YT);
      end;
    ParentSectionList.FirstPageItem := False;     {items after this will not be first on page}
    end;
end;

procedure TPreformated.ProcessText(TagIndex: integer);
var
  FO: TFontObj;   
begin
FO := TFontObj(Fonts.Items[Fonts.Count-1]);    {keep font the same for inserted space}
if FO.Pos = Length(BuffS) then   
  Inc(FO.Pos);
BuffS := BuffS+' ';
XP^[Length(BuffS)-1] := XP^[Length(BuffS)-2]+1;
Finish;
end;

procedure TPreformated.MinMaxWidth(Canvas: TCanvas; var Min, Max: integer);
begin
if BreakWord then  
  begin
  inherited;
  Exit;
  end;
if Len = 0 then
  begin
  Max := 0;
  Min := 0;
  end
else
  begin
  if StoredMax = 0 then  
    begin
    Max := FindTextWidth(Canvas, Buff, Len-1, False);  
    StoredMax := Max;
    end
  else Max := StoredMax;  
  Min := IntMin(2000, Max);   {arbitrary selection}   
  end;
end;

function TPreFormated.DrawLogic(Canvas : TCanvas; X, Y, XRef, YRef, AWidth, AHeight, BlHt: integer; IMgr: IndentManager;
             var MaxWidth: integer; var Curs: integer): integer;
var
  Dummy: integer;
  Save: integer;
begin
if Len = 0 then
  begin
  ContentTop := Y;
  Result := Fonts.GetFontObjAt(0, Dummy).FontHeight;
  SectionHeight := Result;
  MaxWidth := 0;
  YDraw := Y;   
  DrawHeight := Result;   
  ContentBot := Y+Result;  
  DrawBot := ContentBot;    
  end
else if not BreakWord then   
  begin
  {call with large width to prevent wrapping}