mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-05-18 11:42:40 +02:00
5930 lines
171 KiB
ObjectPascal
5930 lines
171 KiB
ObjectPascal
{Version 7.5}
|
|
{*********************************************************}
|
|
{* LITESUBS.PAS *}
|
|
{* Copyright (c) 1995-2002 by *}
|
|
{* L. David Baldwin *}
|
|
{* All rights reserved. *}
|
|
{*********************************************************}
|
|
|
|
{$i LiteCons.inc}
|
|
|
|
{
|
|
This module is comprised mostly of the various Section object definitions.
|
|
As the HTML document is parsed, it is divided up into sections. Some sections
|
|
are quite simple, like TParagraphSpace. Others are more complex such as
|
|
TSection which can hold a complete paragraph.
|
|
|
|
The HTML document is then stored as a list, TSectionList, of the various
|
|
sections.
|
|
|
|
Closely related to TSectionList is TCell. TCell holds the list of sections for
|
|
each cell in a Table (the ThtmlTable section). In this way each table cell may
|
|
contain a document of it's own.
|
|
|
|
The Section objects each store relevant data for the section such as the text,
|
|
fonts, images, and other info needed for formating.
|
|
|
|
Each Section object is responsible for its own formated layout. The layout is
|
|
done in the DrawLogic method. Layout for the whole document is done in the
|
|
TSectionList.DoLogic method which essentially just calls all the Section
|
|
DrawLogic's. It's only necessary to call TSectionList.DoLogic when a new
|
|
layout is required (when the document is loaded or when its width changes).
|
|
|
|
Each Section is also responsible for drawing itself (its Draw method). The
|
|
whole document is drawn with the TSectionList.Draw method.
|
|
}
|
|
|
|
unit LiteSubs;
|
|
|
|
{$IFNDEF HL_LAZARUS}
|
|
{$R HTML32.Res}
|
|
{$ENDIF not HL_LAZARUS}
|
|
|
|
interface
|
|
uses
|
|
{$IFDEF HL_LAZARUS}
|
|
Classes, SysUtils, VCLGlobals, LCLType, LCLLinux, Messages,
|
|
GraphType, Graphics, Controls, Forms, Dialogs, Buttons, StdCtrls, ExtCtrls,
|
|
LiteUn2, LiteGif2;
|
|
{$ELSE}
|
|
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
|
|
Forms, Dialogs, StdCtrls, ExtCtrls, LiteUn2, LiteGif2, mmSystem;
|
|
{$ENDIF}
|
|
|
|
const
|
|
MaxCols = 200; {number columns allowed in table}
|
|
|
|
type
|
|
TGetImageEvent = procedure(Sender: TObject; const SRC: string;
|
|
var Stream: TMemoryStream) of Object;
|
|
TFormSubmitEvent = procedure(Sender: TObject; const Action, Target, EncType, Method: string;
|
|
Results: TStringList) of Object;
|
|
TObjectClickEvent = procedure(Sender, Obj: TObject; const OnClick: string) of Object;
|
|
TExpandNameEvent = procedure(Sender: TObject; const SRC: string; var Result: string) of Object;
|
|
SubSuperType = (Normal, SubSc, SupSc);
|
|
TCell = Class;
|
|
TSectionList = Class;
|
|
TSection = Class;
|
|
|
|
TMyFont = class(TFont)
|
|
public
|
|
NormalSize: integer; {normal unscaled size}
|
|
Fixed: boolean; {set if font is fixed font and can't be changed}
|
|
procedure Assign(Source: TPersistent); override;
|
|
procedure SetNormalSize(List: TSectionList; Value: integer);
|
|
procedure UpdateFont(List: TSectionList; NewColor: TColor);
|
|
end;
|
|
|
|
TFontObj = class(TObject) {font information}
|
|
private
|
|
Section: TSection;
|
|
FVisited, FHover: boolean;
|
|
procedure SetVisited(Value: boolean);
|
|
procedure SetHover(Value: boolean);
|
|
function GetURL: string;
|
|
public
|
|
Pos : integer; {0..Len Index where font takes effect}
|
|
TheFont : TMyFont;
|
|
FontHeight, {tmHeight+tmExternalLeading}
|
|
tmHeight,
|
|
Overhang, Descent : integer;
|
|
SScript: SubSuperType; {Normal, SubSc, SupSc}
|
|
UrlTarget: TUrlTarget;
|
|
constructor Create(ASection: TSection; F: TMyFont; Position: integer);
|
|
destructor Destroy; override;
|
|
procedure UpdateFont;
|
|
procedure FontChanged(Sender: TObject);
|
|
function GetOverhang : integer;
|
|
function GetHeight(var Desc: integer): integer;
|
|
|
|
property URL: string read GetURL;
|
|
property Visited: boolean read FVisited Write SetVisited;
|
|
property Hover: boolean read FHover Write SetHover;
|
|
end;
|
|
|
|
TFontList = class(TFreeList) {a list of TFontObj's}
|
|
Public
|
|
procedure UpDateFonts;
|
|
function GetFontAt(Posn : integer; var OHang : integer) : TMyFont;
|
|
function GetFontCountAt(Posn, Leng : integer) : integer;
|
|
function GetFontObjAt(Posn : integer;
|
|
var Index : integer) : TFontObj;
|
|
end;
|
|
|
|
TImageFormControlObj = class;
|
|
|
|
TFloatingObj = class(TObject)
|
|
protected
|
|
Pos : integer; {0..Len index of image position}
|
|
ImageHeight, {does not include VSpace}
|
|
ImageWidth: integer;
|
|
ObjAlign: AlignmentType;
|
|
Indent: integer;
|
|
HSpace, VSpace: integer; {horizontal, vertical extra space}
|
|
end;
|
|
|
|
TImageObj = class(TFloatingObj) {inline image info}
|
|
private
|
|
FBitmap: TBitmap;
|
|
FHover, FHoverImage: boolean;
|
|
function GetBitmap: TBitmap;
|
|
procedure SetHover(Value: boolean);
|
|
public
|
|
SpecHeight, SpecWidth: integer; {as specified by <img> tag}
|
|
PercentWidth: boolean; {if width is percent}
|
|
ObjHeight, ObjWidth: integer; {width as drawn}
|
|
ImageKnown: boolean; {know size of image}
|
|
Source, Alt : String; {the src= and alt= attributes}
|
|
NoBorder: boolean; {set if don't want blue border}
|
|
Image: TPersistent; {bitmap possibly converted from GIF, Jpeg, etc or animated GIF}
|
|
Mask: TBitmap; {Image's mask if needed for transparency}
|
|
ParentSectionList: TSectionList;
|
|
Transparent: Transparency; {None, Lower Left Corner, or Transp GIF}
|
|
IsMap, UseMap: boolean;
|
|
HasBlueBox: boolean; {Link box drawn around image}
|
|
DrawX: integer;
|
|
DrawYY: integer;
|
|
MapName: String;
|
|
MyFormControl: TImageFormControlObj; {if an <INPUT type=image}
|
|
MyCell: TCell;
|
|
constructor Create(Position: integer; L: TAttributeList);
|
|
destructor Destroy; override;
|
|
procedure DrawLogic(SectionList: TSectionList; Canvas: TCanvas;
|
|
FO: TFontObj; AvailableWidth: integer);
|
|
procedure Draw(Canvas: TCanvas; X: integer; TopY, YBaseline: integer; FO: TFontObj);
|
|
function InsertImage(const UName: String; var Reformat: boolean): boolean;
|
|
|
|
property Bitmap: TBitmap read GetBitmap;
|
|
property Hover: boolean read FHover write SetHover;
|
|
end;
|
|
|
|
TImageObjList = class(TFreeList) {a list of TImageObj's}
|
|
Public
|
|
function FindImage(Posn: integer): TFloatingObj;
|
|
function GetHeightAt(Posn: integer; var AAlign: AlignmentType) : Integer;
|
|
function GetWidthAt(Posn: integer; var AAlign: AlignmentType; var HSpc: integer) : integer;
|
|
function GetImageCountAt(Posn: integer): integer;
|
|
function PtInImage(X: integer; Y: integer; var IX, IY, Posn: integer;
|
|
var AMap, UMap: boolean; var MapItem: TMapItem;
|
|
var ImageObj: TImageObj): boolean;
|
|
function PtInObject(X : integer; Y: integer; var Obj: TObject;
|
|
var IX, IY: integer): boolean;
|
|
end;
|
|
|
|
IndentManager = class(IndentManagerBasic)
|
|
procedure Update(Y: integer; Img: TFloatingObj);
|
|
end;
|
|
|
|
TFormControlObj = class;
|
|
TRadioButtonFormControlObj = class;
|
|
|
|
ThtmlForm = class(TObject)
|
|
Public
|
|
MasterList: TSectionList;
|
|
Method: string[4];
|
|
Action, Target, EncType: String;
|
|
ControlList: TFreeList;
|
|
NonHiddenCount: integer;
|
|
constructor Create(AMasterList: TSectionList; L : TAttributeList);
|
|
destructor Destroy; override;
|
|
procedure DoRadios(Radio: TRadioButtonFormControlObj);
|
|
procedure InsertControl(Ctrl: TFormControlObj);
|
|
procedure ResetControls;
|
|
procedure SubmitTheForm(const ButtonSubmission: string);
|
|
procedure SetSizes(Canvas: TCanvas);
|
|
procedure ControlKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
|
|
end;
|
|
|
|
TFormControlObj = class(TObject)
|
|
private
|
|
FYValue: integer;
|
|
function GetControl: TWinControl; virtual;
|
|
public
|
|
Pos : integer; {0..Len index of image position}
|
|
MasterList: TSectionList;
|
|
MyForm: ThtmlForm;
|
|
Value, Name: String;
|
|
BaseLine: boolean; {True if sits on text baseline}
|
|
FControl: TWinControl;
|
|
ShowIt: boolean;
|
|
OnClickMessage: String;
|
|
|
|
constructor Create(AMasterList: TSectionList; Position: integer; L: TAttributeList);
|
|
destructor Destroy; override;
|
|
procedure ResetToValue; virtual;
|
|
function GetSubmission(Index: integer; var S: string): boolean; virtual;
|
|
procedure SetHeightWidth(Canvas: TCanvas); virtual;
|
|
procedure EnterEvent(Sender: TObject); {these two would be better private}
|
|
procedure ExitEvent(Sender: TObject);
|
|
procedure FormControlClick(Sender: TObject);
|
|
|
|
property TheControl: TWinControl read GetControl; {the Delphi control, TButton, TMemo, etc}
|
|
property YValue: integer read FYValue;
|
|
end;
|
|
|
|
TImageFormControlObj = class(TFormControlObj)
|
|
public
|
|
XPos, YPos, XTmp, YTmp: integer; {click position}
|
|
constructor Create(AMasterList: TSectionList; Position: integer; L: TAttributeList);
|
|
procedure ImageClick;
|
|
function GetSubmission(Index: integer; var S: string): boolean; override;
|
|
end;
|
|
|
|
THiddenFormControlObj = class(TFormControlObj)
|
|
function GetSubmission(Index: integer; var S: string): boolean; override;
|
|
end;
|
|
|
|
TEditFormControlObj = class(TFormControlObj)
|
|
public
|
|
EditSize: integer;
|
|
constructor Create(AMasterList: TSectionList; Position: integer;
|
|
L: TAttributeList; const Typ: string);
|
|
procedure ResetToValue; override;
|
|
function GetSubmission(Index: integer; var S: string): boolean; override;
|
|
procedure SetHeightWidth(Canvas: TCanvas); override;
|
|
end;
|
|
|
|
WhichType = (Submit, ResetB, Button);
|
|
|
|
TButtonFormControlObj = class(TFormControlObj)
|
|
public
|
|
Which: WhichType;
|
|
constructor Create(AMasterList: TSectionList; Position: integer;
|
|
L: TAttributeList; const Typ: string);
|
|
procedure ButtonClick(Sender: TObject);
|
|
procedure SetHeightWidth(Canvas: TCanvas); override;
|
|
end;
|
|
|
|
TRadioButtonFormControlObj = class(TFormControlObj)
|
|
private
|
|
function GetControl: TWinControl; override;
|
|
public
|
|
IsChecked: boolean;
|
|
RButton: TRadioButton;
|
|
MyCell: TCell;
|
|
constructor Create(AMasterList: TSectionList; Position: integer;
|
|
L: TAttributeList; ACell: TCell);
|
|
procedure RadioClick(Sender: TObject);
|
|
procedure ResetToValue; override;
|
|
function GetSubmission(Index: integer; var S: string): boolean; override;
|
|
end;
|
|
|
|
TCheckBoxFormControlObj = class(TFormControlObj)
|
|
public
|
|
IsChecked: boolean;
|
|
constructor Create(AMasterList: TSectionList; Position: integer; L: TAttributeList);
|
|
procedure ResetToValue; override;
|
|
function GetSubmission(Index: integer; var S: string): boolean; override;
|
|
end;
|
|
|
|
LineRec = class(TObject) {holds info on a line of text}
|
|
Start : PChar; {where it starts in Buff}
|
|
SpaceBefore, SpaceAfter,
|
|
LineHt, {total height of line}
|
|
LineImgHt, {top to bottom including any floating image}
|
|
Ln, {# chars in line}
|
|
Descent,
|
|
LineIndent : integer;
|
|
DrawX: integer;
|
|
DrawY: integer;
|
|
end;
|
|
|
|
TSectionBase = class(TObject) {abstract base for document sections}
|
|
public
|
|
ParentSectionList: TSectionList; {what list it's in}
|
|
SectionHeight: integer; {pixel height of section}
|
|
DrawHeight: integer; {floating image may overhang}
|
|
YValue: integer; {Vertical position at top}
|
|
StartCurs: integer;
|
|
Len: integer;
|
|
constructor Create(AMasterList: TSectionList);
|
|
procedure CopyToClipboard; virtual;
|
|
function DrawLogic(Canvas : TCanvas; Y: integer; IMgr: IndentManager;
|
|
var MaxWidth: integer; var Curs: integer): integer; virtual;
|
|
function Draw(Canvas: TCanvas; const ARect: TRect;
|
|
IMgr: IndentManager; X : integer; Y: integer) : integer; virtual;
|
|
function GetURL(Canvas: TCanvas; X: integer; Y: integer;
|
|
var UrlTarg: TUrlTarget; var FormControl: TImageFormControlObj): boolean; virtual;
|
|
function PtInObject(X : integer; Y: integer; var Obj: TObject;
|
|
var IX, IY: integer): boolean; virtual;
|
|
function FindCursor(Canvas: TCanvas; X: integer; Y: integer;
|
|
var XR: integer; var YR: integer; var CaretHt: integer;
|
|
var SCell: TObject; var Intext: boolean): integer; virtual;
|
|
function FindString(From: integer; PC: PChar; MatchCase: boolean): integer; virtual;
|
|
function FindSourcePos(DocPos: integer): integer; virtual;
|
|
function FindDocPos(SourcePos: integer; Prev: boolean): integer; virtual;
|
|
function CursorToXY(Canvas: TCanvas; Cursor: integer; var X: integer;
|
|
var Y: integer): boolean; virtual;
|
|
function GetChAtPos(Pos: integer; var Ch: char; var Obj: TObject): boolean; virtual;
|
|
procedure UpdateFonts; virtual;
|
|
procedure UpdateSpacing; virtual;
|
|
procedure SetParent(List: TSectionList);
|
|
procedure MinMaxWidth(Canvas: TCanvas; var Min, Max: integer); virtual;
|
|
end;
|
|
|
|
IntArray = array[0..MaxCols] of integer;
|
|
|
|
TCellList = class(TFreeList) {a list of TCellObj's to form a table row}
|
|
public
|
|
RowHeight: integer;
|
|
RowSpanHeight: integer; {height of largest rowspan}
|
|
BkGnd: boolean;
|
|
BkColor: TColor;
|
|
procedure DoAttributes(Attr: TAttributeList);
|
|
procedure InitializeRow;
|
|
function DrawLogic1(Canvas : TCanvas; const Widths : IntArray; Span,
|
|
CellPadding, CellSpacing: integer; var More: boolean): integer;
|
|
procedure DrawLogic2(Canvas : TCanvas; Y: integer; CellPadding,
|
|
CellSpacing: integer; var Curs: integer);
|
|
function Draw(Canvas: TCanvas; MasterList: TSectionList; const ARect: TRect;
|
|
const Widths : IntArray; X: integer; Y, YOffset: integer; CellPadding,
|
|
CellSpacing : integer; Border: boolean; Rgn: THandle; MyRow: integer) : integer;
|
|
procedure UpdateFonts;
|
|
end;
|
|
|
|
TCellObj = Class;
|
|
|
|
ThtmlTable = class(TSectionBase) {holds a Table}
|
|
public
|
|
Rows: TFreeList; {a list of TCellLists}
|
|
Caption: TCellObj; {holds the caption info}
|
|
ListsProcessed,
|
|
Border, {if has a border}
|
|
TopCaption: boolean; {if caption is on top (vs. bottom)}
|
|
Indent, {table indent}
|
|
CaptionIndent: integer; {indent of caption}
|
|
Justify: JustifyType; {Left, Center, Right}
|
|
Float: boolean; {if floating}
|
|
NumCols, {Number columns in table}
|
|
TableWidth, {width of table}
|
|
CaptionWidth: integer; {width of caption}
|
|
WidthAttr: integer; {Width attribute as entered}
|
|
AsPercent: boolean; {if it's a percent}
|
|
HeightAttr: integer; {Height attribute as entered}
|
|
HtAsPercent: boolean; {if it's a percent}
|
|
UseAbsolute: boolean; {width entries are considered absolute}
|
|
CaptionHeight, {height of caption itself}
|
|
TableHeight: integer; {height of table itself, not incl caption}
|
|
CellPadding, CellSpacing: integer;
|
|
CaptionMinWidth: integer; {minimum width caption can be shrunk to}
|
|
Widths, {holds column widths}
|
|
Percents: IntArray; {percent widths of columns}
|
|
HSpace, VSpace: integer; {horizontal, vertical extra space}
|
|
Level: integer; {indent level}
|
|
EndList: boolean; {marker for copy}
|
|
DrawX: integer;
|
|
DrawY: integer;
|
|
BkGnd, BdrOn: boolean;
|
|
BkColor, BdrColor: TColor;
|
|
MyCell: TCell;
|
|
|
|
constructor Create(Master: TSectionList;Attr: TAttributeList;
|
|
AJustify: JustifyType; ACell: TCell; ALevel: integer);
|
|
destructor Destroy; override;
|
|
procedure MinMaxWidth(Canvas: TCanvas; var Min, Max: integer); override;
|
|
procedure AddDummyCells;
|
|
procedure GetMinMaxAbs(Canvas: TCanvas; var TotalMinWidth,
|
|
TotalMaxWidth: integer; var MinWidths, MaxWidths: IntArray);
|
|
procedure GetWidthsAbs(Canvas: TCanvas; TablWidth: integer; Specified: boolean;
|
|
var MinWidths, MaxWidths: IntArray);
|
|
procedure GetWidths(Canvas: TCanvas; var TotalMinWidth, TotalMaxWidth: integer;
|
|
var MinWidths, MaxWidths: IntArray; TheWidth: integer);
|
|
procedure xxx(const MaxWidths, MinWidths: IntArray; TheWidth: integer);
|
|
function DrawLogic(Canvas : TCanvas; Y: integer; IMgr: IndentManager;
|
|
var MaxWidth: integer; var Curs: integer): integer; override;
|
|
function Draw(Canvas: TCanvas; const ARect: TRect;
|
|
IMgr: IndentManager; X : integer; Y: integer) : integer; override;
|
|
function GetURL(Canvas: TCanvas; X: integer; Y: integer;
|
|
var UrlTarg: TUrlTarget; var FormControl: TImageFormControlObj): boolean; override;
|
|
function PtInObject(X : integer; Y: integer; var Obj: TObject;
|
|
var IX, IY: integer): boolean; override;
|
|
function FindCursor(Canvas: TCanvas; X: integer; Y: integer;
|
|
var XR: integer; var YR: integer; var CaretHt: integer;
|
|
var SCell: TObject; var Intext: boolean): integer; override;
|
|
function CursorToXY(Canvas: TCanvas; Cursor: integer; var X: integer;
|
|
var Y: integer): boolean; override;
|
|
function GetChAtPos(Pos: integer; var Ch: char; var Obj: TObject): boolean; override;
|
|
function FindString(From: integer; PC: PChar; MatchCase: boolean):
|
|
integer; override;
|
|
function FindSourcePos(DocPos: integer): integer; override;
|
|
function FindDocPos(SourcePos: integer; Prev: boolean): integer; override;
|
|
procedure CopyToClipboard; override;
|
|
procedure UpdateFonts; override;
|
|
end;
|
|
|
|
ClearAttrType = (clrNone, clLeft, clRight, clAll);
|
|
ListTypeType = (None, Ordered, Unordered, Definition);
|
|
XArray = array[0..300] of integer;
|
|
PXArray = ^XArray;
|
|
|
|
IndexObj = class
|
|
Pos: integer;
|
|
Index: integer;
|
|
end;
|
|
|
|
TSection = class(TSectionBase)
|
|
{TSection holds <p>, <li>, many other things, and the base for lists}
|
|
private
|
|
function GetIndexObj(I: integer): IndexObj;
|
|
property PosIndex[I: integer]: IndexObj read GetIndexObj;
|
|
public
|
|
Buff : PChar; {holds the text for the section}
|
|
XP: PXArray;
|
|
BuffSize: integer; {buffer may be larger}
|
|
Fonts : TFontList; {List of FontObj's in this section}
|
|
Images: TImageObjList; {list of TImageObj's, the images in section}
|
|
FormControls: TList; {list of TFormControls in section}
|
|
SIndexList: TFreeList; {list of Source index changes}
|
|
Level, {nesting level of lists}
|
|
Indent, {indent of section}
|
|
ListNumb : integer; {1, 2, 3, etc for ordered lists}
|
|
Lines : TFreeList; {List of LineRecs, info on all the lines in section}
|
|
DefFont : TMyFont;
|
|
ListType: ListTypeType;
|
|
Justify: JustifyType; {Left, Centered, Right}
|
|
ClearAttr: ClearAttrType;
|
|
LevelIndent: integer; {The indent for this list level}
|
|
|
|
constructor Create(AMasterList: TSectionList; ALevel: integer; AFont: TMyFont;
|
|
AnURL: TUrlTarget; AJustify: JustifyType);
|
|
destructor Destroy; override;
|
|
procedure DoClearAttribute(L: TAttributeList);
|
|
procedure Finish;
|
|
procedure AddChar(C: char; Index: integer; NoBreak: boolean);
|
|
procedure AddTokenObj(S : TokenObj; NoBreak: boolean); virtual;
|
|
function BreakInfo(Index: integer; NoBreak: boolean): JustifyType;
|
|
procedure Allocate(N : integer);
|
|
function AddImage(L: TAttributeList; ACell: TCell; Index: integer; NoBreak: boolean): TImageObj;
|
|
function AddFormControl(Which: Symb; AMasterList: TSectionList;
|
|
L: TAttributeList; ACell: TCell; Index: integer; NoBreak: boolean): TFormControlObj;
|
|
procedure ChangeFont(List: TSectionList; NewFont: TMyFont);
|
|
procedure ChangeStyle(Sy: Symb);
|
|
procedure HRef(Sy: Symb; List: TSectionList; AnURL: TUrlTarget;
|
|
AFont: TMyFont);
|
|
function FindCountThatFits(Canvas: TCanvas; Width : integer; Start : PChar;
|
|
Max : integer) : integer;
|
|
function FindCountThatFits1(Canvas: TCanvas; Width : integer;
|
|
Start : PChar; Max: integer; Y: integer; IMgr: IndentManager;
|
|
var ImgHt: integer; NxImages: TList) : integer;
|
|
function FindTextWidth(Canvas: TCanvas; Start: PChar; N: integer;
|
|
RemoveSpaces: boolean): integer;
|
|
function DrawLogic(Canvas : TCanvas; Y: integer; IMgr: IndentManager;
|
|
var MaxWidth: integer; var Curs: integer): integer; override;
|
|
function Draw(Canvas: TCanvas; const ARect: TRect;
|
|
IMgr: IndentManager; X : integer; Y: integer) : integer; override;
|
|
procedure CopyToClipboard; override;
|
|
function GetURL(Canvas: TCanvas; X: integer; Y: integer;
|
|
var UrlTarg: TUrlTarget; var FormControl: TImageFormControlObj): boolean; override;
|
|
function PtInObject(X : integer; Y: integer; var Obj: TObject;
|
|
var IX, IY: integer): boolean; override;
|
|
function FindCursor(Canvas: TCanvas; X: integer; Y: integer;
|
|
var XR: integer; var YR: integer; var CaretHt: integer;
|
|
var SCell: TObject; var Intext: boolean): integer; override;
|
|
function FindString(From: integer; PC: PChar; MatchCase: boolean):
|
|
integer; override;
|
|
function FindSourcePos(DocPos: integer): integer; override;
|
|
function FindDocPos(SourcePos: integer; Prev: boolean): integer; override;
|
|
procedure UpdateFonts; override;
|
|
function CursorToXY(Canvas: TCanvas; Cursor: integer; var X: integer;
|
|
var Y: integer): boolean; override;
|
|
function GetChAtPos(Pos: integer; var Ch: char; var Obj: TObject): boolean; override;
|
|
procedure MinMaxWidth(Canvas: TCanvas; var Min, Max: integer); override;
|
|
end;
|
|
|
|
TCell = class(TFreeList) {a list which holds sections of a table cell}
|
|
MasterList: TSectionList; {the TSectionList that holds the whole document}
|
|
FontSize: integer;
|
|
YValue: integer; {vertical position at top of cell}
|
|
StartCurs: integer;
|
|
Len: integer;
|
|
IMgr: IndentManager;
|
|
BkGnd: boolean;
|
|
BkColor: TColor;
|
|
|
|
constructor Create(Master: TSectionList);
|
|
destructor Destroy; override;
|
|
procedure Add(Item: TSectionBase);
|
|
procedure CopyToClipboard;
|
|
procedure UpdateFonts;
|
|
function DoLogic(Canvas: TCanvas; Y: integer; Width: integer;
|
|
var ScrollWidth: integer; var Curs: integer;
|
|
StartY, StartCount: integer): integer; virtual;
|
|
procedure MinMaxWidth(Canvas: TCanvas; var Min, Max: integer); virtual;
|
|
function Draw(Canvas: TCanvas; ARect: TRect; ClipWidth, X: integer;
|
|
Y:integer): integer; virtual;
|
|
function FindSectionAtPosition(Pos: integer;
|
|
var TopPos: integer; var Index: integer): TSectionBase;
|
|
function GetURL(Canvas: TCanvas; X: integer; Y: integer;
|
|
var UrlTarg: TUrlTarget; var FormControl: TImageFormControlObj): boolean; virtual;
|
|
function PtInObject(X: integer; Y: integer; var Obj: TObject;
|
|
var IX, IY: integer): boolean;
|
|
function FindCursor(Canvas: TCanvas; X: Integer; Y: integer;
|
|
var XR: integer; var YR: integer; var Ht: integer;
|
|
var SCell: TObject; var Intext: boolean): integer;
|
|
function FindString(From: integer; PC: PChar; MatchCase: boolean): integer;
|
|
function FindSourcePos(DocPos: integer): integer;
|
|
function FindDocPos(SourcePos: integer; Prev: boolean): integer;
|
|
function CursorToXY(Canvas: TCanvas; Cursor: integer; var X: integer;
|
|
var Y: integer): boolean;
|
|
function GetChAtPos(Pos: integer; var Ch: char; var Obj: TObject): boolean;
|
|
end;
|
|
|
|
TSectionList = class(TCell) {a list of all the sections--holds document}
|
|
Private
|
|
procedure AdjustFormControls;
|
|
Public
|
|
ShowImages: boolean; {set if showing images}
|
|
YOff: integer; {marks top of window that's displayed}
|
|
YOffChange: boolean; {when above changes}
|
|
NoPartialLine: boolean; {set when printing if no partial line allowed
|
|
at page bottom}
|
|
SelB, SelE: integer;
|
|
FontName : string[lf_FaceSize+1]; {font info for document}
|
|
PreFontName : string[lf_FaceSize+1]; {<pre>, <code> font for document}
|
|
FontColor,
|
|
LinkVisitedColor, LinkActiveColor,
|
|
HotSpotColor: TColor;
|
|
{$ifdef ver100_plus}
|
|
Charset: TFontCharset;
|
|
{$endif}
|
|
UnLine: TFontStyles; {[fsUnderline] or [] depending on htNoLinkUnderline}
|
|
TheOwner: TWinControl; {the viewer that owns this document}
|
|
PPanel: TWinControl; {the viewer's PaintPanel}
|
|
GetImage: TGetImageEvent; {for OnImageRequest Event}
|
|
ExpandName: TExpandNameEvent;
|
|
ObjectClick: TObjectClickEvent;
|
|
BackGround: TColor;
|
|
OnBackgroundChange: TNotifyEvent;
|
|
BackgroundBitmap: TBitmap;
|
|
BackgroundMask: TBitmap;
|
|
BitmapName: String; {name of background bitmap}
|
|
BitmapLoaded: boolean; {if background bitmap is loaded}
|
|
htmlFormList: TFreeList;
|
|
AGifList: TList; {list of all animated Gifs}
|
|
SubmitForm: TFormSubmitEvent;
|
|
ScriptEvent: TScriptEvent;
|
|
CB: SelTextCount;
|
|
PageBottom: integer;
|
|
MapList: TFreeList; {holds list of client maps, TMapItems}
|
|
Timer: TTimer; {for animated GIFs}
|
|
FormControlList: TList; {List of all TFormControlObj's in this SectionList}
|
|
MissingImages: TStringList; {images to be supplied later}
|
|
ControlEnterEvent: TNotifyEvent;
|
|
LinkList: TList; {List of links (TFontObj's)}
|
|
ActiveLink: TFontObj;
|
|
LinksActive: boolean;
|
|
ActiveImage: TImageObj;
|
|
ShowDummyCaret: boolean;
|
|
Parser: TObject;
|
|
|
|
constructor Create(Owner, APaintPanel: TWinControl);
|
|
procedure Clear;
|
|
destructor Destroy; override;
|
|
procedure CheckGIFList(Sender: TObject);
|
|
procedure SetYOffset(Y: integer);
|
|
function GetSelLength: integer;
|
|
function GetSelTextBuf(Buffer: PChar; BufSize: integer): integer;
|
|
procedure SetFonts(const Name, PreName: String; ASize: integer;
|
|
AColor, AHotSpot, AVisitedColor, AActiveColor, ABackground: TColor;
|
|
LnksActive: boolean);
|
|
procedure SetBackground(ABackground: TColor);
|
|
procedure SetBackgroundBitmap(Name: String);
|
|
function GetBackgroundBitmap: TBitmap;
|
|
function FindPositionByIndex(Index: integer): integer;
|
|
procedure CancelActives;
|
|
function GetURL(Canvas: TCanvas; X: integer; Y: integer;
|
|
var UrlTarg: TUrlTarget; var FormControl: TImageFormControlObj): boolean; override;
|
|
function GetTheBitmap(const BMName: String; var Transparent: Transparency;
|
|
var AMask: TBitmap; var FromCache, Delay: boolean): TPersistent;
|
|
function DoLogic(Canvas: TCanvas; Y: integer; Width: integer;
|
|
var ScrollWidth: integer; var Curs: integer;
|
|
StartY, StartCount: integer): integer; override;
|
|
function Draw(Canvas: TCanvas; ARect: TRect; ClipWidth, X: integer;
|
|
Y:integer): integer; override;
|
|
procedure InsertImage(const Src: string; Stream: TMemoryStream; var Reformat: boolean);
|
|
end;
|
|
|
|
TCellObj = class(TObject) {holds a TCell and some other information}
|
|
ColSpan, RowSpan, {column and row spans for this cell}
|
|
Wd: integer; {total width (may cover more than one column)}
|
|
Ht, {total height (may cover more than one row)}
|
|
VSize: integer; {Actual vertical size of contents}
|
|
SpecHt: integer; {Height as specified}
|
|
YIndent: integer; {Vertical indent}
|
|
VAlign: AlignmentType; {Top, Middle, or Bottom}
|
|
WidthAttr: integer; {Width attribute (percentage or absolute)}
|
|
AsPercent: boolean; {it's a percent}
|
|
Cell: TCell;
|
|
|
|
constructor Create(Master: TSectionList; AVAlign: AlignmentType;
|
|
Attr: TAttributeList);
|
|
destructor Destroy; override;
|
|
procedure UpdateFonts;
|
|
end;
|
|
|
|
const
|
|
SmallListIndent = 15; {for <li> without <ul>}
|
|
ImageSpace = 5; {extra space for left, right images}
|
|
|
|
var
|
|
ListIndent: integer{$IFNDEF HL_LAZARUS} = 35{$ENDIF}; {defines successive indents}
|
|
|
|
implementation
|
|
|
|
uses htmllite, LitePars, LiteSbs1, LiteReadThd;
|
|
|
|
type
|
|
TSectionClass = Class of TSectionBase;
|
|
EProcessError = class(Exception);
|
|
|
|
procedure IndentManager.Update(Y: integer; Img: TFloatingObj);
|
|
{Given a new floating image, update the edge information. Fills Img.Indent,
|
|
the distance from the left edge to the upper left corner of the image}
|
|
var
|
|
IH, IW: integer;
|
|
IR: IndentRec;
|
|
begin
|
|
if Assigned(Img) then
|
|
begin
|
|
IW := Img.ImageWidth + Img.HSpace;
|
|
IH := Img.ImageHeight + 2*Img.VSpace;
|
|
if (Img.ObjAlign = ALeft) then
|
|
begin
|
|
IR := IndentRec.Create;
|
|
with IR do
|
|
begin
|
|
Img.Indent := LeftIndent(Y)-LfEdge;
|
|
X := Img.Indent + IW;
|
|
YT := Y;
|
|
YB := Y + IH;
|
|
Lev := 0;
|
|
L.Add(IR);
|
|
end;
|
|
end
|
|
else if (Img.ObjAlign = ARight) then
|
|
begin
|
|
IR := IndentRec.Create;
|
|
with IR do
|
|
begin
|
|
X := RightSide(Y) - RtEdge - IW;
|
|
Img.Indent := X + RtEdge + Img.HSpace;
|
|
YT := Y;
|
|
YB := Y + IH;
|
|
Lev := 0;
|
|
R.Add(IR);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{----------------TMyFont.Assign}
|
|
procedure TMyFont.Assign(Source: TPersistent);
|
|
begin
|
|
if Source is TMyFont then
|
|
begin
|
|
NormalSize := TMyFont(Source).NormalSize;
|
|
Fixed := TMyFont(Source).Fixed;
|
|
end;
|
|
inherited Assign(Source);
|
|
end;
|
|
|
|
procedure TMyFont.SetNormalSize(List: TSectionList; Value: integer);
|
|
begin
|
|
NormalSize := Value;
|
|
Size := MulDiv(List.FontSize, Value, 12);
|
|
end;
|
|
|
|
procedure TMyFont.UpdateFont(List: TSectionList; NewColor: TColor);
|
|
begin
|
|
if not Fixed then Name := List.FontName
|
|
else Name := List.PreFontName;
|
|
{$ifdef ver100_plus}
|
|
Charset := List.Charset;
|
|
{$endif}
|
|
Size := MulDiv(List.FontSize, NormalSize, 12); {Scale the font size}
|
|
Color := NewColor or $2000000;
|
|
end;
|
|
|
|
constructor TFontObj.Create(ASection: TSection; F: TMyFont; Position: integer);
|
|
begin
|
|
inherited Create;
|
|
Section := ASection;
|
|
TheFont := F;
|
|
TheFont.OnChange := {$IFDEF HL_LAZARUS}@{$ENDIF}FontChanged;
|
|
Pos := Position;
|
|
UrlTarget := TUrlTarget.Create;
|
|
FontChanged(Self);
|
|
end;
|
|
|
|
destructor TFontObj.Destroy;
|
|
begin
|
|
TheFont.Free;
|
|
UrlTarget.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TFontObj.SetVisited(Value: boolean);
|
|
begin
|
|
if Value <> FVisited then
|
|
begin
|
|
FVisited := Value;
|
|
if FHover then
|
|
TheFont.Color := Section.ParentSectionList.LinkActiveColor or $2000000
|
|
else if Value then
|
|
TheFont.Color := Section.ParentSectionList.LinkVisitedColor or $2000000
|
|
else
|
|
TheFont.Color := Section.ParentSectionList.HotspotColor or $2000000;
|
|
end;
|
|
end;
|
|
|
|
procedure TFontObj.SetHover(Value: boolean);
|
|
begin
|
|
if Value <> FHover then
|
|
begin
|
|
FHover := Value;
|
|
if FHover then
|
|
TheFont.Color := Section.ParentSectionList.LinkActiveColor or $2000000
|
|
else if FVisited then
|
|
TheFont.Color := Section.ParentSectionList.LinkVisitedColor or $2000000
|
|
else
|
|
TheFont.Color := Section.ParentSectionList.HotspotColor or $2000000;
|
|
end;
|
|
end;
|
|
|
|
function TFontObj.GetURL: string;
|
|
begin
|
|
Result := UrlTarget.Url;
|
|
end;
|
|
|
|
procedure TFontObj.UpdateFont;
|
|
var
|
|
Color: TColor;
|
|
begin
|
|
if UrlTarget.Url <> '' then Color := Section.ParentSectionList.HotSpotColor
|
|
else Color := Section.ParentSectionList.FontColor;
|
|
TheFont.UpdateFont(Section.ParentSectionList, Color);
|
|
end;
|
|
|
|
procedure TFontObj.FontChanged(Sender: TObject);
|
|
var
|
|
Save: THandle;
|
|
tm : TTextmetric;
|
|
DC: HDC;
|
|
begin
|
|
DC := GetDC(0);
|
|
Save := SelectObject(DC, TheFont.Handle);
|
|
GetTextMetrics(DC, tm);
|
|
tmHeight := tm.tmHeight;
|
|
FontHeight := tm.tmHeight + tm.tmExternalLeading;
|
|
Descent := tm.tmDescent;
|
|
Overhang := tm.tmOverhang;
|
|
SelectObject(DC, Save);
|
|
ReleaseDC(0, DC);
|
|
end;
|
|
|
|
function TFontObj.GetOverhang: integer;
|
|
begin
|
|
Result := Overhang;
|
|
end;
|
|
|
|
function TFontObj.GetHeight(var Desc: integer): integer;
|
|
begin
|
|
Desc := Descent;
|
|
Result := FontHeight;
|
|
end;
|
|
|
|
procedure TFontList.UpDateFonts;
|
|
var
|
|
I: integer;
|
|
begin
|
|
for I := 0 to Count-1 do
|
|
TFontObj(Items[I]).UpdateFont;
|
|
end;
|
|
|
|
function TFontList.GetFontAt(Posn : integer;
|
|
var OHang : integer) : TMyFont;
|
|
{given a character index, find the font that's effective there}
|
|
var
|
|
I, PosX: integer;
|
|
F : TFontObj;
|
|
begin
|
|
I := 0;
|
|
PosX := 0;
|
|
while (I < Count) do
|
|
begin
|
|
PosX := TFontObj(Items[I]).Pos;
|
|
Inc(I);
|
|
if PosX >= Posn then Break;
|
|
end;
|
|
Dec(I);
|
|
if PosX > Posn then Dec(I);
|
|
F := TFontObj(Items[I]);
|
|
OHang := F.GetOverhang;
|
|
Result := F.TheFont;
|
|
end;
|
|
|
|
function TFontList.GetFontCountAt(Posn, Leng : integer) : integer;
|
|
{Given a position, return the number of chars before the font changes}
|
|
var
|
|
I, PosX : integer;
|
|
begin
|
|
I := 0;
|
|
PosX := 0;
|
|
while I < Count do
|
|
begin
|
|
PosX := TFontObj(Items[I]).Pos;
|
|
if PosX >= Posn then Break;
|
|
Inc(I);
|
|
end;
|
|
if PosX = Posn then Inc(I);
|
|
if I = Count then
|
|
Result := Leng-Posn
|
|
else
|
|
Result := TFontObj(Items[I]).Pos - Posn;
|
|
end;
|
|
|
|
{----------------TFontList.GetFontObjAt}
|
|
function TFontList.GetFontObjAt(Posn : integer;
|
|
var Index : integer) : TFontObj;
|
|
{Given a position, returns the FontObj which applies there and the index of
|
|
the FontObj in the list}
|
|
var
|
|
PosX: integer;
|
|
begin
|
|
Index := 0;
|
|
PosX := 0;
|
|
while (Index < Count) do
|
|
begin
|
|
PosX := TFontObj(Items[Index]).Pos;
|
|
Inc(Index);
|
|
if PosX >= Posn then Break;
|
|
end;
|
|
Dec(Index);
|
|
if PosX > Posn then Dec(Index);
|
|
Result := TFontObj(Items[Index]);
|
|
end;
|
|
|
|
{----------------TImageObj.Create}
|
|
constructor TImageObj.Create(Position: integer; L: TAttributeList);
|
|
var
|
|
I: integer;
|
|
S: string;
|
|
NewSpace: integer;
|
|
begin
|
|
inherited Create;
|
|
Pos := Position;
|
|
ObjAlign := ABottom; {default}
|
|
NewSpace := -1;
|
|
for I := 0 to L.Count-1 do
|
|
with TAttribute(L[I]) do
|
|
case Which of
|
|
SrcSy: Source := Name;
|
|
AltSy: Alt := Name;
|
|
IsMapSy: IsMap := True;
|
|
UseMapSy:
|
|
begin
|
|
UseMap := True;
|
|
S := Trim(Uppercase(Name));
|
|
if (Length(S) > 1) and (S[1] = '#') then
|
|
System.Delete(S, 1, 1);
|
|
MapName := S;
|
|
end;
|
|
AlignSy:
|
|
begin
|
|
S := UpperCase(Name);
|
|
if S = 'TOP' then ObjAlign := ATop
|
|
else if (S = 'MIDDLE') or (S = 'ABSMIDDLE') then ObjAlign := AMiddle
|
|
else if S = 'LEFT' then ObjAlign := ALeft
|
|
else if S = 'RIGHT' then ObjAlign := ARight;
|
|
end;
|
|
BorderSy: NoBorder := Value = 0;
|
|
TranspSy: Transparent := LLCorner;
|
|
HeightSy: SpecHeight := Intmax(1, Value); {spec ht of 0 becomes 1}
|
|
WidthSy: if System.Pos('%', Name) = 0 then
|
|
SpecWidth := Value
|
|
else if (Value > 0) and (Value <=100) then
|
|
begin
|
|
SpecWidth := Value;
|
|
PercentWidth := True;
|
|
end;
|
|
HSpaceSy: NewSpace := IntMin(40, Abs(Value));
|
|
VSpaceSy: VSpace := IntMin(40, Abs(Value));
|
|
ActiveSy: FHoverImage := True;
|
|
end;
|
|
if NewSpace >= 0 then
|
|
HSpace := NewSpace
|
|
else if ObjAlign in [ALeft, ARight] then
|
|
HSpace := ImageSpace {default}
|
|
else HSpace := 0;
|
|
end;
|
|
|
|
destructor TImageObj.Destroy;
|
|
begin
|
|
if (Source <> '') then
|
|
BitmapList.DecUsage(Source);
|
|
if (Image is TGifImage) and TGifImage(Image).IsCopy then
|
|
Image.Free;
|
|
FBitmap.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TImageObj.GetBitmap: TBitmap;
|
|
begin
|
|
Result := Nil;
|
|
if Image = ErrorBitmap then Exit;
|
|
if (Image is TGifImage) then
|
|
Result := TGifImage(Image).Bitmap
|
|
else if (Image is TBitmap) then
|
|
begin
|
|
if Assigned(FBitmap) then
|
|
Result := FBitmap
|
|
else
|
|
begin
|
|
FBitmap := TBitmap.Create;
|
|
FBitmap.Assign(TBitmap(Image));
|
|
FBitmap.Palette := CopyPalette(ThePalette);
|
|
Result := FBitmap;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TImageObj.SetHover(Value: boolean);
|
|
begin
|
|
if (Value <> FHover) and FHoverImage and (Image is TGifImage) then
|
|
with TGifImage(Image) do
|
|
begin
|
|
if Value then
|
|
if NumFrames = 2 then
|
|
CurrentFrame := 2
|
|
else
|
|
begin
|
|
Animate := True;
|
|
ParentSectionList.AGifList.Add(Image);
|
|
end
|
|
else
|
|
begin
|
|
Animate := False;
|
|
CurrentFrame := 1;
|
|
ParentSectionList.AGifList.Remove(Image);
|
|
end;
|
|
FHover := Value;
|
|
end;
|
|
end;
|
|
|
|
{----------------TImageObj.InsertImage}
|
|
function TImageObj.InsertImage(const UName: string; var Reformat: boolean): boolean;
|
|
var
|
|
TmpImage: TPersistent;
|
|
FromCache, IsAniGIF, Delay: boolean;
|
|
begin
|
|
Result := False;
|
|
Reformat := False;
|
|
if (Image = DefBitmap) then
|
|
begin
|
|
Result := True;
|
|
TmpImage := ParentSectionList.GetTheBitmap(UName, Transparent, Mask, FromCache, Delay);
|
|
if not Assigned(TmpImage) then Exit;
|
|
IsAniGIF := TmpImage is TGifImage;
|
|
|
|
if IsAniGIF then
|
|
begin
|
|
if FromCache then {it would be}
|
|
Image := TGifImage.CreateCopy(TGifImage(TmpImage)) {it's in Cache already, make copy}
|
|
else
|
|
Image := TmpImage;
|
|
ParentSectionList.AGifList.Add(Image);
|
|
TGifImage(Image).Animate := True;
|
|
if Assigned(ParentSectionList.Timer) then
|
|
ParentSectionList.Timer.Enabled := True;
|
|
end
|
|
else Image := TmpImage;
|
|
|
|
if not ImageKnown then
|
|
begin {need to get the dimensions}
|
|
Reformat := True;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{----------------TImageObj.DrawLogic}
|
|
procedure TImageObj.DrawLogic(SectionList: TSectionList; Canvas: TCanvas;
|
|
FO: TFontObj; AvailableWidth: integer);
|
|
{calculate the height and width}
|
|
var
|
|
TmpImage: TPersistent;
|
|
ImHeight, ImWidth: integer;
|
|
ViewImages, FromCache, Delay: boolean;
|
|
AltWidth, AltHeight: integer;
|
|
Rslt: string;
|
|
|
|
begin
|
|
ParentSectionList := SectionList;
|
|
ViewImages := SectionList.ShowImages;
|
|
Delay := False;
|
|
|
|
TmpImage := Image;
|
|
if ViewImages and not Assigned(TmpImage) then
|
|
begin
|
|
if Source <> '' then
|
|
with SectionList do
|
|
begin
|
|
if not Assigned(GetImage) then
|
|
Source := (TheOwner as ThtmlLite).HTMLExpandFilename(Source)
|
|
else if Assigned(ExpandName) then
|
|
begin
|
|
ExpandName(TheOwner, Source, Rslt);
|
|
Source := Rslt;
|
|
end;
|
|
if MissingImages.IndexOf(Uppercase(Source)) = -1 then
|
|
TmpImage := ParentSectionList.GetTheBitmap(Source, Transparent, Mask, FromCache, Delay)
|
|
else Delay := True; {already in list, don't request it again}
|
|
end;
|
|
if not Assigned(TmpImage) then
|
|
begin
|
|
if Delay then
|
|
begin
|
|
Image := DefBitmap;
|
|
TmpImage := DefBitmap;
|
|
ParentSectionList.MissingImages.AddObject(Source, Self); {add it even if it's there already}
|
|
end
|
|
else
|
|
begin
|
|
Image := ErrorBitmap;
|
|
TmpImage := ErrorBitmap;
|
|
Mask := ErrorBitmapMask;
|
|
Transparent := LLCorner;
|
|
end;
|
|
end
|
|
else if TmpImage is TGifImage then
|
|
begin
|
|
if FromCache then
|
|
begin {it's in Cache already, make copy}
|
|
Image := TGifImage.CreateCopy(TGifImage(TmpImage));
|
|
TmpImage := Image;
|
|
end
|
|
else
|
|
Image := TmpImage;
|
|
if not FHoverImage then
|
|
ParentSectionList.AGifList.Add(Image)
|
|
else TGifImage(Image).Animate := False;
|
|
end
|
|
else Image := TBitmap(TmpImage);
|
|
end;
|
|
if not ViewImages then
|
|
TmpImage := DefBitMap;
|
|
|
|
if TmpImage is TGifImage then
|
|
begin
|
|
ImHeight := TGifImage(TmpImage).Height;
|
|
ImWidth := TGifImage(TmpImage).Width;
|
|
end
|
|
else
|
|
begin
|
|
ImHeight := TBitmap(TmpImage).Height;
|
|
ImWidth := TBitmap(TmpImage).Width;
|
|
end;
|
|
|
|
if not ImageKnown then
|
|
if not ((Image = ErrorBitmap) or (TmpImage = DefBitmap)) then
|
|
begin
|
|
if PercentWidth then
|
|
begin
|
|
ObjWidth := MulDiv(AvailableWidth, SpecWidth, 100);
|
|
if SpecHeight <> 0 then ObjHeight := SpecHeight
|
|
else ObjHeight := ImHeight;
|
|
end
|
|
else if (SpecWidth <> 0) and (SpecHeight <> 0) then
|
|
begin {Both width and height specified}
|
|
ObjHeight := SpecHeight;
|
|
ObjWidth := SpecWidth;
|
|
ImageKnown := True;
|
|
end
|
|
else if SpecHeight <> 0 then
|
|
begin
|
|
ObjHeight := SpecHeight;
|
|
ObjWidth := MulDiv(SpecHeight, ImWidth, ImHeight);
|
|
ImageKnown := True;
|
|
end
|
|
else if SpecWidth <> 0 then
|
|
begin
|
|
ObjWidth := SpecWidth;
|
|
ObjHeight := MulDiv(SpecWidth, ImHeight, ImWidth);
|
|
ImageKnown := True;
|
|
end
|
|
else
|
|
begin {neither height and width specified}
|
|
ObjHeight := ImHeight;
|
|
ObjWidth := ImWidth;
|
|
ImageKnown := True;
|
|
end;
|
|
end
|
|
else {don't know the image yet}
|
|
if (SpecHeight <> 0) and (SpecWidth <> 0) then
|
|
begin {Both width and height specified}
|
|
ObjHeight := SpecHeight;
|
|
ObjWidth := SpecWidth;
|
|
ImageKnown := True; {do know the image size}
|
|
end
|
|
else
|
|
begin {neither height and width specified}
|
|
ObjHeight := ImHeight;
|
|
ObjWidth := ImWidth;
|
|
end;
|
|
|
|
if (not ViewImages or (TmpImage = ErrorBitmap) or (Image = DefBitmap))
|
|
and Not ImageKnown then
|
|
begin
|
|
Canvas.Font.Name := 'Arial';{use same font as in Draw}
|
|
Canvas.Font.Size := 8; {should be option?}
|
|
if Alt <> '' then
|
|
begin
|
|
AltWidth := Canvas.TextWidth(Alt) + 2;
|
|
AltHeight := Canvas.TextHeight(Alt);
|
|
end
|
|
else
|
|
begin
|
|
AltHeight := 0;
|
|
AltWidth := 0;
|
|
end;
|
|
ObjWidth := IntMax(ObjWidth, 16+8 + AltWidth);
|
|
ObjHeight := IntMax(ObjHeight, IntMax(16+8, AltHeight));
|
|
end;
|
|
|
|
ImageHeight := ObjHeight;
|
|
ImageWidth := ObjWidth;
|
|
|
|
HasBlueBox := (FO.URLTarget.Url <> '') and not NoBorder;
|
|
|
|
if HasBlueBox then
|
|
begin
|
|
Inc(ImageHeight, 2); {extra pixel top and bottom for rectangle}
|
|
Inc(ImageWidth, 2);
|
|
end;
|
|
end;
|
|
|
|
procedure TImageObj.Draw(Canvas: TCanvas; X: integer; TopY, YBaseline: integer;
|
|
FO: TFontObj);
|
|
var
|
|
TmpImage: TPersistent;
|
|
TmpMask: TBitmap;
|
|
MiddleAlignTop: integer;
|
|
ViewImages: boolean;
|
|
SubstImage: boolean;
|
|
Ofst: integer;
|
|
SaveColor: TColor;
|
|
|
|
procedure DoDraw(XX: integer; Y: integer);
|
|
var
|
|
DC: HDC;
|
|
Img: TBitmap;
|
|
|
|
function PrintTransparentBitmap(Bitmap, Mask: TBitmap): HBitmap;
|
|
var
|
|
DC, MemDC: HDC;
|
|
OldPal: HPalette;
|
|
TmpBitmap: HBitmap;
|
|
begin
|
|
DC := GetDC(0);
|
|
MemDC := CreateCompatibleDC(DC);
|
|
try
|
|
Result := CreateCompatibleBitmap(DC, Bitmap.Width, Bitmap.Height);
|
|
TmpBitmap := SelectObject(MemDC, Result);
|
|
OldPal := SelectPalette(MemDC, ThePalette, False);
|
|
RealizePalette(MemDC);
|
|
BitBlt(MemDC, 0, 0, Bitmap.Width, Bitmap.Height, Bitmap.Canvas.Handle, 0, 0, SRCCOPY);
|
|
BitBlt(MemDC, 0, 0, Bitmap.Width, Bitmap.Height, Mask.Canvas.Handle, 0, 0, SRCPAINT);
|
|
SelectObject(MemDC, TmpBitmap);
|
|
SelectPalette(MemDC, OldPal, False);
|
|
finally
|
|
DeleteDC(MemDC);
|
|
ReleaseDC(0, DC);
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
if (TmpImage is TGifImage) then
|
|
with TGifImage(TmpImage) do
|
|
begin
|
|
ShowIt := True;
|
|
Visible := True;
|
|
Draw(Canvas, ParentSectionList, MyCell, XX, Y, ObjWidth, ObjHeight);
|
|
Exit;
|
|
end;
|
|
DC := Canvas.Handle;
|
|
try
|
|
if ((Transparent <> NotTransp) or (TmpImage = ErrorBitmap)) and Assigned(TmpMask) then
|
|
if TmpImage = ErrorBitmap then
|
|
FinishTransparentBitmap(DC, TBitmap(TmpImage), Mask, XX, Y,
|
|
TBitmap(TmpImage).Width, TBitmap(TmpImage).Height)
|
|
else
|
|
FinishTransparentBitmap(DC, TBitmap(TmpImage), Mask, XX, Y, ObjWidth, ObjHeight)
|
|
else
|
|
begin
|
|
Img := TBitmap(TmpImage);
|
|
if (TmpImage = DefBitMap) or (TmpImage = ErrorBitmap) then
|
|
BitBlt(DC, XX, Y, Img.Width, Img.Height, Img.Canvas.Handle, 0, 0, SRCCOPY)
|
|
else
|
|
begin
|
|
SetStretchBltMode(DC, ColorOnColor);
|
|
StretchBlt(DC, XX, Y, ObjWidth, ObjHeight, Img.Canvas.Handle, 0, 0, Img.Width, Img.Height, SRCCOPY);
|
|
end;
|
|
end;
|
|
except
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
with ParentSectionList do
|
|
begin
|
|
ViewImages := ShowImages;
|
|
Dec(TopY, YOff);
|
|
Dec(YBaseLine, YOff);
|
|
end;
|
|
if ViewImages then
|
|
begin
|
|
TmpImage := Image;
|
|
if Image is TBitmap then
|
|
TmpMask := Mask;
|
|
end
|
|
else
|
|
begin
|
|
TmpImage := DefBitMap;
|
|
TmpMask := Nil;
|
|
end;
|
|
SubstImage := not ViewImages or (TmpImage = ErrorBitmap) or (TmpImage = DefBitmap); {substitute image}
|
|
|
|
with Canvas do
|
|
begin
|
|
Brush.Style := bsClear;
|
|
SaveColor := Font.Color;
|
|
Font.Color := clBlack; {else transparent won't work for blue text}
|
|
Font.Size := 8;
|
|
Font.Name := 'Arial'; {make this a property?}
|
|
if SubstImage then Ofst := 4 else Ofst := 0;
|
|
if ObjAlign = AMiddle then
|
|
MiddleAlignTop := YBaseLine+FO.Descent-(FO.tmHeight div 2)-(ImageHeight div 2)
|
|
else MiddleAlignTop := 0; {not used}
|
|
|
|
DrawX := X;
|
|
case ObjAlign of
|
|
ATop: DrawYY := TopY;
|
|
ALeft, ARight: DrawYY := TopY+VSpace;
|
|
AMiddle: DrawYY := MiddleAlignTop;
|
|
ABottom: DrawYY := YBaseLine-ImageHeight;
|
|
end;
|
|
if HasBlueBox then
|
|
begin
|
|
Inc(DrawX, 1);
|
|
Inc(DrawYY, 1);
|
|
end;
|
|
|
|
if not SubstImage or (ObjHeight >= 16+8) and (ObjWidth >= 16+8) then
|
|
DoDraw(DrawX+Ofst, DrawYY+Ofst);
|
|
Inc(DrawYY, ParentSectionList.YOff);
|
|
SetTextAlign(Canvas.Handle, TA_Top);
|
|
if SubstImage and not HasBlueBox then
|
|
begin
|
|
Font.Color := SaveColor;
|
|
{calc the offset from the image's base to the alt= text baseline}
|
|
case ObjAlign of
|
|
ATop, ALeft, ARight:
|
|
begin
|
|
if Alt <> '' then
|
|
WrapText(Canvas, X+24, TopY+Ofst+VSpace, X+ObjWidth-2, TopY+ObjHeight-1+VSpace, Alt);
|
|
RaisedRect(ParentSectionList, Canvas, X, TopY+VSpace,
|
|
X+ObjWidth-1, TopY+ObjHeight-1+VSpace, False);
|
|
end;
|
|
AMiddle:
|
|
begin {MiddleAlignTop is always initialized}
|
|
if Alt <> '' then
|
|
WrapText(Canvas, X+24, MiddleAlignTop+Ofst, X+ObjWidth-2,
|
|
MiddleAlignTop+ObjHeight-1, Alt);
|
|
RaisedRect(ParentSectionList, Canvas, X, MiddleAlignTop,
|
|
X+ObjWidth-1, MiddleAlignTop+ObjHeight-1, False);
|
|
end;
|
|
ABottom:
|
|
begin
|
|
if Alt <> '' then
|
|
WrapText(Canvas, X+24, YBaseLine-ObjHeight+Ofst, X+ObjWidth-2,
|
|
YBaseLine-1, Alt);
|
|
RaisedRect(ParentSectionList, Canvas, X, YBaseLine-ObjHeight,
|
|
X+ObjWidth-1, YBaseLine-1, False);
|
|
end;
|
|
end;
|
|
end;
|
|
if HasBlueBox then
|
|
begin
|
|
Pen.Color := FO.TheFont.Color;
|
|
Font.Color := Pen.Color;
|
|
if (Alt <> '') and SubstImage then {output Alt message}
|
|
case ObjAlign of
|
|
ATop, ALeft, ARight:
|
|
WrapText(Canvas, X+24, TopY+Ofst, X+ObjWidth-2, TopY+ObjHeight-1, Alt);
|
|
AMiddle:
|
|
WrapText(Canvas, X+24, MiddleAlignTop+Ofst, X+ObjWidth-2,
|
|
MiddleAlignTop+ObjHeight-1, Alt);
|
|
ABottom:
|
|
WrapText(Canvas, X+24, YBaseLine-ObjHeight+Ofst, X+ObjWidth-2,
|
|
YBaseLine-1, Alt);
|
|
end;
|
|
case ObjAlign of {draw blue box}
|
|
ATop: Rectangle(X, TopY, X+ImageWidth, TopY+ImageHeight);
|
|
ALeft, ARight: Rectangle(X, TopY+VSpace, X+ImageWidth, TopY+VSpace+ImageHeight);
|
|
AMiddle: Rectangle(X, MiddleAlignTop, X+ImageWidth, MiddleAlignTop + ImageHeight);
|
|
ABottom: Rectangle(X, YBaseLine-ImageHeight, X+ImageWidth, YBaseLine);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TImageObjList.FindImage(Posn: integer): TFloatingObj;
|
|
{find the image at a given character position}
|
|
var
|
|
I: integer;
|
|
begin
|
|
for I := 0 to Count-1 do
|
|
if TFloatingObj(Items[I]).Pos = Posn then
|
|
begin
|
|
Result := TFloatingObj(Items[I]);
|
|
Exit;
|
|
end;
|
|
Result := Nil;
|
|
end;
|
|
|
|
function TImageObjList.GetHeightAt(Posn: integer; var AAlign: AlignmentType) : Integer;
|
|
var
|
|
Img: TFloatingObj;
|
|
begin
|
|
Img := FindImage(Posn);
|
|
if Assigned(Img) then
|
|
begin
|
|
Result := Img.ImageHeight;
|
|
AAlign := Img.ObjAlign;
|
|
end
|
|
else Result := -1;
|
|
end;
|
|
|
|
function TImageObjList.GetWidthAt(Posn: integer; var AAlign: AlignmentType; var HSpc: integer) : integer;
|
|
var
|
|
Img: TFloatingObj;
|
|
begin
|
|
Img := FindImage(Posn);
|
|
if Assigned(Img) then
|
|
begin
|
|
Result := Img.ImageWidth;
|
|
AAlign := Img.ObjAlign;
|
|
HSpc := Img.HSpace;
|
|
end
|
|
else Result := -1;
|
|
end;
|
|
|
|
function TImageObjList.GetImageCountAt(Posn: integer): integer;
|
|
{Return count of chars before the next image. 0 if at the image, 9999 if no
|
|
images after Posn}
|
|
var
|
|
I, Pos: integer;
|
|
begin
|
|
if Count = 0 then
|
|
begin
|
|
Result := 9999;
|
|
Exit;
|
|
end;
|
|
I := 0;
|
|
while I < count do
|
|
begin
|
|
Pos := TFloatingObj(Items[I]).Pos;
|
|
if Pos >= Posn then break;
|
|
Inc(I);
|
|
end;
|
|
if I = Count then Result := 9999
|
|
else
|
|
Result := TFloatingObj(Items[I]).Pos - Posn;
|
|
end;
|
|
|
|
function TImageObjList.PtInImage(X: integer; Y: integer; var IX, IY, Posn: integer;
|
|
var AMap, UMap: boolean; var MapItem: TMapItem;
|
|
var ImageObj: TImageObj): boolean;
|
|
var
|
|
I, J, LimX, LimY: integer;
|
|
LIY: integer;
|
|
Obj: TObject;
|
|
begin
|
|
Result := False;
|
|
for I := 0 to Count-1 do
|
|
begin
|
|
Obj := TObject(Items[I]);
|
|
if Obj is TImageObj then
|
|
with TImageObj(Obj) do
|
|
begin
|
|
IX := X-DrawX; {these are actual image, box if any is outside}
|
|
LIY := Y - DrawYY;
|
|
if HasBlueBox then begin LimX := ImageWidth-2; Limy := ImageHeight-2; end
|
|
else begin LimX := ImageWidth; Limy := ImageHeight; end;
|
|
if (IX >= 0) and (IX < LimX) and (LIY >= 0) and (LIY < LimY) then
|
|
begin
|
|
IY := LIY;
|
|
Result := True;
|
|
AMap := IsMap;
|
|
Posn := Pos;
|
|
UMap := False;
|
|
ImageObj := TImageObj(Obj);
|
|
if UseMap then
|
|
with ParentSectionList.MapList do
|
|
for J := 0 to Count-1 do
|
|
begin
|
|
MapItem := TMapItem(Items[J]);
|
|
if MapItem.MapName = MapName then
|
|
begin
|
|
UMap := True;
|
|
Exit;
|
|
end;
|
|
end;
|
|
Exit;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TImageObjList.PtInObject(X : integer; Y: integer; var Obj: TObject;
|
|
var IX, IY: integer): boolean;
|
|
var
|
|
I, LimX, LimY: integer;
|
|
LIY: integer;
|
|
Item: TObject;
|
|
begin
|
|
Result := False;
|
|
for I := 0 to Count-1 do
|
|
begin
|
|
Item := TImageObj(Items[I]);
|
|
if Item is TImageObj then
|
|
with TImageObj(Item) do
|
|
begin
|
|
IX := X-DrawX; {these are actual image, box if any is outside}
|
|
LIY := Y - DrawYY;
|
|
if HasBlueBox then begin LimX := ImageWidth-2; Limy := ImageHeight-2; end
|
|
else begin LimX := ImageWidth; Limy := ImageHeight; end;
|
|
if (IX >= 0) and (IX < LimX) and (LIY >= 0) and (LIY < LimY) then
|
|
begin
|
|
IY := LIY;
|
|
Result := True;
|
|
Obj := Item;
|
|
Exit;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{----------------ThtmlForm.Create}
|
|
constructor ThtmlForm.Create(AMasterList: TSectionList; L : TAttributeList);
|
|
var
|
|
I: integer;
|
|
begin
|
|
inherited Create;
|
|
MasterList := AMasterList;
|
|
AMasterList.htmlFormList.Add(Self);
|
|
Method := 'Get';
|
|
if Assigned(L) then
|
|
for I := 0 to L.Count-1 do
|
|
with TAttribute(L[I]) do
|
|
case Which of
|
|
MethodSy: Method := Name;
|
|
ActionSy: Action := Name;
|
|
TargetSy: Target := Name;
|
|
EncTypeSy: EncType := Name;
|
|
end;
|
|
ControlList := TFreeList.Create;
|
|
end;
|
|
|
|
destructor ThtmlForm.Destroy;
|
|
begin
|
|
ControlList.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure ThtmlForm.InsertControl(Ctrl: TFormControlObj);
|
|
begin
|
|
ControlList.Add(Ctrl);
|
|
if not (Ctrl is THiddenFormControlObj) then Inc(NonHiddenCount);
|
|
end;
|
|
|
|
procedure ThtmlForm.DoRadios(Radio: TRadioButtonFormControlObj);
|
|
var
|
|
S: string;
|
|
Ctrl: TFormControlObj;
|
|
I: integer;
|
|
begin
|
|
if Radio.Name <>'' then
|
|
begin
|
|
S := Radio.Name;
|
|
for I := 0 to ControlList.Count-1 do
|
|
begin
|
|
Ctrl := TFormControlObj(ControlList.Items[I]);
|
|
if (Ctrl is TRadioButtonFormControlObj) and (Ctrl <> Radio) then
|
|
if CompareText(Ctrl.Name, S) = 0 then
|
|
TRadioButtonFormControlObj(Ctrl).RButton.Checked := False;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure ThtmlForm.ResetControls;
|
|
var
|
|
I: integer;
|
|
begin
|
|
for I := 0 to ControlList.Count-1 do
|
|
TFormControlObj(ControlList.Items[I]).ResetToValue;
|
|
end;
|
|
|
|
procedure ThtmlForm.ControlKeyDown(Sender: TObject; var Key: Word;
|
|
Shift: TShiftState);
|
|
begin
|
|
if (Sender is TEdit) then
|
|
if (Key = VK_RETURN) then
|
|
SubmitTheForm('');
|
|
end;
|
|
|
|
procedure ThtmlForm.SubmitTheForm(const ButtonSubmission: string);
|
|
var
|
|
I, J: integer;
|
|
SL: TStringList;
|
|
S: string;
|
|
begin
|
|
if Assigned(MasterList.SubmitForm) then
|
|
begin
|
|
SL := TStringList.Create;
|
|
for I := 0 to ControlList.Count-1 do
|
|
with TFormControlObj(ControlList.Items[I]) do
|
|
begin
|
|
J := 0;
|
|
while GetSubmission(J, S) do
|
|
begin
|
|
if S <> '' then
|
|
SL.Add(S);
|
|
Inc(J);
|
|
end;
|
|
end;
|
|
if ButtonSubmission <> '' then
|
|
SL.Add(ButtonSubmission);
|
|
MasterList.SubmitForm(MasterList.TheOwner, Action, Target, EncType, Method, SL);
|
|
end;
|
|
end;
|
|
|
|
procedure ThtmlForm.SetSizes(Canvas: TCanvas);
|
|
var
|
|
I: integer;
|
|
begin
|
|
for I := 0 to ControlList.Count-1 do
|
|
TFormControlObj(ControlList.Items[I]).SetHeightWidth(Canvas);
|
|
end;
|
|
|
|
{----------------TFormControlObj.Create}
|
|
constructor TFormControlObj.Create(AMasterList: TSectionList;
|
|
Position: integer; L: TAttributeList);
|
|
var
|
|
T: TAttribute;
|
|
begin
|
|
inherited Create;
|
|
Pos := Position;
|
|
MasterList := AMasterList;
|
|
with (MasterList.Parser as ThlParser) do
|
|
begin
|
|
if not Assigned(CurrentForm) then {maybe someone forgot the <form> tag}
|
|
CurrentForm := ThtmlForm.Create(AMasterList, Nil);
|
|
AMasterList.FormControlList.Add(Self);
|
|
MyForm := CurrentForm;
|
|
end;
|
|
if L.Find(ValueSy, T) then
|
|
Value := T.Name;
|
|
if L.Find(NameSy, T) then
|
|
Name := T.Name;
|
|
if L.Find(OnClickSy, T) then
|
|
OnClickMessage := T.Name;
|
|
MyForm.InsertControl(Self);
|
|
end;
|
|
|
|
destructor TFormControlObj.Destroy;
|
|
begin
|
|
if Assigned(FControl) then {hidden controls are Nil}
|
|
begin
|
|
TPaintPanel(MasterList.PPanel).RemoveControl(FControl);
|
|
FControl.Free;
|
|
end;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TFormControlObj.EnterEvent(Sender: TObject);
|
|
{Once form control entered, insure all form controls are tab active}
|
|
var
|
|
I: integer;
|
|
begin
|
|
MasterList.ControlEnterEvent(Self);
|
|
with MasterList.FormControlList do
|
|
begin
|
|
for I := 0 to Count-1 do
|
|
with TFormControlObj(Items[I]) do
|
|
if not ShowIt and Assigned(FControl) then
|
|
begin
|
|
FControl.Show; {makes it tab active}
|
|
FControl.Left := -4000; {even if it can't be seen}
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TFormControlObj.ExitEvent(Sender: TObject);
|
|
begin
|
|
MasterList.AdjustFormControls;
|
|
end;
|
|
|
|
function TFormControlObj.GetControl: TWinControl;
|
|
begin
|
|
Result := FControl;
|
|
end;
|
|
|
|
procedure TFormControlObj.ResetToValue;
|
|
begin end;
|
|
|
|
function TFormControlObj.GetSubmission(Index: integer; var S: string): boolean;
|
|
begin
|
|
Result := False;
|
|
end;
|
|
|
|
procedure TFormControlObj.SetHeightWidth(Canvas: TCanvas);
|
|
begin
|
|
if Assigned(FControl) and not Assigned(FControl.Parent) then
|
|
FControl.Parent := TPaintPanel(MasterList.PPanel);
|
|
end;
|
|
|
|
procedure TFormControlObj.FormControlClick(Sender: TObject);
|
|
begin
|
|
if Assigned(MasterList.ObjectClick) then
|
|
MasterList.ObjectClick(MasterList.TheOwner, Self, OnClickMessage);
|
|
end;
|
|
|
|
constructor TImageFormControlObj.Create(AMasterList: TSectionList;
|
|
Position: integer; L: TAttributeList);
|
|
begin
|
|
inherited Create(AMasterList, Position, L);
|
|
XPos := -1; {so a button press won't submit image data}
|
|
end;
|
|
|
|
procedure TImageFormControlObj.ImageClick;
|
|
begin
|
|
FormControlClick(Self);
|
|
XPos := XTmp; YPos := YTmp;
|
|
MyForm.SubmitTheForm('');
|
|
end;
|
|
|
|
function TImageFormControlObj.GetSubmission(Index: integer; var S: string): boolean;
|
|
begin
|
|
Result := False;
|
|
if (Index <= 1) and (XPos >= 0) then
|
|
begin
|
|
S := '';
|
|
if Name <> '' then S := Name+'.';
|
|
if Index = 0 then S := S+'x='+IntToStr(XPos)
|
|
else
|
|
begin {index = 1}
|
|
S := S+'y='+IntToStr(YPos);
|
|
XPos := -1;
|
|
end;
|
|
Result := True;
|
|
end;
|
|
end;
|
|
|
|
{----------------THiddenFormControlObj.GetSubmission}
|
|
function THiddenFormControlObj.GetSubmission(Index: integer; var S: string): boolean;
|
|
begin
|
|
Result := Index = 0;
|
|
if Result then
|
|
S := Name+'='+Value;
|
|
end;
|
|
|
|
{----------------TEditFormControlObj.Create}
|
|
constructor TEditFormControlObj.Create(AMasterList: TSectionList;
|
|
Position: integer; L: TAttributeList; const Typ: string);
|
|
var
|
|
T: TAttribute;
|
|
PntPanel: TPaintPanel;
|
|
I: integer;
|
|
begin
|
|
inherited Create(AMasterList, Position, L);
|
|
EditSize := 20;
|
|
if L.Find(SizeSy, T) then
|
|
begin
|
|
if T.Value > 0 then EditSize := T.Value
|
|
else
|
|
begin {see if it's comma delimited list}
|
|
I := IntMin(System.Pos(',', T.Name), System.Pos(' ', T.Name));
|
|
if I > 1 then EditSize := StrToIntDef(copy(T.Name, 1, I-1), 20);
|
|
end;
|
|
end;
|
|
PntPanel := TPaintPanel(AMasterList.PPanel);
|
|
FControl := TEdit.Create(PntPanel);
|
|
with TEdit(FControl) do
|
|
begin
|
|
Top := -400; {so will be invisible until placed}
|
|
Width := 120;
|
|
Height := 20;
|
|
Text := Value;
|
|
Font.Name := AMasterList.PreFontName;
|
|
Font.Size := 10;
|
|
if L.Find(MaxLengthSy, T) then
|
|
MaxLength := T.Value;
|
|
if Typ = 'password' then
|
|
PassWordChar := '*';
|
|
OnKeyDown := {$IFDEF HL_LAZARUS}@{$ENDIF}MyForm.ControlKeyDown;
|
|
OnEnter := {$IFDEF HL_LAZARUS}@{$ENDIF}EnterEvent;
|
|
OnExit := {$IFDEF HL_LAZARUS}@{$ENDIF}ExitEvent;
|
|
OnClick := {$IFDEF HL_LAZARUS}@{$ENDIF}FormControlClick;
|
|
end;
|
|
end;
|
|
|
|
procedure TEditFormControlObj.ResetToValue;
|
|
begin
|
|
TEdit(FControl).Text := Value;
|
|
end;
|
|
|
|
function TEditFormControlObj.GetSubmission(Index: integer; var S: string): boolean;
|
|
begin
|
|
if Index = 0 then
|
|
begin
|
|
Result := True;
|
|
S := Name+'='+TEdit(FControl).Text;
|
|
end
|
|
else Result := False;
|
|
end;
|
|
|
|
procedure TEditFormControlObj.SetHeightWidth(Canvas: TCanvas);
|
|
begin
|
|
if not Assigned(FControl.Parent) then
|
|
FControl.Parent := TPaintPanel(MasterList.PPanel);
|
|
with TEdit(FControl) do
|
|
begin
|
|
Canvas.Font := Font;
|
|
Width := Canvas.TextWidth('A')*EditSize+5;
|
|
end;
|
|
end;
|
|
|
|
{----------------TButtonFormControlObj.Create}
|
|
constructor TButtonFormControlObj.Create(AMasterList: TSectionList;
|
|
Position: integer; L: TAttributeList; const Typ: string);
|
|
var
|
|
PntPanel: TPaintPanel;
|
|
begin
|
|
inherited Create(AMasterList, Position, L);
|
|
if Typ = 'submit' then
|
|
begin
|
|
Which := Submit;
|
|
if Value = '' then
|
|
Value := 'Submit';
|
|
end
|
|
else if Typ = 'reset' then
|
|
begin
|
|
Which := ResetB;
|
|
if Value = '' then
|
|
Value := 'Reset';
|
|
end
|
|
else
|
|
begin
|
|
Which := Button;
|
|
if Value = '' then
|
|
Value := 'Button';
|
|
end;
|
|
PntPanel := TPaintPanel(AMasterList.PPanel);
|
|
FControl := TButton.Create(PntPanel);
|
|
with TButton(FControl) do
|
|
begin
|
|
Top := -400; {so will be invisible until placed}
|
|
OnClick := {$IFDEF HL_LAZARUS}@{$ENDIF}ButtonClick;
|
|
Caption := Value;
|
|
OnEnter := {$IFDEF HL_LAZARUS}@{$ENDIF}EnterEvent;
|
|
OnExit := {$IFDEF HL_LAZARUS}@{$ENDIF}ExitEvent;
|
|
end;
|
|
end;
|
|
|
|
procedure TButtonFormControlObj.ButtonClick(Sender: TObject);
|
|
var
|
|
S: string;
|
|
begin
|
|
FormControlClick(Self);
|
|
if Which = ResetB then
|
|
MyForm.ResetControls
|
|
else if Which = Submit then
|
|
if Name = '' then
|
|
MyForm.SubmitTheForm('')
|
|
else
|
|
begin
|
|
S := Name;
|
|
MyForm.SubmitTheForm(S+'='+Value);
|
|
end;
|
|
end;
|
|
|
|
procedure TButtonFormControlObj.SetHeightWidth(Canvas: TCanvas);
|
|
begin
|
|
if Assigned(FControl) and not Assigned(FControl.Parent) then
|
|
FControl.Parent := TPaintPanel(MasterList.PPanel);
|
|
with TButton(FControl) do
|
|
begin
|
|
Canvas.Font := Font;
|
|
Height := Canvas.TextHeight('A')+8;
|
|
Width := Canvas.TextWidth(Caption)+20;
|
|
end;
|
|
end;
|
|
|
|
{----------------TCheckBoxFormControlObj.Create}
|
|
constructor TCheckBoxFormControlObj.Create(AMasterList: TSectionList;
|
|
Position: integer; L: TAttributeList);
|
|
var
|
|
T: TAttribute;
|
|
PntPanel: TPaintPanel;
|
|
begin
|
|
inherited Create(AMasterList, Position, L);
|
|
if Value = '' then Value := 'on';
|
|
BaseLine := True; {sits on text baseline}
|
|
if L.Find(CheckedSy, T) then IsChecked := True;
|
|
PntPanel := TPaintPanel(AMasterList.PPanel);
|
|
FControl := TCheckBox.Create(PntPanel);
|
|
with TCheckBox(FControl) do
|
|
begin
|
|
Top := -400; {so will be invisible until placed}
|
|
Width := 13;
|
|
Height := 13;
|
|
Checked := IsChecked;
|
|
OnClick := {$IFDEF HL_LAZARUS}@{$ENDIF}FormControlClick;
|
|
OnEnter := {$IFDEF HL_LAZARUS}@{$ENDIF}EnterEvent;
|
|
OnExit := {$IFDEF HL_LAZARUS}@{$ENDIF}ExitEvent;
|
|
end;
|
|
end;
|
|
|
|
procedure TCheckBoxFormControlObj.ResetToValue;
|
|
begin
|
|
TCheckBox(FControl).Checked := IsChecked;
|
|
end;
|
|
|
|
function TCheckBoxFormControlObj.GetSubmission(Index: integer; var S: string): boolean;
|
|
begin
|
|
if (Index = 0) and TCheckBox(FControl).Checked then
|
|
begin
|
|
Result := True;
|
|
S := Name+'='+Value;
|
|
end
|
|
else Result := False;
|
|
end;
|
|
|
|
constructor TRadioButtonFormControlObj.Create(AMasterList: TSectionList;
|
|
Position: integer; L: TAttributeList; ACell: TCell);
|
|
var
|
|
T: TAttribute;
|
|
PntPanel: TPaintPanel;
|
|
begin
|
|
inherited Create(AMasterList, Position, L);
|
|
MyCell := ACell;
|
|
PntPanel := TPaintPanel(AMasterList.PPanel);
|
|
FControl := TPanel.Create(PntPanel);
|
|
BaseLine := True; {sits on text baseline}
|
|
if L.Find(CheckedSy, T) then IsChecked := True;
|
|
{Use a TPanel to isolate RadioButton action}
|
|
with TPanel(FControl) do
|
|
begin
|
|
Top := -400; {so will be invisible until placed}
|
|
Width := 13;
|
|
Height := 14;
|
|
BevelOuter := bvNone;
|
|
BevelInner := bvNone;
|
|
ParentColor := False;
|
|
end;
|
|
RButton := TRadioButton.Create(FControl);
|
|
RButton.Checked := IsChecked;
|
|
FControl.InsertControl(RButton);
|
|
RButton.OnClick := {$IFDEF HL_LAZARUS}@{$ENDIF}RadioClick;
|
|
RButton.OnEnter := {$IFDEF HL_LAZARUS}@{$ENDIF}EnterEvent;
|
|
RButton.OnExit := {$IFDEF HL_LAZARUS}@{$ENDIF}ExitEvent;
|
|
end;
|
|
|
|
function TRadioButtonFormControlObj.GetControl: TWinControl;
|
|
begin
|
|
Result := RButton;
|
|
end;
|
|
|
|
procedure TRadioButtonFormControlObj.RadioClick(Sender: TObject);
|
|
begin
|
|
MyForm.DoRadios(Self);
|
|
FormControlClick(Self);
|
|
end;
|
|
|
|
procedure TRadioButtonFormControlObj.ResetToValue;
|
|
begin
|
|
RButton.Checked := IsChecked;
|
|
end;
|
|
|
|
function TRadioButtonFormControlObj.GetSubmission(Index: integer;
|
|
var S: string): boolean;
|
|
begin
|
|
if (Index = 0) and RButton.Checked then
|
|
begin
|
|
Result := True;
|
|
S := Name+'='+Value;
|
|
end
|
|
else Result := False;
|
|
end;
|
|
|
|
{----------------TCell.Create}
|
|
constructor TCell.Create(Master: TSectionList);
|
|
begin
|
|
inherited Create;
|
|
MasterList := Master;
|
|
IMgr := IndentManager.Create;
|
|
end;
|
|
|
|
destructor TCell.Destroy;
|
|
begin
|
|
IMgr.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
{----------------TCell.Add}
|
|
procedure TCell.Add(Item: TSectionBase);
|
|
begin
|
|
if Assigned(Item) then
|
|
begin
|
|
inherited Add(Item);
|
|
if (Item is TSection) then
|
|
TSection(Item).Finish;
|
|
Item.SetParent(MasterList);
|
|
end;
|
|
end;
|
|
|
|
{----------------TCell.UpdateFonts}
|
|
procedure TCell.UpdateFonts;
|
|
var
|
|
I: integer;
|
|
begin
|
|
for I := 0 to Count-1 do
|
|
TSectionBase(Items[I]).UpdateFonts;
|
|
end;
|
|
|
|
{----------------TCell.FindSectionAtPosition}
|
|
function TCell.FindSectionAtPosition(Pos: integer;
|
|
var TopPos: integer; var Index: integer): TSectionBase;
|
|
{Find the section which contains the Y Position, Pos. Return also the position
|
|
of the top of that section and the index of that section}
|
|
var
|
|
I: integer;
|
|
H, Delta: integer;
|
|
begin
|
|
H := 0;
|
|
for I := 0 to Count-1 do
|
|
begin
|
|
Delta := TSectionBase(Items[I]).SectionHeight;
|
|
Inc(H, Delta);
|
|
if H > Pos then
|
|
begin
|
|
TopPos := H-Delta;
|
|
Result := TSectionBase(Items[I]);
|
|
Index := I;
|
|
Exit;
|
|
end;
|
|
end;
|
|
Result := Nil;
|
|
end;
|
|
|
|
{----------------TCell.GetURL}
|
|
function TCell.GetURL(Canvas: TCanvas; X: integer; Y: integer;
|
|
var UrlTarg: TUrlTarget; var FormControl: TImageFormControlObj): boolean;
|
|
{Y is absolute}
|
|
var
|
|
I: integer;
|
|
H: integer;
|
|
begin
|
|
Result := False;
|
|
FormControl := Nil;
|
|
UrlTarg := Nil;
|
|
H := 0;
|
|
for I := 0 to Count-1 do
|
|
with TSectionBase(Items[I]) do
|
|
begin
|
|
if (Y >= H) and (Y < H+DrawHeight) then
|
|
begin
|
|
Result := GetURL(Canvas, X, Y-H, UrlTarg, FormControl);
|
|
if Result then
|
|
Exit;
|
|
end;
|
|
Inc(H, SectionHeight);
|
|
end;
|
|
end;
|
|
|
|
{----------------TCell.PtInObject}
|
|
function TCell.PtInObject(X: integer; Y: integer; var Obj: TObject;
|
|
var IX, IY: integer): boolean;
|
|
{Y is absolute}
|
|
var
|
|
I: integer;
|
|
H: integer;
|
|
begin
|
|
Result := False;
|
|
Obj := Nil;
|
|
H := 0;
|
|
for I := 0 to Count-1 do
|
|
with TSectionBase(Items[I]) do
|
|
begin
|
|
if (Y >= H) and (Y < H+DrawHeight) then
|
|
begin
|
|
Result := PtInObject(X, Y-H, Obj, IX, IY);
|
|
if Result then
|
|
Exit;
|
|
end;
|
|
Inc(H, SectionHeight);
|
|
end;
|
|
end;
|
|
|
|
{----------------TCell.FindCursor}
|
|
function TCell.FindCursor(Canvas: TCanvas; X: Integer; Y: integer;
|
|
var XR: integer; var YR: integer; var Ht: integer;
|
|
var SCell: TObject; var Intext: boolean): integer;
|
|
{Y, YR is absolute}
|
|
var
|
|
Dummy: integer;
|
|
H: integer;
|
|
S: TSectionBase;
|
|
begin
|
|
S := FindSectionAtPosition(Y, H, Dummy);
|
|
if Assigned(S) then
|
|
begin
|
|
Result := S.FindCursor(Canvas, X, Y-H, XR, YR, Ht, SCell, InText);
|
|
Inc(YR, H);
|
|
end
|
|
else Result := -1;
|
|
if (Result >= 0) and not Assigned(SCell) then SCell := Self;
|
|
end;
|
|
|
|
{----------------TCell.FindString}
|
|
function TCell.FindString(From: integer; PC: PChar; MatchCase: boolean): integer;
|
|
var
|
|
I: integer;
|
|
begin
|
|
Result := -1;
|
|
for I := 0 to Count-1 do
|
|
begin
|
|
Result := TSectionBase(Items[I]).FindString(From, PC, MatchCase);
|
|
if Result >= 0 then
|
|
Break;
|
|
end;
|
|
end;
|
|
|
|
{----------------TCell.FindSourcePos}
|
|
function TCell.FindSourcePos(DocPos: integer): integer;
|
|
var
|
|
I: integer;
|
|
begin
|
|
Result := -1;
|
|
for I := 0 to Count-1 do
|
|
begin
|
|
Result := TSectionBase(Items[I]).FindSourcePos(DocPos);
|
|
if Result >= 0 then
|
|
Break;
|
|
end;
|
|
end;
|
|
|
|
{----------------TCell.FindDocPos}
|
|
function TCell.FindDocPos(SourcePos: integer; Prev: boolean): integer;
|
|
var
|
|
I: integer;
|
|
begin
|
|
Result := -1;
|
|
if not Prev then
|
|
for I := 0 to Count-1 do
|
|
begin
|
|
Result := TSectionBase(Items[I]).FindDocPos(SourcePos, Prev);
|
|
if Result >= 0 then
|
|
Break;
|
|
end
|
|
else //Prev, iterate backwards
|
|
for I := Count-1 downto 0 do
|
|
begin
|
|
Result := TSectionBase(Items[I]).FindDocPos(SourcePos, Prev);
|
|
if Result >= 0 then
|
|
Break;
|
|
end
|
|
end;
|
|
|
|
{----------------TCell.CursorToXY}
|
|
function TCell.CursorToXY(Canvas: TCanvas; Cursor: integer; var X: integer;
|
|
var Y: integer): boolean;
|
|
var
|
|
I: integer;
|
|
begin
|
|
Result := False;
|
|
for I := 0 to Count-1 do
|
|
begin
|
|
Result := TSectionBase(Items[I]).CursorToXY(Canvas, Cursor, X, Y);
|
|
if Result then Break;
|
|
end;
|
|
end;
|
|
|
|
{----------------TCell.GetChAtPos}
|
|
function TCell.GetChAtPos(Pos: integer; var Ch: char; var Obj: TObject): boolean;
|
|
var
|
|
I: integer;
|
|
begin
|
|
Result := False;
|
|
if (Pos >= StartCurs) and (Pos <= StartCurs+Len) then
|
|
for I := 0 to Count-1 do
|
|
begin
|
|
Result := TSectionBase(Items[I]).GetChAtPos(Pos, Ch, Obj);
|
|
if Result then Break;
|
|
end;
|
|
end;
|
|
|
|
{----------------TCell.CopyToClipboard}
|
|
procedure TCell.CopyToClipboard;
|
|
var
|
|
I: integer;
|
|
SLE, SLB: integer;
|
|
begin
|
|
if not Assigned(MasterList) then Exit; {dummy cell}
|
|
SLB := MasterList.SelB;
|
|
SLE := MasterList.SelE;
|
|
if SLE <= SLB then Exit; {nothing to do}
|
|
|
|
for I := 0 to Count-1 do
|
|
with TSectionBase(Items[I]) do
|
|
begin
|
|
if (SLB >= StartCurs + Len) then Continue;
|
|
if (SLE <= StartCurs) then Break;
|
|
CopyToClipboard;
|
|
end;
|
|
end;
|
|
|
|
{----------------TCell.DoLogic}
|
|
function TCell.DoLogic(Canvas: TCanvas; Y: integer; Width: integer;
|
|
var ScrollWidth: integer; var Curs: integer;
|
|
StartY, StartCount: integer): integer;
|
|
{Do the entire layout of the cell or document. Return the total document
|
|
pixel height}
|
|
var
|
|
I, Sw, TheCount: integer;
|
|
H, IB: integer;
|
|
begin
|
|
IMgr.Clear;
|
|
IMgr.Reset(0, Width);
|
|
IMgr.Width := Width;
|
|
YValue := Y;
|
|
StartCurs := Curs;
|
|
H := StartY;
|
|
TheCount := Count;
|
|
I := StartCount;
|
|
while I < TheCount do
|
|
begin
|
|
try
|
|
H := TSectionBase(Items[I]).DrawLogic(Canvas, Y+H, IMgr, Sw, Curs)+ H;
|
|
ScrollWidth := IntMax(ScrollWidth, Sw);
|
|
Inc(I);
|
|
except
|
|
on E:EProcessError do
|
|
begin
|
|
MessageDlg(E.Message, mtError, [mbOK], 0);
|
|
TSectionBase(Items[I]).Free;
|
|
Delete(I);
|
|
Dec(TheCount);
|
|
end;
|
|
end;
|
|
end;
|
|
Len := Curs - StartCurs;
|
|
writeln('TCell.DoLogic ',HexStr(Cardinal(Self),8),' ',Curs,' ',StartCurs,' Len=',Len);
|
|
Result := H;
|
|
IB := IMgr.ImageBottom - YValue; {check for image overhang}
|
|
if IB > Result then
|
|
Result := IB;
|
|
end;
|
|
|
|
{----------------TCell.MinMaxWidth}
|
|
procedure TCell.MinMaxWidth(Canvas: TCanvas; var Min, Max: integer);
|
|
{Find the Width the cell would take if no wordwrap, Max, and the width if wrapped
|
|
at largest word, Min}
|
|
var
|
|
I, Mn, Mx: integer;
|
|
begin
|
|
Max := 0; Min := 0;
|
|
for I := 0 to Count-1 do
|
|
begin
|
|
TSectionBase(Items[I]).MinMaxWidth(Canvas, Mn, Mx);
|
|
Max := IntMax(Max, Mx);
|
|
Min := IntMax(Min, Mn);
|
|
end;
|
|
end;
|
|
|
|
{----------------TCell.Draw}
|
|
function TCell.Draw(Canvas: TCanvas; ARect: TRect; ClipWidth, X: integer;
|
|
Y: integer): integer;
|
|
{draw the document or cell. Note: individual sections not in ARect don't bother
|
|
drawing}
|
|
var
|
|
I: integer;
|
|
H: integer;
|
|
begin
|
|
IMgr.Reset(X, X+IMgr.Width);
|
|
IMgr.ClipWidth := ClipWidth;
|
|
H := Y;
|
|
for I := 0 to Count-1 do
|
|
begin
|
|
writeln('TCell.Draw ',HexStr(Cardinal(Self),8),' ',I,' ',TSectionBase(Items[I]).ClassName);
|
|
H := TSectionBase(Items[I]).Draw(Canvas, ARect, IMgr, X, H);
|
|
end;
|
|
Result := H;
|
|
end;
|
|
|
|
{----------------TSectionList}
|
|
constructor TSectionList.Create(Owner, APaintPanel: TWinControl);
|
|
begin
|
|
inherited Create(Self);
|
|
TheOwner := Owner;
|
|
PPanel := APaintPanel;
|
|
htmlFormList := TFreeList.Create;
|
|
AGifList := TList.Create;
|
|
MapList := TFreeList.Create;
|
|
FormControlList := TList.Create;
|
|
MissingImages := TStringList.Create;
|
|
MissingImages.Sorted := False;
|
|
LinkList := TList.Create;
|
|
UnLine := [fsUnderline];
|
|
end;
|
|
|
|
destructor TSectionList.Destroy;
|
|
begin
|
|
Clear;
|
|
htmlFormList.Free;
|
|
MapList.Free;
|
|
AGifList.Free;
|
|
Timer.Free;
|
|
FormControlList.Free;
|
|
MissingImages.Free;
|
|
LinkList.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TSectionList.GetURL(Canvas: TCanvas; X: integer; Y: integer;
|
|
var UrlTarg: TUrlTarget; var FormControl: TImageFormControlObj): boolean;
|
|
var
|
|
OldLink: TFontObj;
|
|
OldImage: TImageObj;
|
|
begin
|
|
OldLink := ActiveLink;
|
|
OldImage := ActiveImage;
|
|
ActiveLink := Nil;
|
|
ActiveImage := Nil;
|
|
Result := inherited GetUrl(Canvas, X, Y, UrlTarg, FormControl);
|
|
if LinksActive and (ActiveLink <> OldLink) then
|
|
begin
|
|
if OldLink <> Nil then OldLink.Hover := False;
|
|
if ActiveLink <> Nil then ActiveLink.Hover := True;
|
|
PPanel.Invalidate;
|
|
end;
|
|
if (ActiveImage <> OldImage) then
|
|
begin
|
|
if OldImage <> Nil then OldImage.Hover := False;
|
|
if ActiveImage <> Nil then ActiveImage.Hover := True;
|
|
PPanel.Invalidate;
|
|
end;
|
|
end;
|
|
|
|
procedure TSectionList.CancelActives;
|
|
begin
|
|
if Assigned(ActiveLink) or Assigned(ActiveImage) then
|
|
PPanel.Invalidate;
|
|
if Assigned(ActiveLink) then
|
|
begin
|
|
ActiveLink.Hover := False;
|
|
ActiveLink := Nil;
|
|
end;
|
|
if Assigned(ActiveImage) then
|
|
begin
|
|
ActiveImage.Hover := False;
|
|
ActiveImage := Nil;
|
|
end;
|
|
end;
|
|
|
|
procedure TSectionList.CheckGIFList(Sender: TObject);
|
|
var
|
|
I: integer;
|
|
begin
|
|
for I := 0 to AGifList.Count-1 do
|
|
with TGifImage(AGifList.Items[I]) do
|
|
if ShowIt then
|
|
begin
|
|
CheckTime(PPanel);
|
|
end;
|
|
Timer.Interval := 50;
|
|
end;
|
|
|
|
procedure TSectionList.SetYOffset(Y: integer);
|
|
var
|
|
I, J: integer;
|
|
begin
|
|
if Y <> YOff then
|
|
begin
|
|
YOff := Y;
|
|
YOffChange := True;
|
|
{After next Draw, hide all formcontrols that aren't to be shown}
|
|
for I := 0 to htmlFormList.Count-1 do
|
|
with ThtmlForm(htmlFormList.Items[I]) do
|
|
for J := 0 to ControlList.Count-1 do
|
|
with TFormControlObj(ControlList.Items[J]) do
|
|
ShowIt := False;
|
|
end;
|
|
end;
|
|
|
|
procedure TSectionList.Clear;
|
|
begin
|
|
BackgroundBitmap := Nil;
|
|
BackgroundMask := Nil;
|
|
if BitmapLoaded and (BitmapName <> '') then
|
|
BitmapList.DecUsage(BitmapName);
|
|
BitmapName := '';
|
|
BitmapLoaded := False;
|
|
htmlFormList.Clear;
|
|
if Assigned(FormControlList) then
|
|
FormControlList.Clear;
|
|
AGifList.Clear;
|
|
Timer.Free;
|
|
Timer := Nil;
|
|
SelB := 0;
|
|
SelE := 0;
|
|
MapList.Clear;
|
|
MissingImages.Clear;
|
|
if Assigned(LinkList) then
|
|
LinkList.Clear;
|
|
ActiveLink := Nil;
|
|
ActiveImage := Nil;
|
|
inherited Clear;
|
|
end;
|
|
|
|
{----------------TSectionList.GetSelLength:}
|
|
function TSectionList.GetSelLength: integer;
|
|
var
|
|
I: integer;
|
|
begin
|
|
Result := 0;
|
|
if SelE <= SelB then Exit; {nothing to do}
|
|
CB := SelTextCount.Create;
|
|
try
|
|
for I := 0 to Count-1 do
|
|
with TSectionBase(Items[I]) do
|
|
begin
|
|
if (SelB >= StartCurs + Len) then Continue;
|
|
if (SelE <= StartCurs) then Break;
|
|
CopyToClipboard;
|
|
end;
|
|
Result := CB.Terminate;
|
|
finally
|
|
CB.Free;
|
|
end;
|
|
end;
|
|
|
|
{----------------TSectionList.GetSelTextBuf}
|
|
function TSectionList.GetSelTextBuf(Buffer: PChar; BufSize: integer): integer;
|
|
var
|
|
I: integer;
|
|
begin
|
|
if BufSize >= 1 then
|
|
begin
|
|
Buffer[0] := #0;
|
|
Result := 1;
|
|
end
|
|
else Result := 0;
|
|
if SelE <= SelB then Exit; {nothing to do}
|
|
CB := SelTextBuf.Create(Buffer, BufSize);
|
|
try
|
|
for I := 0 to Count-1 do
|
|
with TSectionBase(Items[I]) do
|
|
begin
|
|
if (SelB >= StartCurs + Len) then Continue;
|
|
if (SelE <= StartCurs) then Break;
|
|
CopyToClipboard;
|
|
end;
|
|
Result := CB.Terminate;
|
|
finally
|
|
CB.Free;
|
|
end;
|
|
end;
|
|
|
|
{----------------TSectionList.DoLogic}
|
|
function TSectionList.DoLogic(Canvas: TCanvas; Y: integer; Width: integer;
|
|
var ScrollWidth: integer; var Curs: integer;
|
|
StartY, StartCount: integer): integer;
|
|
var
|
|
I: integer;
|
|
begin
|
|
if Assigned(Timer) then Timer.Enabled := False;
|
|
for I := 0 to htmlFormList.Count-1 do
|
|
ThtmlForm(htmlFormList.Items[I]).SetSizes(Canvas);
|
|
|
|
Result := inherited DoLogic(Canvas, Y, Width, ScrollWidth, Curs, StartY, StartCount);
|
|
|
|
for I := 0 to AGifList.Count-1 do
|
|
with TGifImage(AGifList.Items[I]) do
|
|
begin
|
|
CurrentFrame := 1; {required for dtDoNothing and background}
|
|
Animate := False; {starts iteration count from 1}
|
|
Animate := True;
|
|
end;
|
|
if not Assigned(Timer) then
|
|
begin
|
|
Timer := TTimer.Create(TheOwner as ThtmlLite);
|
|
Timer.Interval := 50;
|
|
Timer.OnTimer := {$IFDEF HL_LAZARUS}@{$ENDIF}CheckGIFList;
|
|
end;
|
|
if Assigned(Timer) then Timer.Enabled := AGifList.Count >= 1;
|
|
AdjustFormControls;
|
|
end;
|
|
|
|
procedure TSectionList.AdjustFormControls;
|
|
var
|
|
I: integer;
|
|
|
|
function ActiveInList: boolean; {see if active control is a form control}
|
|
var
|
|
Control: TWinControl;
|
|
I: integer;
|
|
begin
|
|
with FormControlList do
|
|
begin
|
|
Result := False;
|
|
Control := Screen.ActiveControl;
|
|
for I := 0 to Count-1 do
|
|
with TFormControlObj(Items[I]) do
|
|
if FControl = Control then
|
|
begin
|
|
Result := True;
|
|
Break;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
if (FormControlList.Count = 0) then Exit;
|
|
with FormControlList do
|
|
if not ActiveInList then
|
|
begin {if none of the formcontrols are active, turn off tabs for those off screen}
|
|
for I := 0 to Count-1 do
|
|
with TFormControlObj(Items[I]) do
|
|
if not ShowIt and Assigned(FControl) then
|
|
FControl.Hide; {hides and turns off tabs}
|
|
end
|
|
else
|
|
for I := 0 to Count-1 do
|
|
with TFormControlObj(Items[I]) do
|
|
if not ShowIt and Assigned(FControl) then
|
|
begin
|
|
FControl.Show; {turns on tabs}
|
|
FControl.Left := -4000; {but it still can't be seen}
|
|
end;
|
|
end;
|
|
|
|
{----------------TSectionList.Draw}
|
|
function TSectionList.Draw(Canvas: TCanvas; ARect: TRect; ClipWidth, X: integer;
|
|
Y:integer): integer;
|
|
var
|
|
OldPal: HPalette;
|
|
I: integer;
|
|
begin
|
|
PageBottom := ARect.Bottom + YOff;
|
|
if Assigned(Timer) then Timer.Enabled := False;
|
|
for I := 0 to AGifList.Count-1 do
|
|
with TGifImage(AGifList.Items[I]) do
|
|
begin
|
|
ShowIt := False;
|
|
end;
|
|
OldPal := SelectPalette(Canvas.Handle, ThePalette, True);
|
|
RealizePalette(Canvas.Handle);
|
|
try
|
|
writeln('TSectionList.Draw ');
|
|
Result := inherited Draw(Canvas, ARect, ClipWidth, X, Y);
|
|
finally
|
|
SelectPalette(Canvas.Handle, OldPal, True);
|
|
end;
|
|
if YOffChange then
|
|
begin
|
|
AdjustFormControls;
|
|
YOffChange := False;
|
|
end;
|
|
if Assigned(Timer) then Timer.Enabled := AGifList.Count >= 1;
|
|
end;
|
|
|
|
procedure TSectionList.SetFonts(const Name, PreName: String; ASize: integer;
|
|
AColor, AHotSpot, AVisitedColor, AActiveColor, ABackground: TColor;
|
|
LnksActive: boolean);
|
|
begin
|
|
FontName := Name;
|
|
PreFontName := PreName;
|
|
FontSize := ASize;
|
|
FontColor := AColor;
|
|
HotSpotColor := AHotSpot;
|
|
LinkVisitedColor := AVisitedColor;
|
|
LinkActiveColor := AActiveColor;
|
|
LinksActive := LnksActive;
|
|
SetBackground(ABackground);
|
|
UpdateFonts;
|
|
end;
|
|
|
|
procedure TSectionList.SetBackground(ABackground: TColor);
|
|
begin
|
|
Background := ABackground;
|
|
if Assigned(OnBackGroundChange) then
|
|
OnBackgroundChange(Self);
|
|
end;
|
|
|
|
procedure TSectionList.SetBackgroundBitmap(Name: String);
|
|
begin
|
|
BackgroundBitmap := Nil;
|
|
BitmapName := Name;
|
|
BitmapLoaded := False;
|
|
end;
|
|
|
|
{----------------TSectionList.InsertImage}
|
|
procedure TSectionList.InsertImage(const Src: string; Stream: TMemoryStream;
|
|
var Reformat: boolean);
|
|
var
|
|
UName: string;
|
|
I, J: integer;
|
|
Pair: TBitmapItem;
|
|
NonAnimated, Rformat: boolean;
|
|
Image: TPersistent;
|
|
AMask: TBitmap;
|
|
Tr, Transparent: Transparency;
|
|
Obj: TObject;
|
|
Tmp: TGifImage;
|
|
begin
|
|
Image := Nil; AMask := Nil;
|
|
Reformat := False;
|
|
UName := Trim(Uppercase(Src));
|
|
I := BitmapList.IndexOf(UName); {first see if the bitmap is already loaded}
|
|
J := MissingImages.IndexOf(UName); {see if it's in missing image list}
|
|
if (I = -1) and (J >= 0) then
|
|
begin
|
|
Transparent := NotTransp;
|
|
if Assigned(Stream) and (Stream.Memory <> Nil) and (Stream.Size >= 1) then
|
|
begin
|
|
NonAnimated := True;
|
|
if KindOfImage(Stream.Memory) in [GIF, Gif89] then
|
|
Image := CreateAGifFromStream(NonAnimated, Stream);
|
|
if Assigned(Image) then
|
|
begin
|
|
if NonAnimated then
|
|
begin {else already have animated GIF}
|
|
Tmp := TGifImage(Image);
|
|
Image := TBitmap.Create;
|
|
Image.Assign(Tmp.MaskedBitmap);
|
|
if Tmp.IsTransparent then
|
|
begin
|
|
AMask := TBitmap.Create;
|
|
AMask.Assign(Tmp.Mask);
|
|
Transparent := TGif;
|
|
end;
|
|
Tmp.Free;
|
|
end;
|
|
end
|
|
else
|
|
Image := GetImageAndMaskFromStream(Stream, Transparent, AMask);
|
|
end;
|
|
if Assigned(Image) then {put in Cache}
|
|
try
|
|
if Assigned(AMask) then Tr := Transparent
|
|
else Tr := NotTransp;
|
|
Pair := TBitmapItem.Create(Image, AMask, Tr);
|
|
try
|
|
BitmapList.AddObject(UName, Pair); {put new bitmap in list}
|
|
BitmapList.DecUsage(UName); {this does not count as being used yet}
|
|
except
|
|
Pair.Mask := Nil;
|
|
Pair.MImage:= Nil;
|
|
Pair.Free;
|
|
end;
|
|
except {accept inability to create}
|
|
end;
|
|
end;
|
|
if (I >= 0) or Assigned(Image) then {a valid image in the Cache}
|
|
begin
|
|
while J >= 0 do
|
|
begin
|
|
Obj := MissingImages.Objects[J];
|
|
if (Obj = Self) then
|
|
BitmapLoaded := False {the background image, set to load}
|
|
else if (Obj is TImageObj) then
|
|
begin
|
|
TImageObj(Obj).InsertImage(UName, Rformat);
|
|
Reformat := Reformat or Rformat;
|
|
end;
|
|
MissingImages.Delete(J);
|
|
J := MissingImages.IndexOf(UName);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{----------------TSectionList.GetTheBitmap}
|
|
function TSectionList.GetTheBitmap(const BMName: String; var Transparent: Transparency;
|
|
var AMask: TBitmap; var FromCache, Delay: boolean): TPersistent;
|
|
{Note: bitmaps and Mask returned by this routine are on "loan". Do not destroy
|
|
them}
|
|
{Transparent may be set to NotTransp or LLCorner on entry but may discover it's
|
|
TGif here}
|
|
|
|
{$ifdef ShareWare}
|
|
const
|
|
OneTime: boolean = False;
|
|
{$endif}
|
|
|
|
var
|
|
UName: string;
|
|
Ext: string[10];
|
|
I: integer;
|
|
Pair: TBitmapItem;
|
|
Tr: Transparency;
|
|
NonAnimated: boolean;
|
|
Stream: TMemoryStream;
|
|
Tmp: TGifImage;
|
|
|
|
begin
|
|
{$ifdef ShareWare}
|
|
{$Include DemoVers.inc}
|
|
{$endif}
|
|
AMask := Nil;
|
|
Delay := False;
|
|
FromCache := False;
|
|
if BMName <> '' then
|
|
begin
|
|
UName := Trim(Uppercase(BMName));
|
|
I := BitmapList.IndexOf(UName); {first see if the bitmap is already loaded}
|
|
if I > -1 then
|
|
begin {yes, handle the case where the image is already loaded}
|
|
Result := BitmapList.GetImage(I);
|
|
FromCache := True;
|
|
if Result is TBitmap then
|
|
with BitmapList.Objects[I] as TBitmapItem do
|
|
begin
|
|
if Transp = TGif then
|
|
Transparent := TGif {it's a transparent GIF}
|
|
else if Transp = Tpng then
|
|
Transparent := TPng
|
|
else if Transparent = LLCorner then
|
|
begin
|
|
if not Assigned (Mask) then {1st bitmap may not have been marked transp}
|
|
Mask := GetImageMask(TBitmap(MImage), False, 0);
|
|
if Assigned(Mask) then Transp := LLCorner;
|
|
end;
|
|
AMask := Mask;
|
|
end;
|
|
Exit;
|
|
end;
|
|
|
|
{The image is not loaded yet, need to get it}
|
|
Result := Nil;
|
|
if Assigned(GetImage) then
|
|
begin {the OnImageRequest}
|
|
Stream := Nil;
|
|
GetImage(TheOwner, BMName, Stream);
|
|
if Stream = WaitStream then
|
|
Delay := True
|
|
else if Assigned(Stream) and (Stream.Memory <> Nil) and (Stream.Size >= 1) then
|
|
begin
|
|
NonAnimated := True;
|
|
if KindOfImage(Stream.Memory) in [GIF, Gif89] then
|
|
Result := CreateAGifFromStream(NonAnimated, Stream);
|
|
if Assigned(Result) then
|
|
begin
|
|
if NonAnimated then
|
|
begin {else already have animated GIF}
|
|
Tmp := TGifImage(Result);
|
|
Result := TBitmap.Create;
|
|
Result.Assign(Tmp.MaskedBitmap);
|
|
if Tmp.IsTransparent then
|
|
begin
|
|
AMask := TBitmap.Create;
|
|
AMask.Assign(Tmp.Mask);
|
|
Transparent := TGif;
|
|
end
|
|
else if Transparent = LLCorner then
|
|
AMask := GetImageMask(TBitmap(Result), False, 0);
|
|
Tmp.Free;
|
|
end;
|
|
end
|
|
else
|
|
Result := GetImageAndMaskFromStream(Stream, Transparent, AMask);
|
|
end;
|
|
end
|
|
else
|
|
begin {look for the image file}
|
|
Ext := ExtractFileExt(BMName);
|
|
NonAnimated := True;
|
|
if (CompareText(Ext, '.gif')=0) then {remove .gfr check}
|
|
Result := CreateAGif(BMName, NonAnimated);
|
|
if Assigned(Result) then
|
|
begin
|
|
if NonAnimated then
|
|
begin {else already have animated GIF}
|
|
Tmp := TGifImage(Result);
|
|
Result := TBitmap.Create;
|
|
Result.Assign(Tmp.MaskedBitmap);
|
|
if Tmp.IsTransparent then
|
|
begin
|
|
AMask := TBitmap.Create;
|
|
AMask.Assign(Tmp.Mask);
|
|
Transparent := TGif;
|
|
end
|
|
else if Transparent = LLCorner then
|
|
AMask := GetImageMask(TBitmap(Result), False, 0);
|
|
Tmp.Free;
|
|
end;
|
|
end
|
|
else
|
|
Result := GetImageAndMaskFromFile(BMName, Transparent, AMask);
|
|
end;
|
|
if Assigned(Result) then {put in Image List for use later also}
|
|
try
|
|
if Assigned(AMask) then Tr := Transparent
|
|
else Tr := NotTransp;
|
|
Pair := TBitmapItem.Create(Result, AMask, Tr);
|
|
try
|
|
BitmapList.AddObject(UName, Pair); {put new bitmap in list}
|
|
except
|
|
Pair.Mask := Nil;
|
|
Pair.MImage:= Nil;
|
|
Pair.Free;
|
|
end;
|
|
except {accept inability to create}
|
|
end;
|
|
end
|
|
else Result := Nil;
|
|
end;
|
|
|
|
function TSectionList.FindPositionByIndex(Index: integer): integer;
|
|
{given a section index, find the vertical pixel distance to that section}
|
|
var
|
|
I: integer;
|
|
begin
|
|
Result := 0;
|
|
for I := 0 to IntMin(Index-1, Count-2) do
|
|
Result := TSectionBase(Items[I]).SectionHeight+ Result;
|
|
end;
|
|
|
|
function TSectionList.GetBackgroundBitmap: TBitmap;
|
|
var
|
|
Mask: TBitmap;
|
|
Dummy1: Transparency;
|
|
TmpResult: TPersistent;
|
|
FromCache, Delay: boolean;
|
|
Rslt: string;
|
|
begin
|
|
if ShowImages and not BitmapLoaded and (BitmapName <> '') then
|
|
begin
|
|
if not Assigned(BackgroundBitmap) then
|
|
begin
|
|
Dummy1 := NotTransp;
|
|
if not Assigned(GetImage) then
|
|
BitmapName := (TheOwner as ThtmlLite).HTMLExpandFilename(BitmapName)
|
|
else if Assigned(ExpandName) then
|
|
begin
|
|
ExpandName(TheOwner, BitmapName, Rslt);
|
|
BitmapName := Rslt;
|
|
end;
|
|
TmpResult := GetTheBitmap(BitmapName, Dummy1, Mask, FromCache, Delay); {might be Nil}
|
|
if TmpResult is TBitmap then
|
|
begin
|
|
BackgroundBitmap := TBitmap(TmpResult);
|
|
BackgroundMask := Mask;
|
|
end
|
|
else
|
|
begin
|
|
BackgroundBitmap := Nil;
|
|
if Delay then
|
|
MissingImages.AddObject(BitmapName, Self);
|
|
end;
|
|
BitmapLoaded := True;
|
|
end;
|
|
end;
|
|
Result := BackgroundBitmap;
|
|
end;
|
|
|
|
{----------------TCellObj.Create}
|
|
constructor TCellObj.Create(Master: TSectionList; AVAlign: AlignmentType;
|
|
Attr: TAttributeList);
|
|
var
|
|
I: integer;
|
|
begin
|
|
inherited Create;
|
|
Cell := TCell.Create(Master);
|
|
ColSpan := 1;
|
|
RowSpan := 1;
|
|
VAlign := AVAlign;
|
|
if Assigned(Attr) then
|
|
for I := 0 to Attr.Count-1 do
|
|
with TAttribute(Attr[I]) do
|
|
case Which of
|
|
ColSpanSy:
|
|
if Value > 1 then ColSpan := Value;
|
|
RowSpanSy:
|
|
if Value > 1 then RowSpan := Value;
|
|
WidthSy:
|
|
if Pos('%', Name) > 0 then
|
|
begin
|
|
if (Value > 0) and (Value <= 100) then
|
|
begin
|
|
WidthAttr := Value*10;
|
|
AsPercent := True;
|
|
end;
|
|
end
|
|
else if (Value > 0) then
|
|
WidthAttr := Value;
|
|
HeightSy: SpecHt := Value;
|
|
BGColorSy:
|
|
Cell.BkGnd := GetColor(Name, Cell.BkColor);
|
|
end;
|
|
end;
|
|
|
|
destructor TCellObj.Destroy;
|
|
begin
|
|
Cell.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TCellObj.UpdateFonts;
|
|
begin
|
|
Cell.UpdateFonts;
|
|
end;
|
|
|
|
{----------------TSectionBase.Create}
|
|
constructor TSectionBase.Create(AMasterList: TSectionList);
|
|
begin
|
|
inherited Create;
|
|
ParentSectionList := AMasterList;
|
|
end;
|
|
|
|
procedure TSectionBase.CopyToClipboard;
|
|
begin
|
|
end;
|
|
|
|
{----------------TSectionBase.DrawLogic}
|
|
function TSectionBase.DrawLogic(Canvas : TCanvas; Y: integer; IMgr: IndentManager;
|
|
var MaxWidth: integer; var Curs: integer): integer;
|
|
begin
|
|
StartCurs := Curs;
|
|
Result := SectionHeight;
|
|
DrawHeight := SectionHeight;
|
|
MaxWidth := IMgr.Width;
|
|
end;
|
|
|
|
function TSectionBase.Draw(Canvas: TCanvas; const ARect: TRect;
|
|
IMgr: IndentManager; X: integer; Y: integer) : integer;
|
|
begin
|
|
YValue := Y;
|
|
Result := Y+SectionHeight;
|
|
end;
|
|
|
|
function TSectionBase.GetURL(Canvas: TCanvas; X: integer; Y: integer;
|
|
var UrlTarg: TUrlTarget; var FormControl: TImageFormControlObj): boolean;
|
|
begin
|
|
Result := False;
|
|
end;
|
|
|
|
function TSectionBase.PtInObject(X : integer; Y: integer; var Obj: TObject;
|
|
var IX, IY: integer): boolean;
|
|
begin
|
|
Result := False;
|
|
end;
|
|
|
|
function TSectionBase.FindCursor(Canvas: TCanvas; X: integer; Y: integer;
|
|
var XR: integer; var YR: integer; var CaretHt: integer;
|
|
var SCell: TObject; var Intext: boolean): integer;
|
|
begin
|
|
Result := -1;
|
|
end;
|
|
|
|
function TSectionBase.FindString(From: integer; PC: PChar; MatchCase: boolean): integer;
|
|
begin
|
|
Result := -1;
|
|
end;
|
|
|
|
function TSectionBase.FindSourcePos(DocPos: integer): integer;
|
|
begin
|
|
Result := -1;
|
|
end;
|
|
|
|
function TSectionBase.FindDocPos(SourcePos: integer; Prev: boolean): integer;
|
|
begin
|
|
Result := -1;
|
|
end;
|
|
|
|
function TSectionBase.CursorToXY(Canvas: TCanvas; Cursor: integer; var X: integer;
|
|
var Y: integer): boolean;
|
|
begin
|
|
Result := False;
|
|
end;
|
|
|
|
function TSectionBase.GetChAtPos(Pos: integer; var Ch: char; var Obj: TObject): boolean;
|
|
begin
|
|
Result := False;
|
|
end;
|
|
|
|
procedure TSectionBase.UpdateFonts;
|
|
begin
|
|
UpdateSpacing;
|
|
end;
|
|
|
|
procedure TSectionBase.UpdateSpacing;
|
|
begin
|
|
end;
|
|
|
|
procedure TSectionBase.SetParent(List: TSectionList);
|
|
begin
|
|
ParentSectionList := List;
|
|
UpdateSpacing;
|
|
end;
|
|
|
|
procedure TSectionBase.MinMaxWidth(Canvas: TCanvas; var Min, Max: integer);
|
|
begin
|
|
Min := 0; Max := 0;
|
|
end;
|
|
|
|
{----------------TCellList.DoAttributes}
|
|
procedure TCellList.DoAttributes(Attr: TAttributeList);
|
|
var
|
|
I: integer;
|
|
begin
|
|
for I := 0 to Attr.Count-1 do
|
|
with TAttribute(Attr[I]) do
|
|
if Which = BGColorSy then
|
|
BkGnd := GetColor(Name, BkColor);
|
|
end;
|
|
|
|
{----------------TCellList.InitializeRow}
|
|
procedure TCellList.InitializeRow;
|
|
var
|
|
I: integer;
|
|
begin
|
|
if BkGnd then
|
|
for I := 0 to Count-1 do
|
|
with TCellObj(Items[I]).Cell do
|
|
if not BkGnd then
|
|
begin
|
|
BkGnd := True;
|
|
BkColor := Self.BkColor;
|
|
end;
|
|
end;
|
|
|
|
{----------------TCellList.UpdateFonts}
|
|
procedure TCellList.UpdateFonts;
|
|
var
|
|
I: integer;
|
|
begin
|
|
for I := 0 to Count-1 do
|
|
if Assigned(Items[I]) then
|
|
TCellObj(Items[I]).UpdateFonts;
|
|
end;
|
|
|
|
{----------------TCellList.DrawLogic1}
|
|
function TCellList.DrawLogic1(Canvas : TCanvas; const Widths : IntArray; Span,
|
|
CellPadding, CellSpacing: integer; var More: boolean): integer;
|
|
{Find vertical size of each cell, Row height of this row. But final Y position
|
|
is not known at this time.}
|
|
var
|
|
I, J, Dummy: integer;
|
|
DummyCurs, H, TmpSize: integer;
|
|
CellObj: TCellObj;
|
|
begin
|
|
H := 0;
|
|
DummyCurs := 0;
|
|
More := False;
|
|
for I := 0 to Count-1 do
|
|
begin
|
|
CellObj := TCellObj(Items[I]);
|
|
if Assigned(CellObj) then
|
|
with CellObj do
|
|
if ColSpan > 0 then {skip the dummy cells}
|
|
begin
|
|
Wd := 0;
|
|
for J := I to ColSpan+I-1 do
|
|
Inc(Wd, Widths[J]); {accumulate column widths}
|
|
if Span = RowSpan then
|
|
begin
|
|
VSize := Cell.DoLogic(Canvas, 0, Wd-2*CellPadding-CellSpacing,
|
|
Dummy, DummyCurs, 0, 0);
|
|
if VSize > SpecHt-2*CellPadding then TmpSize := VSize
|
|
else TmpSize := SpecHt-2*CellPadding;
|
|
if TmpSize > H then H := TmpSize;
|
|
end
|
|
else if RowSpan > Span then More := True;
|
|
end;
|
|
end;
|
|
Result := H;
|
|
end;
|
|
|
|
{----------------TCellList.DrawLogic2}
|
|
procedure TCellList.DrawLogic2(Canvas : TCanvas; Y: integer; CellPadding,
|
|
CellSpacing: integer; var Curs: integer);
|
|
{Calc Y indents. Set up Y positions of all cells.}
|
|
var
|
|
I, FullPad, Dummy: integer;
|
|
Tmp: integer;
|
|
CellObj: TCellObj;
|
|
begin
|
|
for I := 0 to Count-1 do
|
|
begin
|
|
CellObj := TCellObj(Items[I]);
|
|
if Assigned(CellObj) then
|
|
with CellObj do
|
|
if Cell.Count > 0 then
|
|
begin
|
|
FullPad := 2*CellPadding+CellSpacing;
|
|
Tmp := Ht - VSize - FullPad;
|
|
case VAlign of
|
|
ATop: YIndent := 0;
|
|
AMiddle: YIndent := Tmp div 2;
|
|
ABottom: YIndent := Tmp;
|
|
end;
|
|
Cell.DoLogic(Canvas, Y+CellPadding+CellSpacing+YIndent, Wd-FullPad,
|
|
Dummy, Curs, 0, 0);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{----------------TCellList.Draw}
|
|
function TCellList.Draw(Canvas: TCanvas; MasterList: TSectionList; const ARect: TRect;
|
|
const Widths : IntArray; X: integer; Y, YOffset: integer; CellPadding,
|
|
CellSpacing : integer; Border: boolean; Rgn: THandle; MyRow: integer) : integer;
|
|
var
|
|
I, Padding: integer;
|
|
YO: integer;
|
|
ARgn: THandle;
|
|
CellObj: TCellObj;
|
|
AddOn: integer;
|
|
begin
|
|
YO := Y - YOffset;
|
|
Result := RowHeight+Y;
|
|
|
|
if (YO+RowSpanHeight >= ARect.Top) and (YO < ARect.Bottom) then
|
|
for I := 0 to Count-1 do
|
|
begin
|
|
CellObj := TCellObj(Items[I]);
|
|
if Assigned(CellObj) then
|
|
with CellObj do
|
|
begin
|
|
if (Cell.Count > 0) then
|
|
begin
|
|
Padding := CellPadding+CellSpacing;
|
|
if Cell.BkGnd then
|
|
begin
|
|
Canvas.Brush.Color := Cell.BkColor or $2000000;
|
|
Canvas.FillRect(Rect(X+CellSpacing, IntMax(YO+CellSpacing, TopLim),
|
|
X+Wd, IntMin(YO+Ht, BotLim)));
|
|
end;
|
|
Cell.Draw(Canvas, ARect, Wd-Padding-CellPadding, X+Padding,
|
|
Y+Padding+YIndent);
|
|
if Border then
|
|
begin
|
|
RaisedRect(Cell.MasterList, Canvas, X+CellSpacing-1, YO+CellSpacing-1,
|
|
X+Wd, YO+Ht, False);
|
|
end;
|
|
|
|
if Rgn <> 0 then
|
|
begin
|
|
if Border then
|
|
AddOn := 1
|
|
else
|
|
AddOn := 0;
|
|
ARgn := CreateRectRgn(X+CellSpacing-AddOn, IntMax(YO+CellSpacing-AddOn, TopLim),
|
|
X+Wd+AddOn, IntMin(YO+Ht+AddOn, BotLim));
|
|
CombineRgn(Rgn, Rgn, ARgn, RGN_DIFF);
|
|
DeleteObject(ARgn);
|
|
end;
|
|
end;
|
|
end;
|
|
X := X + Widths[I];
|
|
end;
|
|
end;
|
|
|
|
{----------------ThtmlTable.Create}
|
|
constructor ThtmlTable.Create(Master: TSectionList;Attr: TAttributeList;
|
|
AJustify: JustifyType; ACell: TCell; ALevel: integer);
|
|
var
|
|
I: integer;
|
|
begin
|
|
inherited Create(Master);
|
|
MyCell := ACell;
|
|
Level := ALevel;
|
|
Rows := TFreeList.Create;
|
|
Caption := TCellObj.Create(Master, ATop, Nil);
|
|
TopCaption := True;
|
|
Justify := AJustify;
|
|
CellPadding := 1;
|
|
CellSpacing := 2;
|
|
HSpace := ImageSpace;
|
|
for I := 0 to Attr.Count-1 do
|
|
with TAttribute(Attr[I]) do
|
|
case Which of
|
|
BorderSy:
|
|
Border := Value > 0; {Border=0 is no border}
|
|
AlignSy:
|
|
if CompareText(Name, 'CENTER') = 0 then Justify := Centered
|
|
else if CompareText(Name, 'LEFT') = 0 then
|
|
begin
|
|
Justify := Left;
|
|
Float := True;
|
|
end
|
|
else if CompareText(Name, 'RIGHT') = 0 then
|
|
begin
|
|
Justify := Right;
|
|
Float := True;
|
|
end;
|
|
CellSpacingSy:
|
|
if Value >= 0 then CellSpacing := IntMin(Value, 40);
|
|
CellPaddingSy:
|
|
if Value >= 0 then CellPadding := IntMin(Value, 50);
|
|
WidthSy:
|
|
if Pos('%', Name) > 0 then
|
|
begin
|
|
if (Value > 0) and (Value <= 100) then WidthAttr := Value*10;
|
|
AsPercent := True;
|
|
end
|
|
else WidthAttr := Value;
|
|
HeightSy:
|
|
if (Pos('%', Name) > 0) and (ACell = Master) then
|
|
begin
|
|
if (Value > 0) and (Value <= 110) then HeightAttr := Value*10;
|
|
HtAsPercent := True;
|
|
end
|
|
else HeightAttr := Value;
|
|
BGColorSy:
|
|
BkGnd := GetColor(Name, BkColor);
|
|
BorderColorSy:
|
|
BdrOn := GetColor(Name, BdrColor);
|
|
HSpaceSy: HSpace := IntMin(40, Abs(Value));
|
|
VSpaceSy: VSpace := IntMin(200, Abs(Value));
|
|
end;
|
|
if Border then Inc(CellSpacing, 2); {includes border lines}
|
|
if Border then CellSpacing := IntMax(1, CellSpacing);
|
|
end;
|
|
|
|
{----------------ThtmlTable.Destroy}
|
|
destructor ThtmlTable.Destroy;
|
|
begin
|
|
Rows.Free;
|
|
Caption.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure ThtmlTable.UpdateFonts;
|
|
var
|
|
I: integer;
|
|
begin
|
|
for I := 0 to Rows.Count-1 do
|
|
TCellList(Rows.Items[I]).UpdateFonts;
|
|
Caption.UpdateFonts;
|
|
end;
|
|
|
|
{----------------ThtmlTable.AddDummyCells}
|
|
procedure ThtmlTable.AddDummyCells;
|
|
var
|
|
Cl, Rw, K, RowCount: integer;
|
|
AnyAbsolute: boolean;
|
|
|
|
function DummyCell(RSpan: integer): TCellObj;
|
|
begin
|
|
Result := TCellObj.Create(ParentSectionList, ATop, Nil);
|
|
Result.ColSpan := 0;
|
|
Result.RowSpan := RSpan;
|
|
end;
|
|
|
|
Begin
|
|
if not BkGnd and (MyCell.BkGnd) then
|
|
begin {Transfer any Background colors}
|
|
BkGnd := True;
|
|
BkColor := MyCell.BkColor;
|
|
end;
|
|
|
|
RowCount := Rows.Count;
|
|
if not ListsProcessed then
|
|
begin {put dummy cells in rows to make up for ColSpan > 1}
|
|
NumCols := 0;
|
|
AnyAbsolute := False;
|
|
for Rw := 0 to RowCount-1 do
|
|
begin
|
|
with TCellList(Rows[Rw]) do
|
|
begin
|
|
InitializeRow;
|
|
for Cl := Count-1 downto 0 do
|
|
with TCellObj(Items[Cl]) do
|
|
begin
|
|
if WidthAttr > 0 then
|
|
begin
|
|
if not AsPercent then AnyAbsolute := True;
|
|
end;
|
|
if Self.BkGnd and not Cell.BkGnd then {transfer bgcolor to cells}
|
|
begin
|
|
Cell.BkGnd := True;
|
|
Cell.BkColor := Self.BkColor;
|
|
end;
|
|
for K := 1 to ColSpan-1 do
|
|
if RowSpan > 1 then
|
|
TCellList(Rows[Rw]).Insert(Cl+K, DummyCell(RowSpan)) {these could be
|
|
Nil also except they're needed for expansion in the next section}
|
|
else
|
|
TCellList(Rows[Rw]).Insert(Cl+K, Nil);
|
|
end;
|
|
end;
|
|
NumCols := IntMax(NumCols, TCellList(Rows[Rw]).Count); {temporary # cols}
|
|
end;
|
|
|
|
{Absolute calc only if some absolute widths entered}
|
|
UseAbsolute := AnyAbsolute;
|
|
|
|
{put dummy cells in cols to make up for RowSpan > 1}
|
|
for Cl := 0 to NumCols-1 do
|
|
for Rw := 0 to RowCount-1 do
|
|
with TCellList(Rows[Rw]) do
|
|
if Count > Cl then
|
|
if Assigned(Items[Cl]) then
|
|
with TCellObj(Items[Cl]) do
|
|
begin
|
|
RowSpan := IntMin(RowSpan, RowCount-Rw); {practical limit}
|
|
if RowSpan > 1 then
|
|
for K := Rw+1 to Rw+RowSpan-1 do
|
|
begin {insert dummy cells in following rows if RowSpan > 1}
|
|
while TCellList(Rows[K]).Count < Cl do {add padding if row is short}
|
|
TCellList(Rows[K]).Add(DummyCell(0));
|
|
TCellList(Rows[K]).Insert(Cl, DummyCell(0));
|
|
end;
|
|
end;
|
|
|
|
NumCols := 0; {find the number of columns}
|
|
for Rw := 0 to RowCount-1 do
|
|
begin
|
|
NumCols := IntMax(NumCols, TCellList(Rows[Rw]).Count);
|
|
end;
|
|
if NumCols > MaxCols then
|
|
Raise EProcessError.Create('Table has too many Columns');
|
|
|
|
ListsProcessed := True;
|
|
end; {if not ListsProcessed}
|
|
end;
|
|
|
|
{----------------ThtmlTable.GetMinMaxAbs}
|
|
procedure ThtmlTable.GetMinMaxAbs(Canvas: TCanvas; var TotalMinWidth,
|
|
TotalMaxWidth: integer; var MinWidths, MaxWidths: IntArray);
|
|
var
|
|
I, J, Min, Max, N, Span, Addon, D: integer;
|
|
More: boolean;
|
|
|
|
Begin
|
|
FillChar(MinWidths, Sizeof(MinWidths), 0);
|
|
FillChar(MaxWidths, Sizeof(MaxWidths), 0);
|
|
Addon := 2*CellPadding + CellSpacing;
|
|
Span := 1;
|
|
More := True;
|
|
while More do
|
|
begin
|
|
More := False;
|
|
for J := 0 to Rows.Count-1 do
|
|
with TCellList(Rows[J]) do
|
|
begin
|
|
for I := 0 to Count-1 do
|
|
if Assigned(Items[I]) then
|
|
with TCellObj(Items[I]) do
|
|
begin
|
|
More := More or (ColSpan > Span); {set if need another iteration}
|
|
if ColSpan = Span then
|
|
begin
|
|
Cell.MinMaxWidth(Canvas, Min, Max);
|
|
Inc(Min, Addon);
|
|
Inc(Max, Addon);
|
|
if Span = 1 then
|
|
begin
|
|
if not AsPercent and (WidthAttr > 0) then
|
|
begin
|
|
Min := IntMax(Min, WidthAttr+Addon);
|
|
Max := IntMax(Min, WidthAttr+Addon);
|
|
end;
|
|
MinWidths[I] := Intmax(MinWidths[I], Min);
|
|
MaxWidths[I] := Intmax(MaxWidths[I], Max);
|
|
end
|
|
else
|
|
begin
|
|
TotalMinWidth := 0; TotalMaxWidth := 0;
|
|
for N := I to I+ColSpan-1 do
|
|
begin {find the current totals for the span}
|
|
Inc(TotalMaxWidth, MaxWidths[N]);
|
|
Inc(TotalMinWidth, MinWidths[N]);
|
|
end;
|
|
if not AsPercent and (WidthAttr > 0) then
|
|
begin
|
|
Min := IntMax(Min, WidthAttr+Addon);
|
|
Max := IntMax(Min, WidthAttr+Addon);
|
|
end;
|
|
if (TotalMinWidth < Min) then
|
|
if TotalMinWidth > 0 then
|
|
begin
|
|
D := Min - TotalMinWidth;
|
|
for N := I to I+ColSpan-1 do {increase the sub widths to match the span}
|
|
MinWidths[N] := MinWidths[N]+MulDiv(MinWidths[N], D, TotalMinWidth);
|
|
end
|
|
else MinWidths[I] := Min; {this for multiple empty cols}
|
|
if (TotalMaxWidth < Max) then
|
|
if TotalMaxWidth > 0 then
|
|
begin {increase the sub widths to match the span}
|
|
D := Max - TotalMaxWidth;
|
|
for N := I to I+ColSpan-1 do {increase the sub widths to match the span}
|
|
MaxWidths[N] := MaxWidths[N]+MulDiv(MaxWidths[N], D, TotalMaxWidth);
|
|
end
|
|
else MaxWidths[I] := Max;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
Inc(Span);
|
|
end;
|
|
|
|
{Find the total min and max width}
|
|
TotalMaxWidth := 0; TotalMinWidth := 0;
|
|
for I := 0 to NumCols-1 do
|
|
begin
|
|
Inc(TotalMaxWidth, MaxWidths[I]);
|
|
Inc(TotalMinWidth, MinWidths[I]);
|
|
end;
|
|
|
|
end;
|
|
|
|
{----------------ThtmlTable.GetWidthsAbs}
|
|
procedure ThtmlTable.GetWidthsAbs(Canvas: TCanvas; TablWidth: integer;
|
|
Specified: boolean; var MinWidths, MaxWidths: IntArray);
|
|
var
|
|
N, D, W, dd, TotalMinWidth, TotalMaxWidth: integer;
|
|
|
|
Begin
|
|
GetMinMaxAbs(Canvas, TotalMinWidth, TotalMaxWidth, MinWidths, MaxWidths);
|
|
|
|
if TotalMinWidth >=TablWidth then {use the minimum column widths, table will expand}
|
|
Move(MinWidths, Widths, Sizeof(MinWidths))
|
|
else if (TotalMaxWidth <= TablWidth) and not Specified then
|
|
{use the max column widths, table will be smaller}
|
|
Move(MaxWidths, Widths, Sizeof(MaxWidths))
|
|
else {make table fit}
|
|
begin
|
|
D := TotalMaxWidth - TotalMinWidth;
|
|
W := TablWidth - TotalMinWidth;
|
|
if D > 0 then {expand only those columns with some slop in them}
|
|
begin
|
|
for N := 0 to NumCols-1 do
|
|
begin
|
|
dd := MaxWidths[N] - MinWidths[N]; {some dd's may be 0}
|
|
Widths[N] := MinWidths[N] + MulDiv(dd, W, D);
|
|
end;
|
|
end
|
|
else {no adjustable columns, will have to expand them all}
|
|
for N := 0 to NumCols-1 do
|
|
Widths[N] := MinWidths[N] + MulDiv(MinWidths[N], W, TotalMinWidth);
|
|
end;
|
|
end;
|
|
|
|
{----------------ThtmlTable.GetWidths}
|
|
procedure ThtmlTable.GetWidths(Canvas: TCanvas; var TotalMinWidth, TotalMaxWidth: integer;
|
|
var MinWidths, MaxWidths: IntArray; TheWidth: integer);
|
|
var
|
|
I, J, Min, Max, N, Span, Addon, Distributable, TotalPC,
|
|
ExcessMin, ExcessMax, NonPC, PCWidth, NewTotalPC, MaxSum: integer;
|
|
More: boolean;
|
|
|
|
Begin
|
|
{Find the max and min widths of each column}
|
|
FillChar(MaxWidths, Sizeof(MaxWidths), 0);
|
|
FillChar(MinWidths, Sizeof(MinWidths), 0);
|
|
FillChar(Percents, Sizeof(Percents), 0);
|
|
Addon := 2*CellPadding + CellSpacing;
|
|
Span := 1;
|
|
More := True;
|
|
while More do
|
|
begin
|
|
More := False;
|
|
for J := 0 to Rows.Count-1 do
|
|
with TCellList(Rows[J]) do
|
|
begin
|
|
for I := 0 to Count-1 do
|
|
if Assigned(Items[I]) then
|
|
with TCellObj(Items[I]) do
|
|
begin
|
|
PCWidth := 0;
|
|
if WidthAttr > 0 then
|
|
if AsPercent then PCWidth := WidthAttr
|
|
else if TheWidth > 0 then
|
|
PCWidth := IntMin(1000, MulDiv(WidthAttr, 1000, TheWidth));
|
|
More := More or (ColSpan > Span); {set if need another iteration}
|
|
if ColSpan = Span then
|
|
begin
|
|
Cell.MinMaxWidth(Canvas, Min, Max);
|
|
Inc(Min, Addon);
|
|
Inc(Max, Addon);
|
|
if Span = 1 then
|
|
begin
|
|
MaxWidths[I] := IntMax(MaxWidths[I], Max);
|
|
MinWidths[I] := IntMax(MinWidths[I], Min);
|
|
Percents[I] := Intmax(Percents[I], PCWidth); {collect percents}
|
|
end
|
|
else
|
|
begin
|
|
TotalMaxWidth := 0; TotalMinWidth := 0;
|
|
TotalPC := 0; NonPC := 0;
|
|
for N := I to I+ColSpan-1 do
|
|
begin {Total up the pertinant column widths}
|
|
Inc(TotalMaxWidth, MaxWidths[N]);
|
|
Inc(TotalMinWidth, MinWidths[N]);
|
|
if Percents[N] > 0 then
|
|
Inc(TotalPC, Percents[N]) {total percents}
|
|
else Inc(NonPC); {count of cell with no percent}
|
|
end;
|
|
ExcessMin := Min - TotalMinWidth;
|
|
ExcessMax := Max - TotalMaxWidth;
|
|
if (PCWidth > 0) or (TotalPC > 0) then
|
|
begin {manipulate for percentages}
|
|
if NonPC > 0 then
|
|
{find the extra percentages to divvy up}
|
|
Distributable := IntMax(0, (PCWidth-TotalPC) div NonPC)
|
|
else Distributable := 0;
|
|
if (NonPC = 0) and (PCWidth > TotalPC) then
|
|
begin
|
|
for N := I to I+ColSpan-1 do {stretch percentages to fit}
|
|
Percents[N] := MulDiv(Percents[N], PCWidth, TotalPC);
|
|
end
|
|
else if Distributable > 0 then {spread colspan percentage excess over the unspecified cols}
|
|
for N := I to I+ColSpan-1 do
|
|
if Percents[N] = 0 then Percents[N] := Distributable;
|
|
NewTotalPC := IntMax(TotalPC, PCWidth);
|
|
if ExcessMin > 0 then
|
|
begin
|
|
if NonPC > 0 then {split excess over non-specified cells}
|
|
begin
|
|
{proportion the distribution so cells with large MaxWidth get more}
|
|
MaxSum := 0;
|
|
for N := I to I+ColSpan-1 do
|
|
if Percents[N] = 0 then
|
|
Inc(MaxSum, MaxWidths[N]);
|
|
for N := I to I+ColSpan-1 do
|
|
if Percents[N] = 0 then
|
|
Inc(MinWidths[N], MulDiv(ExcessMin, MaxWidths[N], MaxSum));
|
|
end
|
|
else
|
|
for N := I to I+ColSpan-1 do
|
|
MinWidths[N] := IntMax(MulDiv(Min, Percents[N], NewTotalPC), MinWidths[N]);
|
|
end;
|
|
if ExcessMax > 0 then
|
|
begin
|
|
if NonPC > 0 then {split excess over non-specified cells}
|
|
begin
|
|
Distributable := ExcessMax div NonPC;
|
|
for N := I to I+ColSpan-1 do
|
|
if Percents[N] = 0 then
|
|
Inc(MaxWidths[N], Distributable);
|
|
end
|
|
else
|
|
for N := I to I+ColSpan-1 do
|
|
MaxWidths[N] := IntMax(MulDiv(Max, Percents[N], NewTotalPC), MaxWidths[N]);
|
|
end;
|
|
end
|
|
else
|
|
begin {no width dimensions entered}
|
|
if ExcessMin > 0 then
|
|
for N := I to I+ColSpan-1 do
|
|
if TotalMinWidth = 0 then
|
|
MinWidths[N] := Min div ColSpan
|
|
else {split up the widths in proportion to widths already there}
|
|
MinWidths[N] := MulDiv(Min, MinWidths[N], TotalMinWidth);
|
|
if ExcessMax > 0 then
|
|
for N := I to I+ColSpan-1 do
|
|
if TotalMaxWidth = 0 then
|
|
MaxWidths[N] := Max div ColSpan
|
|
else {split up the widths in proportion to widths already there}
|
|
MaxWidths[N] := MulDiv(Max, MaxWidths[N], TotalMaxWidth);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
Inc(Span);
|
|
end;
|
|
|
|
TotalMaxWidth := 0; TotalMinWidth := 0;
|
|
for I := 0 to NumCols-1 do
|
|
begin
|
|
Inc(TotalMaxWidth, MaxWidths[I]);
|
|
Inc(TotalMinWidth, MinWidths[I]);
|
|
end;
|
|
end;
|
|
|
|
{----------------ThtmlTable.MinMaxWidth}
|
|
procedure ThtmlTable.MinMaxWidth(Canvas: TCanvas; var Min, Max: integer);
|
|
var
|
|
MaxWidths, MinWidths: IntArray;
|
|
Mn, Dummy: integer;
|
|
begin
|
|
AddDummyCells; {in case it hasn't been done}
|
|
if UseAbsolute and (WidthAttr = 0) then
|
|
GetMinMaxAbs(Canvas, Mn, Max, MinWidths, MaxWidths)
|
|
else if not AsPercent then
|
|
GetWidths(Canvas, Mn, Max, MinWidths, MaxWidths, WidthAttr)
|
|
else
|
|
GetWidths(Canvas, Mn, Max, MinWidths, MaxWidths, 0);
|
|
|
|
Inc(Mn, CellSpacing);
|
|
Inc(Max, CellSpacing);
|
|
if not AsPercent then
|
|
begin
|
|
Mn := IntMax(Mn, WidthAttr);
|
|
Max := IntMax(Max, WidthAttr);
|
|
end;
|
|
Caption.Cell.MinMaxWidth(Canvas, CaptionMinWidth, Dummy);
|
|
Min := IntMax(CaptionMinWidth, Mn); {caption may be wider than table}
|
|
Max := IntMax(CaptionMinWidth, Max);
|
|
end;
|
|
|
|
procedure ThtmlTable.xxx(const MaxWidths, MinWidths: IntArray; TheWidth: integer);
|
|
{Divide up the table into columns. TheWidth is the specified width of the table.
|
|
At this point, it is known that everything will fit into TheWidth. Percents are
|
|
being used}
|
|
var
|
|
I, W, PCNotMinWid, TotalWid, Unsp, UnspDiff, Delta, Addon, Count: integer;
|
|
UseMin: array[0..MaxCols] of boolean;
|
|
NoChange: boolean;
|
|
begin
|
|
FillChar(UseMin, Sizeof(UseMin), False);
|
|
PCNotMinWid := 0; TotalWid := 0; Unsp := 0; UnspDiff := 0;
|
|
{First calculate everything assuming the data entered is perfectly correct}
|
|
for I := 0 to NumCols - 1 do
|
|
begin
|
|
if Percents[I] > 0 then
|
|
begin
|
|
W := MulDiv(TheWidth, Percents[I], 1000); {width based on percentage}
|
|
if W > MinWidths[I] then
|
|
begin
|
|
Widths[I] := W;
|
|
Inc(PCNotMinWid, Percents[I]);
|
|
end
|
|
else
|
|
begin {percent is too small, use Min width}
|
|
Widths[I] := MinWidths[I];
|
|
UseMin[I] := True;
|
|
end;
|
|
end
|
|
else
|
|
begin {no percent}
|
|
Widths[I] := MinWidths[I];
|
|
Inc(Unsp); {an unspecified column}
|
|
Inc(UnspDiff, MaxWidths[I]-MinWidths[I]); {total max-min for unspecified cols}
|
|
end;
|
|
Inc(TotalWid, Widths[I]);
|
|
end;
|
|
|
|
Delta := TotalWid - TheWidth; {see what the error is}
|
|
if Delta < 0 then {table is too small}
|
|
begin
|
|
if Unsp > 0 then
|
|
begin
|
|
if (UnspDiff > 0) and (UnspDiff >= Abs(Delta) div 2) then
|
|
{increase the unspecified columns widths prop to Max, Min unless the difference is trivial}
|
|
begin
|
|
for I := 0 to NumCols-1 do
|
|
if (Percents[I] = 0) then
|
|
Inc(Widths[I], MulDiv(-Delta, MaxWidths[I] - MinWidths[I], UnspDiff));
|
|
end
|
|
else
|
|
begin {increase the unspecified columns widths uniformly}
|
|
Addon := -Delta div Unsp;
|
|
for I := 0 to NumCols - 1 do
|
|
if (Percents[I] = 0) then
|
|
Inc(Widths[I], Addon);
|
|
end;
|
|
end
|
|
else
|
|
begin {no unspecified widths, increase the specified columns which are not minimum}
|
|
for I := 0 to NumCols - 1 do
|
|
if (Percents[I] > 0) and not UseMin[I] then
|
|
Inc(Widths[I], MulDiv(-Delta, Percents[I], PCNotMinWid));
|
|
end;
|
|
end
|
|
else if Delta > 0 then {calculated table is too large}
|
|
begin
|
|
Count := 0;
|
|
{make one or more trial run to see what happens when shrinking the columns
|
|
that can be shrunck. May hit another MinWidth situation}
|
|
repeat
|
|
NoChange := True;
|
|
for I := 0 to NumCols - 1 do
|
|
if (Percents[I] > 0) and not UseMin[I] then
|
|
begin
|
|
W := Widths[I] - MulDiv(Delta, Percents[I], PCNotMinWid);
|
|
if W < MinWidths[I] then
|
|
begin {new width is smaller than MinWidth, make adustments}
|
|
UseMin[I] := True;
|
|
NoChange := False;
|
|
Dec(PCNotMinWid, Percents[I]);
|
|
Dec(Delta, Widths[I]-MinWidths[I]);
|
|
Widths[I] := MinWidths[I];
|
|
end;
|
|
end;
|
|
Inc(Count);
|
|
until NoChange or (Count >= 4); {count guards against endless loop}
|
|
for I := 0 to NumCols - 1 do {now actually change the widths}
|
|
if (Percents[I] > 0) and not UseMin[I] then
|
|
Dec(Widths[I], MulDiv(Delta, Percents[I], PCNotMinWid));
|
|
end;
|
|
|
|
TotalWid := 0; {fix up any round off errors}
|
|
for I := 0 to NumCols - 1 do
|
|
Inc(TotalWid, Widths[I]);
|
|
Delta := TotalWid-TheWidth; {round off error}
|
|
if Delta > 0 then
|
|
begin
|
|
for I := 0 to NumCols-1 do
|
|
if not UseMin[I] then
|
|
begin
|
|
Dec(Widths[I], Delta); {remove extra from first non minimum}
|
|
Break;
|
|
end;
|
|
end
|
|
else Inc(Widths[0], -Delta); {tack it on anywhere}
|
|
end;
|
|
|
|
{----------------ThtmlTable.DrawLogic}
|
|
function ThtmlTable.DrawLogic(Canvas : TCanvas; Y: integer; IMgr: IndentManager;
|
|
var MaxWidth: integer; var Curs: integer): integer;
|
|
Label
|
|
GotWidths;
|
|
type
|
|
HeightArray = array[0..16000] of integer;
|
|
var
|
|
I, J, K, N, Span,
|
|
TotalMaxWidth, TotalMinWidth, D, W, DS,
|
|
Total, TotalPC, Residual, NewResidual, W1, W2, NewTotal: integer;
|
|
More, Mr, HasPercents, UsesPercents, Done: boolean;
|
|
MaxWidths, MinWidths: IntArray;
|
|
NewWidth, Dummy: integer;
|
|
Heights: ^HeightArray;
|
|
OwnerWidth: integer;
|
|
H, TotalHt, Addon: integer;
|
|
Specified: boolean;
|
|
AddedOn: integer;
|
|
DisplayHt, NewHeight, Sum: integer;
|
|
|
|
Begin
|
|
YValue := Y;
|
|
StartCurs := Curs;
|
|
IMgr.SetLevel(Y, Level);
|
|
|
|
OwnerWidth := IMgr.RightSide(Y) - IMgr.LeftIndent(Y);
|
|
if WidthAttr > 0 then
|
|
begin
|
|
Specified := True;
|
|
if AsPercent then
|
|
NewWidth := MulDiv(OwnerWidth, WidthAttr, 1000)
|
|
else NewWidth := WidthAttr;
|
|
end
|
|
else
|
|
begin
|
|
Specified := False;
|
|
NewWidth := OwnerWidth;
|
|
end;
|
|
Dec(NewWidth, CellSpacing);
|
|
NewWidth := IntMax(NewWidth, 20);
|
|
|
|
AddDummyCells;
|
|
|
|
{Figure the width of each column}
|
|
if UseAbsolute and not Specified then
|
|
begin
|
|
GetWidthsAbs(Canvas, NewWidth, Specified, MinWidths, MaxWidths); {fills in Widths array}
|
|
GoTo GotWidths;
|
|
end
|
|
else
|
|
GetWidths(Canvas, TotalMinWidth, TotalMaxWidth, MinWidths, MaxWidths, NewWidth);
|
|
|
|
if (TotalMinWidth >= NewWidth) then
|
|
begin {table won't fit, use minimun widths}
|
|
Move(MinWidths, Widths, Sizeof(IntArray));
|
|
GoTo GotWidths;
|
|
end;
|
|
|
|
if Specified then
|
|
begin
|
|
xxx(MaxWidths, MinWidths, NewWidth);
|
|
GoTo GotWidths;
|
|
end;
|
|
|
|
TotalPC := 0; {see if any percentage widths entered}
|
|
for I := 0 to NumCols-1 do
|
|
Inc(TotalPC, Percents[I]);
|
|
UsesPercents := (TotalPc > 0) and (TotalPc <= 1000) {ignore ridiculous values}
|
|
or (WidthAttr > 0);
|
|
|
|
if UsesPercents then
|
|
begin {find the largest width that will accomodate the %'s}
|
|
Residual := 0; W1 := 0; W2 := 0;
|
|
for I := 0 to NumCols-1 do
|
|
if Percents[I] > 0 then {a percent has been entered}
|
|
W1 := IntMax(W1, MulDiv(MaxWidths[I], 1000, Percents[I])) {look for maximum}
|
|
else
|
|
Inc(Residual, MaxWidths[I]); {accumlate the cols which have no percent}
|
|
if TotalPC < 1000 then
|
|
W2 := MulDiv(Residual, 1000, 1000-TotalPC)
|
|
else if Residual > 0 then W2 := 30000
|
|
else W2 := 0;
|
|
Total := IntMax(W1, W2);
|
|
if Total <= NewWidth then
|
|
begin {a fit is found using percents and maxwidths}
|
|
if WidthAttr > 0 then
|
|
Total := NewWidth; {don't try to make it smaller than NewWidth}
|
|
NewResidual := MulDiv(Total, 1000-TotalPC, 1000);
|
|
for I := 0 to NumCols-1 do
|
|
if Percents[I] > 0 then {figure widths to fit this situation}
|
|
Widths[I] := MulDiv(Total, Percents[I], 1000)
|
|
else if Residual > 0 then
|
|
Widths[I] := MulDiv(MaxWidths[I], NewResidual, Residual)
|
|
else Widths[I] := 0; {this is an table syntax error condition}
|
|
GoTo GotWidths;
|
|
end;
|
|
|
|
Done := False;
|
|
repeat {with the above possibilites taken care of, we can assume the final
|
|
width will = NewWidth}
|
|
HasPercents := False;
|
|
Total := 0; Residual := 0;
|
|
for I := 0 to NumCols-1 do
|
|
begin
|
|
if Percents[I] > 0 then
|
|
begin
|
|
W := MulDiv(NewWidth, Percents[I], 1000)-1; {a Percent's width based on NewWidth}
|
|
if W < MinWidths[I] then {but it must be > MinWidth}
|
|
begin {eliminate the percentage value as not achievable}
|
|
Percents[I] := 0;
|
|
Inc(Residual, MinWidths[I]); {and put it in the residuals}
|
|
end
|
|
else
|
|
begin
|
|
HasPercents := True; {still valid percents}
|
|
Inc(Total, W);
|
|
end;
|
|
end
|
|
else Inc(Residual, MinWidths[I]);
|
|
end;
|
|
if not HasPercents then Break; {no percents are achievable}
|
|
if Total+Residual <= NewWidth then
|
|
begin {a solution with at least some percentages can be found}
|
|
Done := True;
|
|
TotalMaxWidth := 0; TotalMinWidth := 0; {recalc these}
|
|
for I := 0 to NumCols-1 do
|
|
begin
|
|
if Percents[I] > 0 then
|
|
begin
|
|
MinWidths[I] := MulDiv(NewWidth, Percents[I], 1000);
|
|
MaxWidths[I] := MinWidths[I]; {this fixes the width thru later calculations}
|
|
end;
|
|
Inc(TotalMaxWidth, MaxWidths[I]);
|
|
Inc(TotalMinWidth, MinWidths[I]);
|
|
end;
|
|
end
|
|
else {it doesn't fit screen, reduce percentages and try again}
|
|
begin
|
|
NewTotal := NewWidth-Residual; {percent items must fit this}
|
|
for I := 0 to NumCols-1 do
|
|
if Percents[I] > 0 then
|
|
Percents[I] := integer(Percents[I]) * NewTotal div Total;
|
|
end;
|
|
until Done;
|
|
end;
|
|
|
|
D := TotalMaxWidth - TotalMinWidth;
|
|
if (TotalMaxWidth <= NewWidth) or (D = 0) then
|
|
Move(MaxWidths, Widths, Sizeof(IntArray))
|
|
else
|
|
begin
|
|
W := NewWidth - TotalMinWidth;
|
|
for I := 0 to NumCols-1 do
|
|
begin
|
|
ds := MaxWidths[I] - MinWidths[I];
|
|
Widths[I] := MinWidths[I] + MulDiv(ds, W, D);
|
|
end;
|
|
end;
|
|
|
|
GotWidths:
|
|
|
|
{Find Table Width}
|
|
TableWidth := CellSpacing;
|
|
for I := 0 to NumCols-1 do
|
|
Inc(TableWidth, Widths[I]);
|
|
Caption.Cell.MinMaxWidth(Canvas, CaptionMinWidth, Dummy);
|
|
CaptionWidth := IntMax(TableWidth, CaptionMinWidth); {make sure caption fits}
|
|
|
|
GetMem(Heights, Rows.Count * Sizeof(integer));
|
|
try
|
|
{Find the height of each row allowing for RowSpans}
|
|
FillChar(Heights^, Rows.Count*Sizeof(integer), 0);
|
|
Span := 1;
|
|
More := True;
|
|
while More do
|
|
begin
|
|
More := False;
|
|
for J := 0 to Rows.Count-1 do
|
|
with TCellList(Rows[J]) do
|
|
begin
|
|
if J+Span > Rows.Count then Break; {otherwise will overlap}
|
|
H := DrawLogic1(Canvas, Widths, Span, CellPadding, CellSpacing, Mr) +
|
|
+ 2*CellPadding+CellSpacing;
|
|
More := More or Mr;
|
|
if Span = 1 then
|
|
Heights^[J] := H
|
|
else
|
|
begin
|
|
TotalHt := 0; {sum up the height so far for the rows involved}
|
|
for K := J to J+Span-1 do
|
|
Inc(TotalHt, Heights^[K]);
|
|
if H > TotalHt then {apportion the excess over the rows}
|
|
begin
|
|
Addon := ((H-TotalHt) div Span);
|
|
AddedOn := 0;
|
|
for K := J to J+Span-1 do
|
|
begin
|
|
Inc(Heights^[K], Addon);
|
|
Inc(AddedOn, Addon);
|
|
end;
|
|
Inc(Heights^[J+Span-1], (H-TotalHt)-AddedOn); {make up for round off error}
|
|
end;
|
|
end;
|
|
end;
|
|
Inc(Span);
|
|
end;
|
|
|
|
if TopCaption then
|
|
begin {layout the caption}
|
|
SectionHeight := Caption.Cell.DoLogic(Canvas, Y, CaptionWidth, Dummy, Curs, 0, 0);
|
|
CaptionHeight := SectionHeight;
|
|
Inc(Y, SectionHeight);
|
|
end
|
|
else SectionHeight := 0;
|
|
|
|
if HeightAttr > 0 then
|
|
begin
|
|
if HtAsPercent then
|
|
with ThtmlLite(ParentSectionList.TheOwner) do
|
|
begin
|
|
DisplayHt := ClientHeight - 2*FMarginHeightX - CellSpacing - 3;
|
|
NewHeight := MulDiv(DisplayHt, HeightAttr, 1000);
|
|
end
|
|
else NewHeight := HeightAttr;
|
|
TotalHt := 0;
|
|
for J := 0 to Rows.Count-1 do
|
|
Inc(TotalHt, Heights^[J]);
|
|
if TotalHt < NewHeight then
|
|
begin
|
|
Addon := (NewHeight-TotalHt) div Rows.Count;
|
|
Sum := 0;
|
|
for J := 0 to Rows.Count-2 do
|
|
begin
|
|
Inc(Heights^[J], Addon);
|
|
Inc(Sum, Heights^[J]);
|
|
end;
|
|
Heights^[Rows.Count-1] := NewHeight-Sum;
|
|
end;
|
|
end;
|
|
|
|
TableHeight := SectionHeight;
|
|
for J := 0 to Rows.Count-1 do
|
|
with TCellList(Rows[J]) do
|
|
begin
|
|
RowHeight := Heights^[J];
|
|
RowSpanHeight := 0;
|
|
Inc(SectionHeight, Heights^[J]);
|
|
for I := 0 to Count-1 do
|
|
if Assigned(Items[I]) then
|
|
with TCellObj(Items[I]) do
|
|
begin {find the actual height, Ht, of each cell}
|
|
Ht := 0;
|
|
for K := J to J+RowSpan-1 do
|
|
Inc(Ht, Heights^[K]);
|
|
if RowSpanHeight < Ht then RowSpanHeight := Ht;
|
|
end;
|
|
DrawLogic2(Canvas, Y, CellPadding, CellSpacing, Curs);
|
|
Inc(Y, RowHeight);
|
|
end;
|
|
Inc(SectionHeight, CellSpacing);
|
|
TableHeight := SectionHeight-TableHeight;
|
|
Finally
|
|
FreeMem(Heights, Rows.Count * Sizeof(integer));
|
|
end;
|
|
|
|
if not TopCaption then
|
|
begin
|
|
CaptionHeight := Caption.Cell.DoLogic(Canvas, YValue+TableHeight,
|
|
CaptionWidth, Dummy, Curs, 0, 0);
|
|
Inc(SectionHeight, CaptionHeight);
|
|
end;
|
|
|
|
{figure the indents, CaptionWidth is = or larger than TableWidth}
|
|
CaptionIndent := 0;
|
|
if CaptionWidth < OwnerWidth then
|
|
case Justify of
|
|
Centered: CaptionIndent := (OwnerWidth-CaptionWidth) div 2;
|
|
Right: CaptionIndent := OwnerWidth-CaptionWidth;
|
|
end;
|
|
Inc(CaptionIndent, IMgr.LeftIndent(YValue));
|
|
Indent := CaptionIndent + (CaptionWidth-TableWidth) div 2; {table indent}
|
|
|
|
Len := Curs-StartCurs;
|
|
writeln('ThtmlTable.DrawLogic ',HexStr(Cardinal(Self),8),' ',Curs,' ',StartCurs,' Len=',Len);
|
|
MaxWidth := CaptionWidth;
|
|
if Float then
|
|
begin
|
|
Inc(SectionHeight, 2*VSpace);
|
|
IMgr.UpdateTable(YValue, MaxWidth+HSpace+1, SectionHeight, Justify);
|
|
DrawHeight := SectionHeight;
|
|
SectionHeight := 0;
|
|
Result := 0;
|
|
end
|
|
else
|
|
begin
|
|
Result := SectionHeight;
|
|
DrawHeight := Result;
|
|
end;
|
|
end;
|
|
|
|
{----------------ThtmlTable.Draw}
|
|
function ThtmlTable.Draw(Canvas: TCanvas; const ARect: TRect;
|
|
IMgr: IndentManager; X: integer; Y: integer) : integer;
|
|
var
|
|
I, XX: integer;
|
|
YY, YTable, YO, YOffset: integer;
|
|
Rgn: THandle;
|
|
begin
|
|
Result := Y+SectionHeight;
|
|
if Float then
|
|
Y := Y + VSpace;
|
|
YOffset := ParentSectionList.YOff;
|
|
YO := Y - YOffset;
|
|
|
|
if (YO+DrawHeight >= ARect.Top) and (YO < ARect.Bottom) then
|
|
begin
|
|
XX := X+Indent; {for the table}
|
|
YY := Y;
|
|
DrawX := XX;
|
|
DrawY := YY;
|
|
if TopCaption then
|
|
YY := Caption.Cell.Draw(Canvas, ARect, CaptionWidth, XX+CaptionIndent-Indent, YY);
|
|
YTable := YY;
|
|
if BdrOn then
|
|
begin
|
|
Rgn:= CreateRectRgn(XX, IntMax(Arect.Top-1, YTable-YOffset),
|
|
XX+TableWidth, IntMin(ARect.Bottom, YTable+TableHeight-YOffset));
|
|
end
|
|
else Rgn := 0;
|
|
for I := 0 to Rows.Count-1 do
|
|
YY := TCellList(Rows.Items[I]).Draw(Canvas, ParentSectionList, ARect, Widths,
|
|
XX, YY, YOffset, CellPadding, CellSpacing, Border, Rgn, I);
|
|
if Rgn <> 0 then
|
|
begin
|
|
Canvas.Brush.Color := BdrColor or $2000000;
|
|
FillRgn(Canvas.Handle, Rgn, Canvas.Brush.Handle);
|
|
DeleteObject(Rgn);
|
|
end;
|
|
if Border then
|
|
RaisedRect(ParentSectionList, Canvas, XX, YTable-YOffset, XX+TableWidth-1,
|
|
YY+CellSpacing-YOffset-1, True);
|
|
if not TopCaption then
|
|
Caption.Cell.Draw(Canvas, ARect, CaptionWidth, XX+CaptionIndent-Indent,
|
|
YTable+TableHeight);
|
|
end;
|
|
end;
|
|
|
|
{----------------ThtmlTable.GetURL}
|
|
function ThtmlTable.GetURL(Canvas: TCanvas; X: integer; Y: integer;
|
|
var UrlTarg: TUrlTarget; var FormControl: TImageFormControlObj): boolean;
|
|
{Y is relative to top of section}
|
|
var
|
|
CaptionOK, TableOK: boolean;
|
|
|
|
function GetTableURL(X: integer; Y: integer): boolean;
|
|
var
|
|
I, J, XX, YY: integer;
|
|
begin
|
|
YY := 0;
|
|
for J := 0 to Rows.Count-1 do
|
|
begin
|
|
XX := DrawX;
|
|
with TCellList(Rows[J]) do
|
|
begin
|
|
for I := 0 to Count-1 do
|
|
begin
|
|
if Assigned(Items[I]) then
|
|
with TCellObj(Items[I]) do
|
|
begin
|
|
if (X >=XX) and (X < XX+Wd)
|
|
and (Y >= YY) and (Y < YY+Ht) then
|
|
begin
|
|
Result := Cell.GetUrl(Canvas, X,
|
|
Y-YY-(CellSpacing+CellPadding+YIndent), UrlTarg, FormControl);
|
|
Exit;
|
|
end;
|
|
end;
|
|
Inc(XX, Widths[I]);
|
|
end;
|
|
Inc(YY, RowHeight);
|
|
end;
|
|
end;
|
|
Result := False;
|
|
end;
|
|
|
|
begin
|
|
Result := False;
|
|
if (Y <= DrawHeight) then
|
|
begin
|
|
TableOK := (X >= DrawX) and (X <= TableWidth+DrawX);
|
|
CaptionOK := (X >= DrawX+CaptionIndent-Indent) and (X <= DrawX+CaptionWidth+CaptionIndent-Indent);
|
|
if TopCaption then
|
|
if Y < CaptionHeight then
|
|
begin
|
|
if CaptionOK then
|
|
Result := Caption.Cell.GetURL(Canvas, X, Y, UrlTarg, FormControl);
|
|
end
|
|
else
|
|
begin
|
|
if TableOK then
|
|
Result := GetTableURL(X, Y-CaptionHeight);
|
|
end
|
|
else
|
|
if Y < TableHeight then
|
|
begin
|
|
if TableOK then
|
|
Result := GetTableURL(X, Y);
|
|
end
|
|
else
|
|
begin
|
|
if CaptionOK then
|
|
Result := Caption.Cell.GetURL(Canvas, X, Y-TableHeight, UrlTarg, FormControl);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function ThtmlTable.PtInObject(X : integer; Y: integer; var Obj: TObject;
|
|
var IX, IY: integer): boolean;
|
|
{Y is relative to top of section}
|
|
var
|
|
CaptionOK, TableOK: boolean;
|
|
|
|
function GetTableObj(X: integer; Y: integer): boolean;
|
|
var
|
|
I, J, XX, YY: integer;
|
|
begin
|
|
YY := 0;
|
|
for J := 0 to Rows.Count-1 do
|
|
begin
|
|
XX := DrawX;
|
|
with TCellList(Rows[J]) do
|
|
begin
|
|
for I := 0 to Count-1 do
|
|
begin
|
|
if Assigned(Items[I]) then
|
|
with TCellObj(Items[I]) do
|
|
begin
|
|
if (X >=XX) and (X < XX+Wd)
|
|
and (Y >= YY) and (Y < YY+Ht) then
|
|
begin
|
|
Result := Cell.PtInObject(X, Y-YY-(CellSpacing+CellPadding+YIndent),
|
|
Obj, IX, IY);
|
|
Exit;
|
|
end;
|
|
end;
|
|
Inc(XX, Widths[I]);
|
|
end;
|
|
Inc(YY, RowHeight);
|
|
end;
|
|
end;
|
|
Result := False;
|
|
end;
|
|
|
|
begin
|
|
Result := False;
|
|
if (Y <= DrawHeight) then
|
|
begin
|
|
TableOK := (X >= DrawX) and (X <= TableWidth+DrawX);
|
|
CaptionOK := (X >= DrawX+CaptionIndent-Indent) and (X <= DrawX+CaptionWidth+CaptionIndent-Indent);
|
|
if TopCaption then
|
|
if Y < CaptionHeight then
|
|
begin
|
|
if CaptionOK then
|
|
Result := Caption.Cell.PtInObject(X, Y, Obj, IX, IY);
|
|
end
|
|
else
|
|
begin
|
|
if TableOK then
|
|
Result := GetTableObj(X, Y-CaptionHeight);
|
|
end
|
|
else
|
|
if Y < TableHeight then
|
|
begin
|
|
if TableOK then
|
|
Result := GetTableObj(X, Y);
|
|
end
|
|
else
|
|
begin
|
|
if CaptionOK then
|
|
Result := Caption.Cell.PtInObject(X, Y-TableHeight, Obj, IX, IY);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{----------------ThtmlTable.FindCursor}
|
|
function ThtmlTable.FindCursor(Canvas: TCanvas; X: integer; Y: integer;
|
|
var XR: integer; var YR: integer; var CaretHt: integer;
|
|
var SCell: TObject; var Intext: boolean): integer;
|
|
{Y is relative to top of section}
|
|
var
|
|
CaptionOK, TableOK: boolean;
|
|
|
|
function GetTableCursor(X: integer; Y: integer; var XR: integer;
|
|
var YR: integer; var CaretHt: integer; var Intext: boolean): integer;
|
|
var
|
|
I, J, XX, YY: integer;
|
|
begin
|
|
YY := 0;
|
|
for J := 0 to Rows.Count-1 do
|
|
begin
|
|
XX := DrawX;
|
|
with TCellList(Rows[J]) do
|
|
begin
|
|
for I := 0 to Count-1 do
|
|
begin
|
|
if Assigned(Items[I]) then
|
|
with TCellObj(Items[I]) do
|
|
begin
|
|
if (X >=XX) and (X < XX+Wd)
|
|
and (Y >= YY) and (Y < YY+Ht) then
|
|
begin
|
|
Result := Cell.FindCursor(Canvas, X,
|
|
Y-YY-(CellSpacing+CellPadding+YIndent), XR, YR, CaretHt, SCell, InText);
|
|
Inc(YR, YY+(CellSpacing+CellPadding+YIndent));
|
|
Exit;
|
|
end;
|
|
end;
|
|
Inc(XX, Widths[I]);
|
|
end;
|
|
Inc(YY, RowHeight);
|
|
end;
|
|
end;
|
|
Result := -1;
|
|
end;
|
|
|
|
begin
|
|
Result := -1;
|
|
if (Y <= SectionHeight) then
|
|
begin
|
|
TableOK := (X >= DrawX) and (X <= TableWidth+DrawX);
|
|
CaptionOK := (X >= DrawX+CaptionIndent-Indent) and (X <= DrawX+CaptionWidth+CaptionIndent-Indent);
|
|
if TopCaption then
|
|
if Y < CaptionHeight then
|
|
begin
|
|
if CaptionOK then
|
|
begin
|
|
Result := Caption.Cell.FindCursor(Canvas, X, Y, XR, YR, CaretHt, SCell, InText);
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
if TableOK then
|
|
begin
|
|
Result := GetTableCursor(X, Y-CaptionHeight, XR, YR, CaretHt, InText);
|
|
Inc(YR, CaptionHeight);
|
|
end;
|
|
end
|
|
else
|
|
if Y < TableHeight then
|
|
begin
|
|
if TableOK then
|
|
begin
|
|
Result := GetTableCursor(X, Y, XR, YR, CaretHt, InText);
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
if CaptionOK then
|
|
begin
|
|
Result := Caption.Cell.FindCursor(Canvas, X, Y-TableHeight,
|
|
XR, YR, CaretHt, SCell, InText);
|
|
Inc(YR, TableHeight);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function ThtmlTable.CursorToXY(Canvas: TCanvas; Cursor: integer;
|
|
var X: integer; var Y: integer): boolean;
|
|
{note: returned X value is not correct here but it isn't used}
|
|
var
|
|
I, J: integer;
|
|
begin
|
|
Result := False;
|
|
if (Len = 0) or (Cursor > StartCurs + Len) then Exit;
|
|
if TopCaption then
|
|
begin
|
|
Result := Caption.Cell.CursorToXy(Canvas, Cursor, X, Y);
|
|
if Result then Exit;
|
|
end;
|
|
for J := 0 to Rows.Count-1 do
|
|
with TCellList(Rows[J]) do
|
|
for I := 0 to Count-1 do
|
|
if Assigned(Items[I]) then
|
|
with TCellObj(Items[I]) do
|
|
begin
|
|
Result := Cell.CursorToXy(Canvas, Cursor, X, Y);
|
|
if Result then Exit;
|
|
end;
|
|
if not TopCaption then
|
|
Result := Caption.Cell.CursorToXy(Canvas, Cursor, X, Y);
|
|
end;
|
|
|
|
{----------------ThtmlTable.GetChAtPos}
|
|
function ThtmlTable.GetChAtPos(Pos: integer; var Ch: char; var Obj: TObject): boolean;
|
|
var
|
|
I, J: integer;
|
|
begin
|
|
Result := False;
|
|
if (Len = 0) or (Pos < StartCurs) or (Pos > StartCurs + Len) then Exit;
|
|
|
|
Result := Caption.Cell.GetChAtPos(Pos, Ch, Obj);
|
|
if Result then Exit;
|
|
|
|
for J := 0 to Rows.Count-1 do
|
|
with TCellList(Rows[J]) do
|
|
for I := 0 to Count-1 do
|
|
if Assigned(Items[I]) then
|
|
with TCellObj(Items[I]) do
|
|
begin
|
|
Result := Cell.GetChAtPos(Pos, Ch, Obj);
|
|
if Result then Exit;
|
|
end;
|
|
end;
|
|
|
|
{----------------ThtmlTable.FindString}
|
|
function ThtmlTable.FindString(From: integer; PC: PChar;
|
|
MatchCase: boolean): integer;
|
|
var
|
|
I, J: integer;
|
|
begin
|
|
Result := -1;
|
|
if TopCaption then
|
|
begin
|
|
Result := Caption.Cell.FindString(From, PC, MatchCase);
|
|
if Result >= 0 then Exit;
|
|
end;
|
|
for J := 0 to Rows.Count-1 do
|
|
with TCellList(Rows[J]) do
|
|
for I := 0 to Count-1 do
|
|
if Assigned(Items[I]) then
|
|
with TCellObj(Items[I]) do
|
|
begin
|
|
Result := Cell.FindString(From, PC, MatchCase);
|
|
if Result >= 0 then Exit;
|
|
end;
|
|
if not TopCaption then
|
|
Result := Caption.Cell.FindString(From, PC, MatchCase);
|
|
end;
|
|
|
|
{----------------ThtmlTable.FindSourcePos}
|
|
function ThtmlTable.FindSourcePos(DocPos: integer): integer;
|
|
var
|
|
I, J: integer;
|
|
begin
|
|
Result := -1;
|
|
if TopCaption then
|
|
begin
|
|
Result := Caption.Cell.FindSourcePos(DocPos);
|
|
if Result >= 0 then Exit;
|
|
end;
|
|
for J := 0 to Rows.Count-1 do
|
|
with TCellList(Rows[J]) do
|
|
for I := 0 to Count-1 do
|
|
if Assigned(Items[I]) then
|
|
with TCellObj(Items[I]) do
|
|
begin
|
|
Result := Cell.FindSourcePos(DocPos);
|
|
if Result >= 0 then Exit;
|
|
end;
|
|
if not TopCaption then
|
|
Result := Caption.Cell.FindSourcePos(DocPos);
|
|
end;
|
|
|
|
{----------------ThtmlTable.FindDocPos}
|
|
function ThtmlTable.FindDocPos(SourcePos: integer; Prev: boolean): integer;
|
|
var
|
|
I, J: integer;
|
|
begin
|
|
if not Prev then
|
|
begin
|
|
Result := Caption.Cell.FindDocPos(SourcePos, Prev);
|
|
if Result >= 0 then Exit;
|
|
|
|
if not Prev then
|
|
for J := 0 to Rows.Count-1 do
|
|
with TCellList(Rows[J]) do
|
|
for I := 0 to Count-1 do
|
|
if Assigned(Items[I]) then
|
|
with TCellObj(Items[I]) do
|
|
begin
|
|
Result := Cell.FindDocPos(SourcePos, Prev);
|
|
if Result >= 0 then Exit;
|
|
end;
|
|
end
|
|
else //Prev , iterate in reverse
|
|
begin
|
|
for J := Rows.Count-1 downto 0 do
|
|
with TCellList(Rows[J]) do
|
|
for I := Count-1 downto 0 do
|
|
if Assigned(Items[I]) then
|
|
with TCellObj(Items[I]) do
|
|
begin
|
|
Result := Cell.FindDocPos(SourcePos, Prev);
|
|
if Result >= 0 then Exit;
|
|
end;
|
|
Result := Caption.Cell.FindDocPos(SourcePos, Prev);
|
|
end;
|
|
end;
|
|
|
|
{----------------ThtmlTable.CopyToClipboard}
|
|
procedure ThtmlTable.CopyToClipboard;
|
|
var
|
|
I, J: integer;
|
|
begin
|
|
if TopCaption then
|
|
Caption.Cell.CopyToClipboard;
|
|
|
|
for J := 0 to Rows.Count-1 do
|
|
with TCellList(Rows[J]) do
|
|
for I := 0 to Count-1 do
|
|
if Assigned(Items[I]) then
|
|
with TCellObj(Items[I]) do
|
|
Cell.CopyToClipboard;
|
|
if not TopCaption then
|
|
Caption.Cell.CopyToClipboard;
|
|
end;
|
|
|
|
{----------------TSection.Create}
|
|
constructor TSection.Create(AMasterList: TSectionList; ALevel: integer; AFont: TMyFont; AnURL: TUrlTarget;
|
|
AJustify: JustifyType);
|
|
var
|
|
FO : TFontObj;
|
|
F: TMyFont;
|
|
Parser: ThlParser;
|
|
begin
|
|
inherited Create(AMasterList);
|
|
Parser := ThlParser(ParentSectionList.Parser);
|
|
Buff := Nil;
|
|
Len := 0;
|
|
writeln('TSection.Create ',HexStr(Cardinal(Self),8),' Len=',Len);
|
|
BuffSize := 0;
|
|
Parser.CurrentSScript := Normal;
|
|
Fonts := TFontList.Create;
|
|
F := TMyFont.Create;
|
|
F.Assign(AFont);
|
|
F.Style := F.Style + Parser.CurrentStyle;
|
|
FO := TFontObj.Create(Self, F, 0);
|
|
if Assigned(AnURL) and (Length(AnURL.Url) > 0) then
|
|
begin
|
|
FO.UrlTarget.Assign(AnUrl.Url, AnUrl.Target);
|
|
ParentSectionList.LinkList.Add(FO);
|
|
end;
|
|
Fonts.Add(FO);
|
|
DefFont := TMyFont.Create;
|
|
DefFont.Assign(F);
|
|
|
|
Images := TImageObjList.Create;
|
|
FormControls := TFormControlList.Create;
|
|
|
|
Level := ALevel;
|
|
Indent := ALevel * ListIndent;
|
|
ListType := None;
|
|
Lines := TFreeList.Create;
|
|
Justify := AJustify;
|
|
end;
|
|
|
|
{----------------TSection.Destroy}
|
|
destructor TSection.Destroy;
|
|
begin
|
|
writeln('TSection.Destroy ',HexStr(Cardinal(Self),8));
|
|
if Assigned(Buff) then FreeMem(Buff, BuffSize);
|
|
if Assigned(XP) then
|
|
FreeMem(XP);
|
|
Fonts.Free;
|
|
Images.Free;
|
|
FormControls.Free;
|
|
SIndexList.Free;
|
|
Lines.Free;
|
|
DefFont.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TSection.DoClearAttribute(L: TAttributeList);
|
|
var
|
|
T: TAttribute;
|
|
S: string[15];
|
|
begin
|
|
if L.Find(ClearSy, T) then
|
|
begin
|
|
S := LowerCase(T.Name);
|
|
if (S = 'left') then ClearAttr := clLeft
|
|
else if (S = 'right') then ClearAttr := clRight
|
|
else ClearAttr := clAll;
|
|
end;
|
|
end;
|
|
|
|
{----------------TSection.AddChar}
|
|
procedure TSection.AddChar(C: char; Index: integer; NoBreak: boolean);
|
|
var
|
|
Tok: TokenObj;
|
|
begin
|
|
Tok := TokenObj.Create;
|
|
Tok.S := C;
|
|
Tok.I^[1] := Index;
|
|
AddTokenObj(Tok, NoBreak);
|
|
Tok.Free;
|
|
end;
|
|
|
|
function TSection.GetIndexObj(I: integer): IndexObj;
|
|
begin
|
|
Result := IndexObj(SIndexList[I]);
|
|
end;
|
|
|
|
procedure TSection.Finish;
|
|
{complete some things after all information added}
|
|
var
|
|
Last, I: integer;
|
|
IO: IndexObj;
|
|
begin
|
|
if Len > 0 then
|
|
begin
|
|
Buff[Len] := #0;
|
|
if Assigned(XP) then {XP = Nil when printing}
|
|
begin
|
|
Last := 0; {to prevent warning msg}
|
|
SIndexList := TFreeList.Create;
|
|
for I := 0 to Len-1 do
|
|
begin
|
|
if (I = 0) or (XP^[I] <> Last+1) then
|
|
begin
|
|
IO := IndexObj.Create;
|
|
IO.Pos := I;
|
|
IO.Index := XP^[I];
|
|
SIndexList.Add(IO);
|
|
end;
|
|
Last := XP^[I];
|
|
end;
|
|
FreeMem(XP);
|
|
XP := Nil;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{----------------TSection.AddTokenObj}
|
|
procedure TSection.AddTokenObj(S : TokenObj; NoBreak: boolean);
|
|
var
|
|
L, I : integer;
|
|
|
|
Procedure Remove(I: integer);
|
|
begin
|
|
Move(S.I^[I+1], S.I^[I], ((Length(S.S))-I)*Sizeof(integer));
|
|
System.Delete(S.S, I, 1);
|
|
end;
|
|
begin
|
|
if Length(S.S) = 0 then Exit;
|
|
{Delete leading spaces or multiple spaces}
|
|
if not NoBreak then
|
|
begin
|
|
if ((Len = 0) or (Buff[Len-1] = ' ')) and (S.S[1] = ' ') then
|
|
begin
|
|
if Length(S.S) = 1 then Exit;
|
|
Remove(1);
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
if ((Len = 0) or (Buff[Len-1] in [#5, #160, ' '])) and (S.S[1] = #5) then
|
|
begin
|
|
if Length(S.S) = 1 then Exit;
|
|
Remove(1)
|
|
end;
|
|
I := Pos(' '#5, S.S);
|
|
while I > 0 do
|
|
begin
|
|
Remove(I+1);
|
|
I := Pos(' '#5, S.S);
|
|
end;
|
|
I := Pos(#5#5, S.S);
|
|
while I > 0 do
|
|
begin
|
|
Remove(I);
|
|
I := Pos(#5#5, S.S);
|
|
end;
|
|
I := Pos(#5' ', S.S);
|
|
while I > 0 do
|
|
begin
|
|
Remove(I);
|
|
I := Pos(#5' ', S.S);
|
|
end;
|
|
I := Pos(#5, S.S);
|
|
while I > 0 do
|
|
begin
|
|
S.S[I] := #160;
|
|
I := Pos(#5, S.S);
|
|
end;
|
|
end;
|
|
|
|
{After floating images at start, delete an annoying space}
|
|
if Len > 0 then
|
|
for I := 0 to Len-1 do
|
|
begin
|
|
if (not (Buff[I] in [#4, #7])) or not (Images.FindImage(I).ObjAlign in [ALeft, ARight]) then
|
|
Break;
|
|
if (I = Len-1) and (Length(S.S) > 0) and (S.S[1] in [' ', #160]) then
|
|
begin
|
|
if Length(S.S) = 1 then Exit;
|
|
Remove(1)
|
|
end;
|
|
end;
|
|
|
|
L := Len+Length(S.S);
|
|
if BuffSize < L+1 then Allocate(L + 100); {L+1 so there is always extra for font at end}
|
|
Move(S.S[1], (Buff+Len)^, Length(S.S));
|
|
Move(S.I[1], XP^[Len], Length(S.S)*Sizeof(integer));
|
|
Len := L;
|
|
writeln('TSection.AddTokenObj ',HexStr(Cardinal(Self),8),' Len=',Len);
|
|
end;
|
|
|
|
function TSection.BreakInfo(Index: integer; NoBreak: boolean): JustifyType; {called when <br> encountered}
|
|
begin
|
|
Result := Justify;
|
|
if Len = 0 then {need to have at least one space}
|
|
begin
|
|
AddChar('X', Index, NoBreak); {fool AddTokenObj into adding a leading space}
|
|
Buff[0] := ' ';
|
|
end;
|
|
end;
|
|
|
|
{----------------TSection.Allocate}
|
|
procedure TSection.Allocate(N : integer);
|
|
begin
|
|
if BuffSize < N then
|
|
begin
|
|
ReAllocMem(Buff, N);
|
|
ReAllocMem(XP, N*Sizeof(integer));
|
|
BuffSize := N;
|
|
end;
|
|
end;
|
|
|
|
procedure TSection.ChangeFont(List: TSectionList; NewFont: TMyFont);
|
|
{will not accommodate a font size change}
|
|
var
|
|
F: TMyFont;
|
|
FO: TFontObj;
|
|
LastUrl: TUrlTarget;
|
|
begin
|
|
FO := TFontObj(Fonts[Fonts.Count-1]);
|
|
LastUrl := FO.UrlTarget;
|
|
If FO.Pos = Len then
|
|
FO.TheFont.Assign(NewFont) {fontobj already at this position, modify it}
|
|
else
|
|
begin
|
|
F := TMyFont.Create;
|
|
F.Assign(NewFont);
|
|
FO := TFontObj.Create(Self, F, Len);
|
|
Fonts.Add(FO);
|
|
if Assigned(LastUrl) then
|
|
FO.URLTarget.Assign(LastUrl.Url, LastUrl.Target);
|
|
end;
|
|
with ThlParser(ParentSectionList.Parser) do
|
|
begin
|
|
with FO.TheFont, (ParentSectionList.Parser as ThlParser) do
|
|
Style := Style + CurrentStyle; {add in <b>, <i>, etc}
|
|
FO.SScript := CurrentSScript;
|
|
if CurrentSScript in [SupSc, SubSc] then
|
|
FO.TheFont.SetNormalSize(List, MulDiv(FO.TheFont.NormalSize, 3, 4));
|
|
end;
|
|
end;
|
|
|
|
procedure TSection.ChangeStyle(Sy: Symb);
|
|
var
|
|
Style: TFontStyles;
|
|
F: TMyFont;
|
|
FO: TFontObj;
|
|
begin
|
|
if Sy in [BSy, BEndSy, ISy, IEndSy, EmSy, EmEndSy, StrongSy, StrongEndSy,
|
|
USy, UEndSy, CiteSy, CiteEndSy, VarSy, VarEndSy] then
|
|
begin
|
|
FO := TFontObj(Fonts[Fonts.Count-1]);
|
|
Style := FO.TheFont.Style;
|
|
case Sy of
|
|
BSy, StrongSy: Style := Style + [fsBold];
|
|
BEndSy, StrongEndSy: Style := Style - [fsBold];
|
|
ISy, EmSy, CiteSy, VarSy: Style := Style + [fsItalic];
|
|
IEndSy, EmEndSy, CiteEndSy, VarEndSy: Style := Style - [fsItalic];
|
|
USy: Style := Style + [fsUnderline];
|
|
UEndSy: Style := Style - [fsUnderline];
|
|
end;
|
|
If FO.Pos = Len then
|
|
FO.TheFont.Style := Style {fontobj already at this position, modify it}
|
|
else
|
|
begin
|
|
F := TMyFont.Create;
|
|
F.Assign(FO.TheFont); {just like the last one}
|
|
F.Style := Style;
|
|
FO := TFontObj.Create(Self, F, Len);
|
|
Fonts.Add(FO);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TSection.HRef(Sy: Symb; List: TSectionList; AnURL: TUrlTarget;
|
|
AFont: TMyFont);
|
|
var
|
|
FO: TFontObj;
|
|
begin
|
|
ChangeFont(List, AFont);
|
|
FO := TFontObj(Fonts[Fonts.Count-1]);
|
|
FO.UrlTarget.Clear;
|
|
if Sy = HRefSy then
|
|
begin
|
|
FO.UrlTarget.Assign(AnUrl.Url, AnUrl.Target);
|
|
List.LinkList.Add(FO);
|
|
end;
|
|
end;
|
|
|
|
function TSection.AddImage(L: TAttributeList; ACell: TCell; Index: integer; NoBreak: boolean): TImageObj;
|
|
begin
|
|
Result := TImageObj.Create(Len, L);
|
|
Result.MyCell := ACell;
|
|
Images.Add(Result);
|
|
if NoBreak then
|
|
AddChar(#7, Index, NoBreak) {marker for nobreak image}
|
|
else
|
|
AddChar(#4, Index, NoBreak); {marker for image}
|
|
end;
|
|
|
|
{----------------TSection.AddFormControl}
|
|
function TSection.AddFormControl(Which: Symb; AMasterList: TSectionList;
|
|
L: TAttributeList; ACell: TCell; Index: integer; NoBreak: boolean): TFormControlObj;
|
|
var
|
|
T: TAttribute;
|
|
FCO: TFormControlObj;
|
|
S: string[20];
|
|
IO: TImageObj;
|
|
|
|
procedure GetEditFCO;
|
|
begin
|
|
FCO := TEditFormControlObj.Create(AMasterList, Len, L, S);
|
|
end;
|
|
|
|
begin
|
|
S := '';
|
|
if Which = InputSy then
|
|
begin
|
|
if L.Find(TypeSy, T) then
|
|
begin
|
|
S := LowerCase(T.Name);
|
|
if (S = 'text') or (S = 'password') then
|
|
GetEditFCO
|
|
else if (S = 'submit') or (S = 'reset') or (S = 'button') then
|
|
FCO := TButtonFormControlObj.Create(AMasterList, Len, L, S)
|
|
else if S = 'radio' then
|
|
FCO := TRadioButtonFormControlObj.Create(AMasterList, Len, L, ACell)
|
|
else if S = 'checkbox' then
|
|
FCO := TCheckBoxFormControlObj.Create(AMasterList, Len, L)
|
|
else if S = 'hidden' then
|
|
FCO := THiddenFormControlObj.Create(AMasterList, Len, L)
|
|
else if S = 'image' then
|
|
FCO := TImageFormControlObj.Create(AMasterList, Len, L)
|
|
else
|
|
GetEditFCO;
|
|
end
|
|
else
|
|
GetEditFCO;
|
|
end
|
|
else if Which = SelectSy then
|
|
begin
|
|
if L.Find(MultipleSy, T) or L.Find(SizeSy, T) and (T.Value > 1) then
|
|
FCO := TListBoxFormControlObj.Create(AMasterList, Len, L)
|
|
else
|
|
FCO := TComboFormControlObj.Create(AMasterList, Len, L);
|
|
end
|
|
else
|
|
FCO := TTextAreaFormControlObj.Create(AMasterList, Len, L);
|
|
if S = 'image' then
|
|
begin
|
|
IO := AddImage(L, ACell, Index, NoBreak); {leave out of FormControlList}
|
|
IO.MyFormControl := TImageFormControlObj(FCO);
|
|
end
|
|
else if S <> 'hidden' then
|
|
begin
|
|
FormControls.Add(FCO);
|
|
if NoBreak then
|
|
AddChar(#6, Index, NoBreak) {marker for no break FormControl}
|
|
else
|
|
AddChar(#2, Index, NoBreak); {marker for FormControl}
|
|
end;
|
|
Result := FCO;
|
|
end;
|
|
|
|
{----------------TSection.FindCountThatFits}
|
|
function TSection.FindCountThatFits(Canvas: TCanvas; Width : integer;
|
|
Start : PChar; Max : integer) : integer;
|
|
{Given a width, find the count of chars (<= Max) which will fit allowing for
|
|
font changes. Line wrapping will be done later}
|
|
var
|
|
Cnt, XX, I, J, J1, J2, J3, OHang, Tmp : integer;
|
|
Picture: boolean;
|
|
Align: AlignmentType;
|
|
HSpc: integer;
|
|
|
|
function Find(Width, Max: integer; Start: PChar): integer;
|
|
{return count <= Max which fits in Width}
|
|
var
|
|
L, H, I, X: integer;
|
|
ExtS: TSize;
|
|
{$ifndef ver120_plus}
|
|
NilP: integer absolute 0;
|
|
{$endif}
|
|
begin
|
|
L := 0; H := Max-1;
|
|
while L <= H do
|
|
begin
|
|
I := (L+H) shr 1;
|
|
{$ifdef ver120_plus}
|
|
GetTextExtentExPoint(Canvas.Handle, Start, I+1, 0, Nil, Nil, ExtS);
|
|
{$else} {do Nil the hard way for Delphi 3}
|
|
GetTextExtentExPoint(Canvas.Handle, Start, I+1, 0, NilP, NilP, ExtS);
|
|
{$endif}
|
|
x := ExtS.cx - OHang;
|
|
if X <= Width then
|
|
L := I+1
|
|
else H := I-1;
|
|
end;
|
|
Result := L;
|
|
end;
|
|
|
|
begin
|
|
Cnt := 0;
|
|
XX := 0;
|
|
while True do
|
|
begin
|
|
Canvas.Font := Fonts.GetFontAt(Start-Buff, OHang);
|
|
J1 := Fonts.GetFontCountAt(Start-Buff, Len);
|
|
J2 := Images.GetImageCountAt(Start-Buff);
|
|
J3 := TFormControlList(FormControls).GetControlCountAt(Start-Buff);
|
|
if J2 = 0 then
|
|
begin
|
|
Tmp:= Images.GetWidthAt(Start-Buff, Align, HSpc);
|
|
if not (Align in [ALeft, ARight]) then
|
|
XX := XX + Tmp + 2*HSpc;
|
|
I := 1; J := 1;
|
|
Picture := True;
|
|
if XX > Width then break;
|
|
end
|
|
else if J3 = 0 then
|
|
begin
|
|
XX := XX + TFormControlList(FormControls).GetWidthAt(Start-Buff);
|
|
I := 1; J := 1;
|
|
Picture := True;
|
|
if XX > Width then break;
|
|
end
|
|
else
|
|
begin
|
|
Picture := False;
|
|
J := IntMin(J1, J2);
|
|
J := IntMin(J, J3);
|
|
I := Find(Width-XX, J, Start);
|
|
end;
|
|
if Cnt+I >= Max then {I has been initialized}
|
|
begin
|
|
Cnt := Max;
|
|
Break;
|
|
end
|
|
else Inc(Cnt, I);
|
|
|
|
if not Picture then
|
|
begin
|
|
if I < J then Break;
|
|
XX := XX + GetXExtent(Canvas.Handle, Start, I) - OHang;
|
|
end;
|
|
|
|
Inc(Start, I);
|
|
end;
|
|
Result := Cnt;
|
|
end;
|
|
|
|
{----------------TSection.FindCountThatFits1}
|
|
function TSection.FindCountThatFits1(Canvas: TCanvas; Width : integer;
|
|
Start : PChar; Max: integer; Y: integer; IMgr: IndentManager;
|
|
var ImgHt: integer; NxImages: TList) : integer;
|
|
{Given a width, find the count of chars (<= Max) which will fit allowing for
|
|
font changes. Line wrapping will be done later}
|
|
var
|
|
Cnt, XX, I, J, J1, J2, J3, OHang, ImgWidth : integer;
|
|
Picture: boolean;
|
|
Align: AlignmentType;
|
|
ImageAtStart: boolean;
|
|
FlObj: TFloatingObj;
|
|
HSpc: integer;
|
|
|
|
function Find(Width, Max: integer; Start: PChar): integer;
|
|
{return count <= Max which fits in Width}
|
|
var
|
|
L, H, I, X: integer;
|
|
ExtS: TSize;
|
|
{$ifndef ver120_plus}
|
|
NilP: integer absolute 0;
|
|
{$endif}
|
|
begin
|
|
L := 0; H := Max-1;
|
|
while L <= H do
|
|
begin
|
|
I := (L+H) shr 1;
|
|
{$ifdef ver120_plus}
|
|
GetTextExtentExPoint(Canvas.Handle, Start, I+1, 0, Nil, Nil, ExtS);
|
|
{$else} {do Nil the hard way for Delphi 3}
|
|
GetTextExtentExPoint(Canvas.Handle, Start, I+1, 0, NilP, NilP, ExtS);
|
|
{$endif}
|
|
x := ExtS.cx - OHang;
|
|
if X <= Width then
|
|
L := I+1
|
|
else H := I-1;
|
|
end;
|
|
Result := L;
|
|
end;
|
|
|
|
begin
|
|
ImageAtStart := True;
|
|
ImgHt := 0;
|
|
Cnt := 0;
|
|
XX := 0;
|
|
while True do
|
|
begin
|
|
Canvas.Font := Fonts.GetFontAt(Start-Buff, OHang);
|
|
J1 := Fonts.GetFontCountAt(Start-Buff, Len);
|
|
J2 := Images.GetImageCountAt(Start-Buff);
|
|
J3 := TFormControlList(FormControls).GetControlCountAt(Start-Buff);
|
|
if J2 = 0 then
|
|
begin {next is an image}
|
|
ImgWidth := Images.GetWidthAt(Start-Buff, Align, HSpc);
|
|
if Align in [ALeft, ARight] then
|
|
begin
|
|
FlObj := Images.FindImage(Start-Buff);
|
|
if ImageAtStart then
|
|
begin
|
|
IMgr.Update(Y, FlObj);
|
|
Inc(XX, ImgWidth + FlObj.HSpace);
|
|
ImgHt := IntMax(ImgHt, FlObj.ImageHeight + 2*FlObj.VSpace);
|
|
end
|
|
else
|
|
NxImages.Add(FlObj); {save it for the next line}
|
|
end
|
|
else
|
|
begin
|
|
Inc(XX, ImgWidth+2*HSpc);
|
|
ImageAtStart := False;
|
|
end;
|
|
I := 1; J := 1;
|
|
Picture := True;
|
|
if XX > Width then break;
|
|
end
|
|
else if J3 = 0 then
|
|
begin
|
|
XX := XX + TFormControlList(FormControls).GetWidthAt(Start-Buff);
|
|
I := 1; J := 1;
|
|
Picture := True;
|
|
ImageAtStart := False;
|
|
if XX > Width then break;
|
|
end
|
|
else
|
|
begin
|
|
Picture := False;
|
|
J := IntMin(J1, J2);
|
|
J := IntMin(J, J3);
|
|
I := Find(Width-XX, J, Start);
|
|
end;
|
|
if Cnt+I >= Max then {I has been initialized}
|
|
begin
|
|
Cnt := Max;
|
|
Break;
|
|
end
|
|
else Inc(Cnt, I);
|
|
|
|
if not Picture then {Picture has been initialized}
|
|
begin
|
|
if I < J then Break; {J has been initialized}
|
|
XX := XX + GetXExtent(Canvas.Handle, Start, I) - OHang;
|
|
ImageAtStart := False;
|
|
end;
|
|
|
|
Inc(Start, I);
|
|
end;
|
|
Result := Cnt;
|
|
end;
|
|
|
|
{----------------TSection.MinMaxWidth}
|
|
procedure TSection.MinMaxWidth(Canvas: TCanvas; var Min, Max: integer);
|
|
{Min is the width the section would occupy when wrapped as tightly as possible.
|
|
Max, the width if no wrapping were used.}
|
|
var
|
|
I, Indx, FloatMin: integer;
|
|
P, P1: PChar;
|
|
Obj: TObject;
|
|
|
|
begin
|
|
Min := 0;
|
|
Max := 0;
|
|
if not Assigned(Buff) then Exit;
|
|
|
|
for I := 0 to Images.Count-1 do {call drawlogic for all the images}
|
|
begin
|
|
Obj := TObject(Images[I]);
|
|
if (Obj is TImageObj) then
|
|
with TImageObj(Obj) do
|
|
begin
|
|
DrawLogic(Self.ParentSectionList, Canvas, Fonts.GetFontObjAt(Pos, Indx), 0);
|
|
if not PercentWidth then
|
|
if ObjAlign in [ALeft, ARight] then
|
|
Max := Max + ImageWidth + HSpace
|
|
else Min := IntMax(Min, ImageWidth);
|
|
end
|
|
else
|
|
with TFloatingObj(Obj) do
|
|
if ObjAlign in [ALeft, ARight] then
|
|
Max := Max + ImageWidth + HSpace
|
|
else Min := IntMax(Min, ImageWidth);
|
|
end;
|
|
FloatMin := Max;
|
|
Max := FindTextWidth(Canvas, Buff, Len, False) + Indent + Max;
|
|
|
|
Buff[Len] := #0; {always extra space on end}
|
|
P := Buff;
|
|
while P^ = ' ' do Inc(P);
|
|
P1 := P;
|
|
while P^ <> #0 do
|
|
begin
|
|
while not (P1^ in [' ', #4, #0]) do Inc(P1);
|
|
Min := IntMax(Min, FindTextWidth(Canvas, P, P1-P, False));
|
|
while (P1^ in [' ', #4]) do Inc(P1);
|
|
P := P1;
|
|
end;
|
|
Min := Min + FloatMin + Indent;
|
|
end;
|
|
|
|
{----------------TSection.FindTextWidth}
|
|
function TSection.FindTextWidth(Canvas: TCanvas; Start: PChar; N: integer;
|
|
RemoveSpaces: boolean): integer;
|
|
{find actual line width of N chars starting at Start. If RemoveSpaces set,
|
|
don't count spaces on right end}
|
|
var
|
|
I, J, J1, OHang, Wid, HSpc: integer;
|
|
Align: AlignmentType;
|
|
begin
|
|
Result := 0;
|
|
if RemoveSpaces then
|
|
while ((Start+N-1)^ = ' ') and (N > 1) do
|
|
Dec(N); {remove spaces on end}
|
|
while N > 0 do
|
|
begin
|
|
J := Images.GetImageCountAt(Start-Buff);
|
|
J1 := TFormControlList(FormControls).GetControlCountAt(Start-Buff);
|
|
if J = 0 then {it's and image}
|
|
begin
|
|
Wid := Images.GetWidthAt(Start-Buff, Align, HSpc);
|
|
{Here we count floating images as 1 char but do not include their width,
|
|
This is required for the call in FindCursor}
|
|
if not (Align in [ALeft, ARight]) then
|
|
begin
|
|
Result := Result + Wid + 2*HSpc;
|
|
end;
|
|
Dec(N); {image counts as one char}
|
|
Inc(Start);
|
|
end
|
|
else if J1 = 0 then
|
|
begin
|
|
Result := Result + TFormControlList(FormControls).GetWidthAt(Start-Buff);
|
|
Dec(N); {control counts as one char}
|
|
Inc(Start);
|
|
end
|
|
else
|
|
begin
|
|
Canvas.Font := Fonts.GetFontAt(Start-Buff, OHang);
|
|
I := IntMin(J, J1);
|
|
I := IntMin(I, IntMin(Fonts.GetFontCountAt(Start-Buff, Len), N));
|
|
Inc(Result, GetXExtent(Canvas.Handle, Start, I) - OHang);
|
|
Dec(N, I);
|
|
Inc(Start, I);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{----------------TSection.DrawLogic}
|
|
function TSection.DrawLogic(Canvas : TCanvas; Y: integer; IMgr: IndentManager;
|
|
var MaxWidth: integer; var Curs: integer): integer;
|
|
{returns height of the section}
|
|
var
|
|
PStart, P, Last : PChar;
|
|
Max, N, Width, I, Indx, ImgHt: integer;
|
|
Finished: boolean;
|
|
LR : LineRec;
|
|
NxImages: TList;
|
|
Tmp: integer;
|
|
Obj: TFloatingObj;
|
|
|
|
function GetClearSpace: integer;
|
|
var
|
|
CL, CR: integer;
|
|
begin
|
|
Result := 0;
|
|
if (ClearAttr <> clrNone) then
|
|
begin {may need to move down past floating image}
|
|
IMgr.GetClearY(CL, CR);
|
|
case ClearAttr of
|
|
clLeft: Result := IntMax(0, CL-Y-1);
|
|
clRight: Result := IntMax(0, CR-Y-1);
|
|
clAll: Result := IntMax(CL-Y-1, IntMax(0, CR-Y-1));
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure LineComplete(NN : integer);
|
|
var
|
|
I, J, DHt, Desc, Tmp, Cnt, Index, H, SB, SA : integer;
|
|
FP : TFontObj;
|
|
Align: AlignmentType;
|
|
BaseLine: boolean;
|
|
NoChar: boolean;
|
|
P: PChar;
|
|
FCO: TFormControlObj;
|
|
begin
|
|
DHt := 0; {for the fonts on this line get the maximum height}
|
|
Cnt := 0;
|
|
Desc := 0;
|
|
NoChar := True;
|
|
P := PStart;
|
|
for I := 0 to NN-1 do
|
|
begin
|
|
if not (P^ in [#2, #4, #6, #7]) then
|
|
begin {check for the no character case}
|
|
NoChar := False;
|
|
Break;
|
|
end;
|
|
Inc(P);
|
|
end;
|
|
|
|
if not NoChar then
|
|
repeat
|
|
FP := Fonts.GetFontObjAt(PStart-Buff+Cnt, Index);
|
|
Tmp := FP.GetHeight(Desc);
|
|
DHt := IntMax(DHt, Tmp);
|
|
LR.Descent := IntMax(LR.Descent, Desc);
|
|
J := Fonts.GetFontCountAt(PStart-Buff+Cnt, Len);
|
|
Inc(Cnt, J);
|
|
until Cnt >= NN;
|
|
|
|
Cnt := 0; {if images, then maybe they add extra space}
|
|
SB := 0;
|
|
SA := 0; {space before and after}
|
|
repeat
|
|
Cnt := Cnt + Images.GetImageCountAt(PStart-Buff+Cnt);
|
|
if Cnt < NN then
|
|
begin
|
|
H := Images.GetHeightAt(PStart-Buff+Cnt, Align);
|
|
case Align of
|
|
ATop: SA := IntMax(SA, H - DHt);
|
|
AMiddle:
|
|
begin
|
|
Tmp := (H - DHt) div 2;
|
|
SA := IntMax(SA, Tmp);
|
|
SB := IntMax(SB, (H - DHt - Tmp));
|
|
end;
|
|
ABottom: SB := IntMax(SB, H - (DHt - Desc));
|
|
end;
|
|
end;
|
|
Inc(Cnt); {to skip by the image}
|
|
until Cnt >= NN;
|
|
|
|
Cnt := 0; {now check on form controls}
|
|
repeat
|
|
Cnt := Cnt + TFormControlList(FormControls).GetControlCountAt(PStart-Buff+Cnt);
|
|
if Cnt < NN then
|
|
begin
|
|
H := TFormControlList(FormControls).GetHeightAt(PStart-Buff+Cnt, BaseLine);
|
|
if BaseLine then
|
|
SB := IntMax(SB, H-(DHt-Desc))
|
|
else
|
|
SB := IntMax(SB, H-DHt);
|
|
FCO := TFormControlList(FormControls).FindControl(PStart-Buff+Cnt);
|
|
if Assigned(FCO) then
|
|
FCO.FYValue := Y;
|
|
end;
|
|
Inc(Cnt); {to skip by the control}
|
|
until Cnt >= NN;
|
|
|
|
LR.Start := PStart;
|
|
LR.LineHt := DHt;
|
|
LR.Ln := NN;
|
|
Tmp := Imgr.LeftIndent(Y);
|
|
if Justify = Left then
|
|
LR.LineIndent := Tmp
|
|
else if Justify = Centered then
|
|
LR.LineIndent := IntMax(Tmp, (Tmp + IMgr.RightSide(Y)-(FindTextWidth(Canvas, PStart, NN, True))) div 2)
|
|
else LR.LineIndent := (IMgr.RightSide(Y)-(FindTextWidth(Canvas, PStart, NN, True)))-1;
|
|
LR.SpaceBefore := LR.SpaceBefore + SB;
|
|
LR.SpaceAfter := SA;
|
|
Lines.Add(LR);
|
|
Inc(PStart, NN);
|
|
SectionHeight := SectionHeight +DHt + SA + LR.SpaceBefore;
|
|
Tmp := DHt +SA + SB;
|
|
Inc(Y, Tmp);
|
|
LR.LineImgHt := IntMax(Tmp, ImgHt);
|
|
for I := 0 to NxImages.Count-1 do
|
|
begin
|
|
IMgr.Update(Y, TFloatingObj(NxImages[I])); {update Image manager and Image}
|
|
{include images in Line height}
|
|
LR.LineImgHt := IntMax(LR.LineImgHt,
|
|
Tmp+TFloatingObj(NxImages[I]).ImageHeight + 2*TFloatingObj(NxImages[I]).VSpace);
|
|
end;
|
|
NxImages.Clear;
|
|
end;
|
|
|
|
begin
|
|
YValue := Y;
|
|
StartCurs := Curs;
|
|
PStart := Buff;
|
|
Last := Buff + Len - 1;
|
|
SectionHeight := 0;
|
|
Lines.Clear;
|
|
if Indent = SmallListIndent then
|
|
IMgr.SetLevelSmall(Y, Level) {special case, <li> without <ul>}
|
|
else IMgr.SetLevel(Y, Level);
|
|
if (Len = 0) then
|
|
begin
|
|
Result := GetClearSpace;
|
|
DrawHeight := Result;
|
|
SectionHeight := Result;
|
|
MaxWidth := 0;
|
|
Exit;
|
|
end;
|
|
Finished := False;
|
|
LevelIndent := Imgr.LeftIndent(Y);
|
|
MaxWidth := IMgr.Width;
|
|
Width := IMgr.RightSide(Y)-IMgr.LeftIndent(Y);
|
|
for I := 0 to Images.Count-1 do {call drawlogic for all the images}
|
|
begin
|
|
Obj := TFloatingObj(Images[I]);
|
|
with Obj do
|
|
begin
|
|
if Obj is TImageObj then
|
|
TImageObj(Obj).DrawLogic(Self.ParentSectionList, Canvas, Fonts.GetFontObjAt(Pos, Indx), Width);
|
|
MaxWidth := IntMax(MaxWidth, ImageWidth + Self.Indent); {HScrollBar for wide images}
|
|
end;
|
|
end;
|
|
for I := 0 to FormControls.Count-1 do
|
|
with TFormControlObj(FormControls[I]) do
|
|
if Assigned(FControl) then
|
|
MaxWidth := IntMax(MaxWidth, FControl.Width + Self.Indent);
|
|
NxImages := TList.Create;
|
|
while not Finished do
|
|
begin
|
|
Max := Last - PStart + 1;
|
|
if Max <= 0 then Break;
|
|
LR := LineRec.Create; {a new line}
|
|
if (Lines.Count = 0) then
|
|
begin {may need to move down past floating image}
|
|
Tmp := GetClearSpace;
|
|
if Tmp > 0 then
|
|
begin
|
|
LR.LineHt := Tmp;
|
|
Inc(SectionHeight, Tmp);
|
|
LR.Ln := 0;
|
|
LR.Start := PStart;
|
|
Inc(Y, Tmp);
|
|
Lines.Add(LR);
|
|
LR := LineRec.Create;
|
|
end;
|
|
end;
|
|
|
|
if Self is TPreformated then Width := 32000
|
|
else Width := IMgr.RightSide(Y)-IMgr.LeftIndent(Y);
|
|
N := IntMax(FindCountThatFits1(Canvas, Width, PStart, Max, Y, IMgr,
|
|
ImgHt, NxImages), 1); {N = at least 1}
|
|
if N = Max then
|
|
begin {Do the remainder}
|
|
LineComplete(N);
|
|
Finished := True;
|
|
end
|
|
else
|
|
begin
|
|
P := PStart + N -1;
|
|
if (P^ = ' ') then
|
|
begin {move past spaces so as not to print any on next line}
|
|
while (N < Max) and ((P+1)^ = ' ') do
|
|
begin
|
|
Inc(P);
|
|
Inc(N);
|
|
end;
|
|
LineComplete(N);
|
|
Finished := N >= Max;
|
|
end
|
|
else if (N < Max) and ((P+1)^ in [#2, #4]) then {an image or control}
|
|
begin
|
|
LineComplete(N);
|
|
Finished := False;
|
|
end
|
|
else
|
|
Begin {non space, wrap it by backing off to previous space or image}
|
|
while not (P^ in [' ', #2, #4]) and (P > PStart) do Dec(P);
|
|
if P = PStart then
|
|
begin {no space found, forget the wrap, write the whole word and any
|
|
spaces found after it}
|
|
P := PStart+N-1;
|
|
while (P <> Last) and not ((P+1)^ in [' ', #2, #4]) do
|
|
begin
|
|
Inc(P);
|
|
end;
|
|
while (P <> Last) and ((P+1)^ = ' ') do
|
|
begin
|
|
Inc(P);
|
|
end;
|
|
MaxWidth := IntMax(MaxWidth, FindTextWidth(Canvas, PStart, P-PStart+1, True));
|
|
LineComplete(P-PStart+1);
|
|
Finished := P = Last;
|
|
end
|
|
else
|
|
begin {found space}
|
|
LineComplete(P-PStart+1);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
NxImages.Free;
|
|
Curs := StartCurs + Len;
|
|
if Level > 0 then
|
|
{for lists, clear left floating images}
|
|
begin
|
|
Tmp := IMgr.GetLevelClear - YValue;
|
|
if Tmp > SectionHeight then SectionHeight := Tmp;
|
|
end;
|
|
DrawHeight := IMgr.ImageBottom - YValue; {in case image overhangs}
|
|
if DrawHeight < SectionHeight then
|
|
DrawHeight := SectionHeight;
|
|
Result := SectionHeight;
|
|
end;
|
|
|
|
{----------------TSection.Draw}
|
|
function TSection.Draw(Canvas: TCanvas; const ARect: TRect;
|
|
IMgr: IndentManager; X: integer; Y: integer) : integer;
|
|
var
|
|
I: integer;
|
|
MySelB, MySelE: integer;
|
|
DC: HDC;
|
|
Ctrl: TFormControlObj;
|
|
YOffset: integer;
|
|
|
|
procedure DrawTheText(LR: LineRec; Start : PChar; Cnt, Descent: integer);
|
|
var
|
|
I, J, J1, J2, J3, J4, XX, OHang, Index, Addon, TopP, Tmp : integer;
|
|
Obj: TFloatingObj;
|
|
FO: TFontObj;
|
|
ARect: TRect;
|
|
Inverted, ImageAtStart: boolean;
|
|
S: string;
|
|
|
|
function ChkInversion(C : integer; var Count: Integer) : boolean;
|
|
var
|
|
LongCount: integer;
|
|
begin
|
|
Result := False;
|
|
Count := 32000;
|
|
if MySelE < MySelB then Exit;
|
|
if (MySelB <= C) and (MySelE > C) then
|
|
begin
|
|
Result := True;
|
|
LongCount := MySelE - C;
|
|
end
|
|
else if MySelB > C then LongCount := MySelB - C
|
|
else if (MySelB = C) and ParentSectionList.ShowDummyCaret then
|
|
LongCount := 1
|
|
else LongCount := 32000;
|
|
if LongCount > 32000 then Count := 32000
|
|
else Count := LongCount;
|
|
end;
|
|
|
|
begin {Y is at bottom of line here}
|
|
writeln('DrawTheText A Cnt=',Cnt);
|
|
ImageAtStart := True;
|
|
XX := X + LR.LineIndent;
|
|
LR.DrawY := Y-LR.LineHt;
|
|
LR.DrawX := XX;
|
|
while Cnt > 0 do
|
|
begin
|
|
I := 1;
|
|
J1 := Fonts.GetFontCountAt(Start-Buff, Len)-1;
|
|
J2 := Images.GetImageCountAt(Start-Buff)-1;
|
|
J4 := TFormControlList(FormControls).GetControlCountAt(Start-Buff)-1;
|
|
FO := Fonts.GetFontObjAt(Start-Buff, Index);
|
|
Canvas.Font := FO.TheFont;
|
|
OHang := FO.OverHang;
|
|
if J2 = -1 then
|
|
begin {it's an image}
|
|
Obj := Images.FindImage(Start-Buff);
|
|
FO := Fonts.GetFontObjAt(Start-Buff, Index);
|
|
if Obj is TImageObj then
|
|
begin
|
|
if Obj.ObjAlign in [ALeft, ARight] then
|
|
begin
|
|
if ImageAtStart then
|
|
begin
|
|
TImageObj(Obj).Draw(Canvas, IMgr.LfEdge+Obj.Indent,
|
|
Y-LR.LineHt-LR.SpaceBefore, Y-Descent, FO);
|
|
end
|
|
else
|
|
begin {if not at start, draw on next line}
|
|
TImageObj(Obj).Draw(Canvas, IMgr.LfEdge+Obj.Indent, Y, Y-Descent, FO);
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
TImageObj(Obj).Draw(Canvas, XX+Obj.HSpace, Y-LR.LineHt, Y-Descent, FO);
|
|
XX := XX + Obj.ImageWidth + 2*Obj.HSpace;
|
|
ImageAtStart := False;
|
|
end;
|
|
end;
|
|
end
|
|
else if J4 = -1 then
|
|
begin {it's a form control}
|
|
Ctrl := TFormControlList(FormControls).FindControl(Start-Buff);
|
|
if Assigned(Ctrl.FControl) then
|
|
with Ctrl, FControl do
|
|
begin
|
|
ShowIt := True;
|
|
if BaseLine then
|
|
TopP := Y - Height - Descent -YOffset {sits on baseline}
|
|
else TopP := Y-Height-YOffset;
|
|
Show;
|
|
Left := XX;
|
|
Top := TopP;
|
|
if Ctrl is TRadioButtonFormControlObj then
|
|
with TRadioButtonFormControlObj(Ctrl) do
|
|
begin
|
|
TRadioButtonFormControlObj(Ctrl).RButton.Show;
|
|
if MyCell.BkGnd then
|
|
(FControl as TPanel).Color := MyCell.BkColor
|
|
else (FControl as TPanel).Color := ParentSectionList.Background;
|
|
TRadioButtonFormControlObj(Ctrl).RButton.Repaint;
|
|
end;
|
|
Inc(XX, Width);
|
|
end;
|
|
ImageAtStart := False;
|
|
end
|
|
else
|
|
begin
|
|
writeln('DrawTheText B ');
|
|
J := IntMin(J1, J2);
|
|
J := IntMin(J, J4);
|
|
Inverted := ChkInversion(Start-Buff, J3);
|
|
J := IntMin(J, J3-1);
|
|
I := IntMin(Cnt, J+1);
|
|
if Inverted then
|
|
begin
|
|
SetBkMode(Canvas.Handle, Opaque);
|
|
Canvas.Brush.Color := Canvas.Font.Color;
|
|
Canvas.Font.Color := ParentSectionList.Background;
|
|
end
|
|
else
|
|
SetBkMode(Canvas.Handle, Transparent);
|
|
|
|
SetTextAlign(Canvas.Handle, TA_BaseLine); {control and image upsets this}
|
|
SetLength(S, I);
|
|
Move(Start^, S[1], I);
|
|
J := Pos(#160, S);
|
|
while J > 0 do {substitute spaces for #160}
|
|
begin
|
|
S[J] := ' ';
|
|
J := Pos(#160, S);
|
|
end;
|
|
writeln('DrawTheText C ',Self is TPreformated);
|
|
if Self is TPreformated then
|
|
begin {so will clip in Table cells}
|
|
ARect := Rect(X, Y-LR.LineHt-LR.SpaceBefore-YOffset, X+IMgr.ClipWidth, Y-YOffset+1);
|
|
ExtTextOut(Canvas.Handle, XX-OHang div 2, Y - Descent -YOffset, ETO_CLIPPED,
|
|
@ARect, PChar(S), I, Nil);
|
|
Addon := 0;
|
|
end
|
|
else
|
|
begin
|
|
with FO do
|
|
if SScript = Normal then Addon := 0
|
|
else if SScript = SupSc then Addon := -(FontHeight div 3)
|
|
else Addon := Descent div 2 +1;
|
|
writeln('DrawTheText D ',S,' ',HexStr(Cardinal(Canvas.Font.Color),8));
|
|
Canvas.Brush.Color:=clRed;
|
|
Canvas.FillRect(Rect(0,0,200,200));
|
|
TextOut(Canvas.Handle, XX-OHang div 2, Y - Descent + Addon - YOffset, PChar(S), I);
|
|
end;
|
|
{Put in a dummy caret to show character position}
|
|
if ParentSectionList.ShowDummyCaret and not Inverted
|
|
and (MySelB = Start-Buff) then
|
|
begin
|
|
Canvas.Pen.Color := Canvas.Font.Color;
|
|
Tmp := Y - Descent+ FO.Descent + Addon - YOffset;
|
|
Canvas.Rectangle(XX-Ohang, Tmp, XX-Ohang+1, Tmp-FO.FontHeight);
|
|
end;
|
|
XX := XX + GetXExtent(Canvas.Handle, Start, I)-OHang;
|
|
ImageAtStart := False;
|
|
end;
|
|
Dec(Cnt, I);
|
|
Inc(Start, I);
|
|
end;
|
|
end;
|
|
|
|
procedure DoDraw(I: integer);
|
|
const
|
|
MaxRoman = 20;
|
|
LowRoman: array[1..MaxRoman] of string[5] = ('i', 'ii', 'iii', 'iv', 'v', 'vi',
|
|
'vii', 'viii', 'ix', 'x', 'xi', 'xii', 'xiii', 'xiv', 'xv', 'xvi', 'xvii',
|
|
'xviii', 'xix', 'xx');
|
|
HighRoman: array[1..MaxRoman] of string[5] = ('I', 'II', 'III', 'IV', 'V', 'VI',
|
|
'VII', 'VIII', 'IX', 'X', 'XI', 'XII', 'XIII', 'XIV', 'XV', 'XVI', 'XVII',
|
|
'XVIII', 'XIX', 'XX');
|
|
var
|
|
NStr : string[7];
|
|
BkGnd, BkGnd1: TColor;
|
|
XS, AlphaNumb: integer;
|
|
|
|
procedure Circle(X, Y: integer);
|
|
var
|
|
Rad: integer;
|
|
begin
|
|
Rad := 5 div 2;
|
|
Canvas.Ellipse(X-Rad, Y-Rad, X+Rad+1, Y+Rad+1);
|
|
end;
|
|
|
|
begin
|
|
with LineRec(Lines[I]) do
|
|
begin
|
|
Inc(Y, LineHt+SpaceBefore);
|
|
XS := LevelIndent + X;
|
|
writeln('DoDraw ',I,' ',ListType <> None);
|
|
if (I = 0) and (ListType <> None) then
|
|
if ListType = Definition then {definition list, do nothing}
|
|
else if ListType = Ordered then {ordered list}
|
|
begin
|
|
AlphaNumb := IntMin(ListNumb-1, 25);
|
|
case TOListItem(Self).IndexType of
|
|
'a': NStr := chr(ord('a')+AlphaNumb);
|
|
'A': NStr := chr(ord('A')+AlphaNumb);
|
|
'i': NStr := LowRoman[IntMin(ListNumb, MaxRoman)];
|
|
'I': NStr := HighRoman[IntMin(ListNumb, MaxRoman)];
|
|
else NStr := IntToStr(ListNumb);
|
|
end;
|
|
Canvas.Font := DefFont; {Fonts[0] may have been changed}
|
|
NStr := NStr+'.';
|
|
SetBkMode(DC, Transparent);
|
|
Canvas.TextOut(XS-5-Canvas.TextWidth(NStr), Y-Descent-YOffset, NStr);
|
|
end
|
|
else if (ListType = Unordered) and not TUListItem(Self).Plain then
|
|
with Canvas do
|
|
begin
|
|
BkGnd := ParentSectionList.Background;
|
|
BkGnd1 := BkGnd and $FFFFFF;
|
|
if (BkGnd = clBtnFace) or (BkGnd1 = clWhite)
|
|
or (BkGnd1 = clSilver) or
|
|
((BkGnd = clWindow) and (GetSysColor(Color_Window) = $FFFFFF))then
|
|
case Level of
|
|
0,3: begin Brush.Color := clRed; Pen.Color := clRed; end;
|
|
1,4: begin Brush.Color := clNavy; Pen.Color := clNavy; end;
|
|
2,5: begin Brush.Color := clMaroon; Pen.Color := clMaroon; end;
|
|
end
|
|
else
|
|
begin
|
|
Pen.Color := ParentSectionList.FontColor;
|
|
Brush.Style := bsClear;
|
|
end;
|
|
Circle(XS-8, Y-(LineHt div 2) - YOffset);
|
|
Brush.Color := BkGnd;
|
|
Brush.Style := bsSolid;
|
|
Pen.Color := ParentSectionList.FontColor;
|
|
end;
|
|
DrawTheText(LineRec(Lines[I]), Start, Ln, Descent);
|
|
Inc(Y, SpaceAfter);
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
Result := Y + SectionHeight;
|
|
YOffset := ParentSectionList.YOff;
|
|
|
|
writeln('TSection.Draw A ',HexStr(Cardinal(Self),8),' Lines.Count=',Lines.Count,
|
|
' Len=',Len,' Y=',Y,' YOffset=',YOffset,
|
|
' DrawHeight=',DrawHeight,' ARect.Top=',ARect.Top,' ARect.Bottom=',ARect.Bottom);
|
|
if (Len > 0) and (Y-YOffset+DrawHeight >= ARect.Top) and (Y-YOffset < ARect.Bottom) then
|
|
begin
|
|
DC := Canvas.Handle;
|
|
SetTextAlign(DC, TA_BaseLine);
|
|
|
|
MySelB := ParentSectionList.SelB-StartCurs;
|
|
MySelE := ParentSectionList.SelE-StartCurs;
|
|
writeln('TSection.Draw Lines.Count=',Lines.Count);
|
|
Canvas.Brush.Color:=clMaroon;
|
|
Canvas.FillRect(Rect(0,0,200,200));
|
|
for I := 0 to Lines.Count-1 do
|
|
with LineRec(Lines[I]) do
|
|
begin
|
|
writeln('TSection.Draw ',I,' ',Y-YOffset+LineImgHt,' >= ',ARect.Top,
|
|
' and ',Y-YOffset,' < ',ARect.Bottom);
|
|
if (Y-YOffset+LineImgHt >= ARect.Top) and (Y-YOffset < ARect.Bottom) then
|
|
DoDraw(I)
|
|
else {do not completely draw extremely long paragraphs}
|
|
Inc(Y, SpaceBefore + LineHt + SpaceAfter);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{----------------TSection.CopyToClipboard}
|
|
procedure TSection.CopyToClipboard;
|
|
var
|
|
I, J, Strt, X1, X2: integer;
|
|
MySelB, MySelE: integer;
|
|
begin
|
|
MySelB := ParentSectionList.SelB - StartCurs;
|
|
MySelE := ParentSectionList.SelE - StartCurs;
|
|
for I := 0 to Lines.Count-1 do
|
|
with LineRec(Lines.Items[I]) do
|
|
begin
|
|
Strt := Start-Buff;
|
|
if (MySelE <= Strt) or (MySelB > Strt + Ln) then Continue;
|
|
if MySelB-Strt > 0 then X1 := MySelB-Strt
|
|
else X1 := 0;
|
|
if MySelE-Strt < Ln then X2 := MySelE - Strt
|
|
else X2 := Ln;
|
|
if X1 = 0 then {output any line indent}
|
|
for J := 0 to LineIndent div ListIndent -1 do
|
|
ParentSectionList.CB.AddText(' ', 3);
|
|
ParentSectionList.CB.AddText(Start+X1, X2-X1);
|
|
if X2 = Ln then ParentSectionList.CB.AddTextCR('', 0);
|
|
end;
|
|
end;
|
|
|
|
{----------------TSection.PtInObject}
|
|
function TSection.PtInObject(X : integer; Y: integer; var Obj: TObject;
|
|
var IX, IY: integer): boolean;
|
|
{Y is distance from start of section}
|
|
begin
|
|
Result := (Images.Count > 0) and Images.PtInObject(X, YValue+Y, Obj, IX, IY);
|
|
end;
|
|
|
|
{----------------TSection.GetURL}
|
|
function TSection.GetURL(Canvas: TCanvas; X: integer; Y: integer;
|
|
var UrlTarg: TUrlTarget; var FormControl: TImageFormControlObj): boolean;
|
|
{Y is distance from start of section}
|
|
var
|
|
I, H, L, Index, Width, TotalHt, IX, IY, Posn: integer;
|
|
FO : TFontObj;
|
|
LR: LineRec;
|
|
IMap, UMap: boolean;
|
|
MapItem: TMapItem;
|
|
ImageObj: TImageObj;
|
|
|
|
function MakeCopy(UrlTarget: TUrlTarget): TUrlTarget;
|
|
begin
|
|
Result := TUrlTarget.Create;
|
|
Result.Assign(UrlTarget.Url, UrlTarget.Target);
|
|
end;
|
|
|
|
begin
|
|
Result := False;
|
|
{First, check to see if in an image}
|
|
if (Images.Count > 0) and
|
|
Images.PtInImage(X, YValue+Y, IX, IY, Posn, IMap, UMap, MapItem, ImageObj) then
|
|
begin
|
|
ParentSectionList.ActiveImage := ImageObj;
|
|
if Assigned(ImageObj.MyFormControl) then
|
|
begin
|
|
FormControl := ImageObj.MyFormControl;
|
|
Result := True;
|
|
FormControl.XTmp := IX;
|
|
FormControl.YTmp := IY;
|
|
end
|
|
else if UMap then
|
|
begin
|
|
if MapItem.GetURL(IX, IY, UrlTarg) then
|
|
Result := True;
|
|
end
|
|
else
|
|
begin
|
|
FO := Fonts.GetFontObjAt(Posn, Index);
|
|
if FO.UrlTarget.Url <> '' then
|
|
begin {found an URL}
|
|
Result := True;
|
|
UrlTarg := MakeCopy(FO.UrlTarget);
|
|
ParentSectionList.ActiveLink := FO;
|
|
if IMap then
|
|
UrlTarg.Url := UrlTarg.Url + '?'+IntToStr(IX)+','+IntToStr(IY);
|
|
end;
|
|
end;
|
|
Exit;
|
|
end;
|
|
|
|
I := 0; H := 0;
|
|
LR := Nil;
|
|
with Lines do
|
|
begin
|
|
while I < Count do
|
|
begin
|
|
LR := LineRec(Lines[I]);
|
|
with LR do
|
|
TotalHt := LineHt+SpaceBefore+SpaceAfter;
|
|
if H+TotalHt > Y then Break;
|
|
Inc(H, TotalHt);
|
|
Inc(I);
|
|
end;
|
|
if I >= Count then Exit;
|
|
end;
|
|
with LR do
|
|
begin
|
|
if X < DrawX then Exit; {LR has been initialized}
|
|
Width := X - DrawX;
|
|
L := FindCountThatFits(Canvas, Width, Start, Ln);
|
|
if L >= Ln then Exit;
|
|
FO := Fonts.GetFontObjAt(L+(Start-Buff), Index);
|
|
if FO.UrlTarget.Url <> '' then
|
|
begin {found an URL}
|
|
if not ((Start+L)^ in [#4, #7]) then {an image here would be in HSpace area}
|
|
Result := True
|
|
else Exit;
|
|
UrlTarg := MakeCopy(FO.UrlTarget);
|
|
ParentSectionList.ActiveLink := FO;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{----------------TSection.FindCursor}
|
|
function TSection.FindCursor(Canvas: TCanvas; X: integer; Y: integer;
|
|
var XR: integer; var YR: integer; var CaretHt: integer;
|
|
var SCell: TObject; var Intext: boolean): integer;
|
|
{Given an X, Y, find the character position and the resulting XR, YR position
|
|
for a caret along with its height, CaretHt. Coordinates are relative to this
|
|
section}
|
|
var
|
|
I, H, L, Width, TotalHt, L1, W, Delta: integer;
|
|
LR: LineRec;
|
|
begin
|
|
Result := -1;
|
|
I := 0; H := 0; L1 := 0;
|
|
LR := Nil;
|
|
with Lines do
|
|
begin
|
|
while I < Count do
|
|
begin
|
|
LR := LineRec(Lines[I]);
|
|
with LR do
|
|
TotalHt := LineHt+SpaceBefore+SpaceAfter;
|
|
if H+TotalHt > Y then Break;
|
|
Inc(H, TotalHt);
|
|
Inc(I);
|
|
Inc(L1, LR.Ln); {L1 accumulates char count of previous lines}
|
|
end;
|
|
if I >= Count then Exit;
|
|
end;
|
|
with LR do
|
|
begin
|
|
InText := True;
|
|
CaretHt := LineHt; {LR has been initialized}
|
|
YR := H + SpaceBefore;
|
|
if X < DrawX then
|
|
begin
|
|
Result := L1+StartCurs;
|
|
InText := False;
|
|
Exit;
|
|
end;
|
|
Width := X-DrawX;
|
|
L := FindCountThatFits(Canvas, Width, Start, Ln);
|
|
W := FindTextWidth(Canvas, Start, L, False);
|
|
XR := DrawX + W;
|
|
if L < Ln then
|
|
begin {check to see if passed 1/2 character mark}
|
|
Delta := FindTextWidth(Canvas, Start+L, 1, False);
|
|
if Width > W+(Delta div 2) then
|
|
begin
|
|
Inc(L);
|
|
Inc(XR, Delta);
|
|
end;
|
|
end
|
|
else InText := False;
|
|
Result := L+L1+StartCurs;
|
|
end;
|
|
end;
|
|
|
|
{----------------TSection.FindString}
|
|
function TSection.FindString(From: integer; PC: PChar; MatchCase: boolean): integer;
|
|
var
|
|
P: PChar;
|
|
I: integer;
|
|
LenPC: word;
|
|
UCh, LCh: Char;
|
|
S1, S2: string[255];
|
|
|
|
function ScanCaseless(P: PChar; LCh, UCh: Char): PChar;
|
|
{Ch is lower case here}
|
|
var
|
|
PU, PL: PChar;
|
|
begin
|
|
PU := StrScan(P, UCh);
|
|
PL := StrScan(P, LCh);
|
|
if not Assigned(PU) then Result := PL
|
|
else if not Assigned(PL) then Result := PU
|
|
else if (PU <= PL) then Result := PU
|
|
else Result := PL;
|
|
end;
|
|
|
|
begin
|
|
Result := -1;
|
|
if (Len = 0) or (From >= StartCurs + Len) then Exit;
|
|
if From < StartCurs then I := 0
|
|
else I := From-StartCurs;
|
|
|
|
if MatchCase then
|
|
begin {case sensitive search}
|
|
P := StrPos(Buff + I, PC);
|
|
if Assigned(P) then
|
|
Result := StartCurs+(P-Buff);
|
|
end
|
|
else
|
|
begin {Caseless search}
|
|
UCh := PC^;
|
|
LCh := AnsiLowerCase(UCh)[1]; {make lower case}
|
|
UCh := AnsiUpperCase(LCh)[1]; {make upper case}
|
|
LenPC := IntMin(StrLen(PC), 255);
|
|
P := ScanCaseless(Buff + I, LCh, UCh);
|
|
S1 := StrPas(PC);
|
|
S2[0] := chr(LenPC);
|
|
while Assigned(P) and (StrLen(P) >= LenPC) do
|
|
begin
|
|
System.Move(P^, S2[1], LenPC);
|
|
if AnsiCompareText(S1, S2) = 0 then
|
|
begin
|
|
Result := StartCurs + (P-Buff);
|
|
Exit;
|
|
end;
|
|
Inc(P);
|
|
P := ScanCaseless(P, LCh, UCh);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{----------------TSection.FindSourcePos}
|
|
function TSection.FindSourcePos(DocPos: integer): integer;
|
|
var
|
|
I: integer;
|
|
IO: IndexObj;
|
|
begin
|
|
Result := -1;
|
|
if (Len = 0) or (DocPos >= StartCurs + Len) then Exit;
|
|
|
|
for I := SIndexList.Count-1 downto 0 do
|
|
begin
|
|
IO := PosIndex[I];
|
|
if IO.Pos <= DocPos-StartCurs then
|
|
begin
|
|
Result := IO.Index + DocPos-StartCurs - IO.Pos;
|
|
break;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{----------------TSection.FindDocPos}
|
|
function TSection.FindDocPos(SourcePos: integer; Prev: boolean): integer;
|
|
{for a given Source position, find the nearest document position either Next or
|
|
previous}
|
|
var
|
|
I: integer;
|
|
IO, IOPrev: IndexObj;
|
|
begin
|
|
Result := -1;
|
|
if Len = 0 then Exit;
|
|
|
|
if not Prev then
|
|
begin
|
|
I:= SIndexList.Count-1;
|
|
IO := PosIndex[I];
|
|
if SourcePos > IO.Index + (Len-1) - IO.Pos then Exit; {beyond this section}
|
|
|
|
IOPrev := PosIndex[0];
|
|
if SourcePos <= IOPrev.Index then
|
|
begin //in this section but before the start of Document text
|
|
Result := StartCurs;
|
|
Exit;
|
|
end;
|
|
|
|
for I := 1 to SIndexList.Count-1 do
|
|
begin
|
|
IO := PosIndex[I];
|
|
if (SourcePos >= IOPrev.Index) and (SourcePos < IO.Index) then
|
|
begin //between IOprev and IO
|
|
if SourcePos-IOPrev.Index+IOPrev.Pos < IO.Pos then
|
|
Result := StartCurs+IOPrev.Pos+(SourcePos-IOPrev.Index)
|
|
else Result := StartCurs+IO.Pos;
|
|
Exit;
|
|
end;
|
|
IOPrev := IO;
|
|
end;
|
|
//after the last IndexObj in list
|
|
Result := StartCurs+IOPrev.Pos+(SourcePos-IOPrev.Index);
|
|
end
|
|
else //prev -- we're iterating from the end of TSectionList
|
|
begin
|
|
IOPrev := PosIndex[0];
|
|
if SourcePos < IOPrev.Index then Exit; //before this section
|
|
|
|
I:= SIndexList.Count-1;
|
|
IO := PosIndex[I];
|
|
if SourcePos > IO.Index + (Len-1) - IO.Pos then
|
|
begin //SourcePos is after the end of this section
|
|
Result := StartCurs + (Len-1);
|
|
Exit;
|
|
end;
|
|
|
|
for I := 1 to SIndexList.Count-1 do
|
|
begin
|
|
IO := PosIndex[I];
|
|
if (SourcePos >= IOPrev.Index) and (SourcePos < IO.Index) then
|
|
begin //between IOprev and IO
|
|
if SourcePos-IOPrev.Index+IOPrev.Pos < IO.Pos then
|
|
Result := StartCurs+IOPrev.Pos+(SourcePos-IOPrev.Index)
|
|
else Result := StartCurs+IO.Pos-1;
|
|
Exit;
|
|
end;
|
|
IOPrev := IO;
|
|
end;
|
|
//after the last IndexObj in list
|
|
Result := StartCurs+IOPrev.Pos+(SourcePos-IOPrev.Index);
|
|
end;
|
|
end;
|
|
|
|
{----------------TSection.CursorToXY}
|
|
function TSection.CursorToXY(Canvas: TCanvas; Cursor: integer; var X: integer;
|
|
var Y: integer): boolean;
|
|
var
|
|
I, Curs: integer;
|
|
LR: LineRec;
|
|
begin
|
|
Result := False;
|
|
if (Len = 0) or (Cursor > StartCurs + Len) then Exit;
|
|
|
|
I := 0;
|
|
LR := Nil;
|
|
Curs := Cursor - StartCurs;
|
|
Y := YValue;
|
|
with Lines do
|
|
begin
|
|
while I < Count do
|
|
begin
|
|
LR := LineRec(Lines[I]);
|
|
with LR do
|
|
begin
|
|
if Curs < Ln then Break;
|
|
Inc(Y, LineHt+SpaceBefore+SpaceAfter);
|
|
Dec(Curs, Ln);
|
|
end;
|
|
Inc(I);
|
|
end;
|
|
if I >= Count then Exit;
|
|
end;
|
|
X := LR.DrawX + FindTextWidth(Canvas, LR.Start, Curs, False);
|
|
Result := True;
|
|
end;
|
|
|
|
{----------------TSection.GetChAtPos}
|
|
function TSection.GetChAtPos(Pos: integer; var Ch: char; var Obj: TObject): boolean;
|
|
begin
|
|
Result := False;
|
|
if (Len = 0) or (Pos < StartCurs) or (Pos >= StartCurs + Len) then Exit;
|
|
Ch := Buff[Pos-StartCurs];
|
|
Obj := Self;
|
|
Result := True;
|
|
end;
|
|
|
|
procedure TSection.UpdateFonts;
|
|
begin
|
|
Fonts.UpdateFonts;
|
|
DefFont.UpdateFont(ParentSectionList, ParentSectionList.FontColor);
|
|
inherited UpdateFonts;
|
|
end;
|
|
|
|
{$IFDEF HL_LAZARUS}
|
|
initialization
|
|
ListIndent:=35;
|
|
{$ENDIF}
|
|
|
|
end.
|
|
|
|
|
|
|