{Version 9.45}
{*********************************************************}
{* HTMLSUBS.PAS *}
{*********************************************************}
{
Copyright (c) 1995-2008 by L. David Baldwin
Permission is hereby granted, free of charge, to any person obtaining a copy of
this software and associated documentation files (the "Software"), to deal in
the Software without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies
of the Software, and to permit persons to whom the Software is furnished to do
so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
Note that the source modules, HTMLGIF1.PAS, PNGZLIB1.PAS, DITHERUNIT.PAS, and
URLCON.PAS are covered by separate copyright notices located in those modules.
}
{$i htmlcons.inc}
{
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 Htmlsubs;
{$IFNDEF LCL}
{$R HTML32.Res}
{$ENDIF}
interface
uses
SysUtils, Classes,
{$IFNDEF LCL}
WinTypes, Windows, WinProcs, Messages, mmSystem,
{$ELSE}
LclIntf, LMessages, Types, LclType, HtmlMisc,
{$ENDIF}
Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls,
HTMLUn2, HTMLGif2,
{$ifdef UseTNT}
TntStdCtrls,
{$endif}
{$ifdef UseElPack}
ElListBox, ElCombos, ElEdits, ElPopBtn,
{$endif}
StyleUn;
type
{$ifdef UseTNT}
ThtEdit = TTntEdit;
ThtButton = TTntButton;
ThtMemo = TTntMemo;
ThtCombobox = TTntCombobox;
ThtListbox = TTntListbox;
{$else}
{$ifdef UseElPack}
ThtEdit = TElEdit;
ThtButton = TElPopupButton;
ThtMemo = TElMemo;
ThtCombobox = TElCombobox;
ThtListbox = TElListbox;
{$else}
ThtEdit = TEdit;
ThtButton = TButton;
ThtMemo = TMemo;
ThtCombobox = TCombobox;
ThtListbox = TListbox;
{$endif}
{$endif}
ThvPanel = Class(TPanel)
public
FVisible: boolean;
procedure SetVisible(Value: boolean);
property Visible: boolean read FVisible write SetVisible default True;
end;
TLinkDrawnEvent = procedure(Sender: TObject; Page: integer; const Url, Target: string;
ARect: TRect) of Object;
TFileBrowseEvent = procedure(Sender, Obj: TObject; var S: string) of Object;
TGetBitmapEvent = procedure(Sender: TObject; const SRC: string;
var Bitmap: TBitmap; var Color: TColor) of Object;
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;
TPanelCreateEvent = procedure(Sender: TObject; const AName, AType, SRC: string;
Panel: ThvPanel) of Object;
TPanelDestroyEvent = procedure(Sender: TObject; Panel: ThvPanel) of Object;
TPanelPrintEvent = procedure(Sender: TObject; Panel: ThvPanel; const Bitmap: TBitmap) of Object;
TObjectTagEvent = procedure(Sender: TObject; Panel: ThvPanel;
const Attributes, Params: TStringList;
var WantPanel: boolean) of Object;
TObjectClickEvent = procedure(Sender, Obj: TObject; const OnClick: string) of Object;
ThtObjectEvent = procedure(Sender, Obj: TObject; const Attribute: string) of Object;
TExpandNameEvent = procedure(Sender: TObject; const SRC: string; var Result: string) of Object;
guResultType = set of (guUrl, guControl, guTitle);
TCell = Class;
TBlockCell = Class;
TCellBasic = Class;
TSectionList = Class;
TSection = Class;
TBlock = Class;
{$IFNDEF LCL}
ThtTabcontrol = class(TWinControl)
{$ELSE}
ThtTabcontrol = class(TCustomControl)
{$ENDIF}
private
procedure WMGetDlgCode(var Message: TMessage); message WM_GETDLGCODE;
protected
property OnEnter;
property OnExit;
property TabStop;
property OnKeyUp;
public
destructor Destroy; override;
end;
TFontObj = class(TObject) {font information}
private
Section: TSection;
FVisited, FHover: boolean;
Title: string;
FYValue: integer;
Active: boolean;
procedure SetVisited(Value: boolean);
procedure SetHover(Value: boolean);
function GetURL: string;
procedure SetAllHovers(List: TList; Value: boolean);
procedure CreateFIArray;
{$ifndef NoTabLink}
procedure EnterEvent(Sender: TObject);
procedure ExitEvent(Sender: TObject);
procedure CreateTabControl(TabIndex: integer);
procedure AKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure AssignY(Y: integer);
{$endif}
public
Pos : integer; {0..Len Index where font takes effect}
TheFont : TMyFont;
FIArray: TFontInfoArray;
FontHeight, {tmHeight+tmExternalLeading}
tmHeight, tmMaxCharWidth,
Overhang, Descent : integer;
SScript: AlignmentType;
UrlTarget: TUrlTarget;
TabControl: ThtTabControl;
constructor Create(ASection: TSection; F: TMyFont; Position: integer);
constructor CreateCopy(ASection: TSection; T: TFontObj);
destructor Destroy; override;
procedure ReplaceFont(F: TMyFont);
procedure ConvertFont(FI: ThtFontInfo);
procedure FontChanged;
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;
property YValue: integer read FYValue;
end;
TFontList = class(TFreeList) {a list of TFontObj's}
Public
constructor CreateCopy(ASection: TSection; T: TFontList);
function GetFontAt(Posn : integer; var OHang : integer) : TMyFont;
function GetFontCountAt(Posn, Leng : integer) : integer;
function GetFontObjAt(Posn : integer;
var Index : integer) : TFontObj;
procedure Decrement(N: integer; ParentSectionList: TSectionList);
end;
TImageFormControlObj = class;
TFloatingObj = class(TIDObject)
protected
Pos : integer; {0..Len index of image position}
ImageHeight, {does not include VSpace}
ImageWidth: integer;
ObjAlign: AlignmentType;
Indent: integer;
HSpaceL, HSpaceR, VSpaceT, VSpaceB: integer; {horizontal, vertical extra space}
SpecWidth: integer; {as specified by tag}
SpecHeight: integer; {as specified by
tag}
PercentWidth: boolean; {if width is percent}
PercentHeight: boolean; {if height is percent}
ImageTitle: string;
FAlt: string; {the alt= attribute}
FAltW: WideString;
function GetYPosition: integer; override;
public
ImageKnown: boolean; {know size of image}
DrawYY: integer;
DrawXX: integer;
NoBorder: boolean; {set if don't want blue border}
BorderSize: integer;
constructor CreateCopy(T: TFloatingObj);
procedure DrawLogic(SectionList: TSectionList; Canvas: TCanvas;
FO: TFontObj; AvailableWidth, AvailableHeight: integer); virtual; abstract;
procedure ProcessProperties(Prop: TProperties);
property Alt: string read FAlt;
end;
TPanelObj = class(TFloatingObj)
private
fMasterList:TSectionList;
SetWidth, SetHeight: integer;
IsCopy: boolean;
public
ShowIt: boolean;
Panel, OPanel: ThvPanel;
OSender: TObject;
PanelPrintEvent: TPanelPrintEvent;
FUserData: TObject;
FMyPanelObj: TPanelObj;
constructor Create(AMasterList: TSectionList; Position: integer;
L: TAttributeList; ACell: TCellBasic; ObjectTag: boolean);
constructor CreateCopy(AMasterList: TSectionList; T: TPanelObj);
destructor Destroy; override;
procedure DrawLogic(SectionList: TSectionList; Canvas: TCanvas;
FO: TFontObj; AvailableWidth, AvailableHeight: integer); override;
procedure Draw(ACanvas: TCanvas; X1, Y1: integer);
end;
HoverType = (hvOff, hvOverUp, hvOverDown);
TImageObj = class(TFloatingObj) {inline image info}
private
FBitmap: TBitmap;
FHover: HoverType;
FHoverImage: boolean;
AltHeight, AltWidth: integer;
Positioning: PositionType;
function GetBitmap: TBitmap;
procedure SetHover(Value: HoverType);
public
ObjHeight, ObjWidth: integer; {width as drawn}
Source: String; {the src= attribute}
Image: TgpObject; {bitmap possibly converted from GIF, Jpeg, etc or animated GIF}
OrigImage: TgpObject; {same as above unless swapped}
Mask: TBitmap; {Image's mask if needed for transparency}
ParentSectionList: TSectionList;
Transparent: Transparency; {None, Lower Left Corner, or Transp GIF}
IsMap, UseMap: boolean;
MapName: String;
MyFormControl: TImageFormControlObj; {if an ,
, font for document}
LinkVisitedColor, LinkActiveColor,
HotSpotColor: TColor;
PrintTableBackground: boolean;
PrintBackground: boolean;
PrintMonoBlack: boolean;
TheOwner: TWinControl; {the viewer that owns this document}
PPanel: TWinControl; {the viewer's PaintPanel}
GetBitmap: TGetBitmapEvent; {for OnBitmapRequest Event}
GetImage: TGetImageEvent; {for OnImageRequest Event}
ExpandName: TExpandNameEvent;
ObjectClick: TObjectClickEvent;
ObjectFocus: ThtObjectEvent;
ObjectBlur: ThtObjectEvent;
ObjectChange: ThtObjectEvent;
FileBrowse: TFileBrowseEvent;
BackGround: TColor;
OnBackgroundChange: TNotifyEvent;
BackgroundBitmap: TGpObject; //TBitmap;
BackgroundMask: TBitmap;
BackgroundAniGif: TGifImage;
BackgroundPRec: PtPositionRec;
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;
PanelCreateEvent: TPanelCreateEvent;
PanelDestroyEvent: TPanelDestroyEvent;
PanelPrintEvent: TPanelPrintEvent;
CB: SelTextCount;
PageBottom: integer;
PageShortened: boolean;
MapList: TFreeList; {holds list of client maps, TMapItems}
Timer: TTimer; {for animated GIFs}
FormControlList: TList; {List of all TFormControlObj's in this SectionList}
PanelList: TList; {List of all TPanelObj'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;
Styles: TStyleList; {the stylesheet}
DrawList: TDrawList;
FirstLineHtPtr: PInteger;
IDNameList: TIDNameList;
PositionList: TList;
BitmapList: TStringBitmapList;
SectionCount: integer;
CycleNumber: integer;
ProgressStart: integer;
IsCopy: boolean; {set when printing or making bitmap/metafile}
NoOutput: boolean;
TabOrderList: TStringList;
FirstPageItem: boolean;
StopTab: boolean;
InlineList: TFreeList; {actually TInlineList, a list of InlineRec's}
TableNestLevel: integer;
InLogic2: boolean;
LinkDrawnEvent: TLinkDrawnEvent;
LinkPage: integer;
PrintingTable: ThtmlTable;
ScaleX, ScaleY: single;
SkipDraw: boolean;
constructor Create(Owner, APaintPanel: TWinControl);
constructor CreateCopy(T: TSectionList);
procedure Clear;
procedure ClearLists;
destructor Destroy; override;
procedure CheckGIFList(Sender: TObject);
procedure HideControls;
procedure SetYOffset(Y: integer);
function GetSelLength: integer;
procedure CopyToClipboardA(Leng: integer);
function GetSelTextBuf(Buffer: PWideChar; BufSize: integer): integer;
procedure SetFonts(const Name, PreName: string; ASize: integer;
AColor, AHotSpot, AVisitedColor, AActiveColor, ABackground: TColor;
LnksActive: boolean; LinkUnderLine: boolean; ACharSet: TFontCharSet;
MarginHeight, MarginWidth: integer);
procedure SetBackground(ABackground: TColor);
procedure SetBackgroundBitmap(Name: String; const APrec: PtPositionRec);
procedure GetBackgroundBitmap;
function FindSectionAtPosition(Pos: integer;
var TopPos: integer; var Index: integer): TSectionBase;
procedure CancelActives;
function GetURL(Canvas: TCanvas; X: integer; Y: integer; var UrlTarg: TUrlTarget;
var FormControl: TImageFormControlObj; var ATitle: string): guResultType; override;
procedure LButtonDown(Down: boolean);
function GetTheBitmap(const BMName: String; var Transparent: Transparency;
var AMask: TBitmap; var FromCache, Delay: boolean): TgpObject;
function DoLogic(Canvas: TCanvas; Y: integer; Width, AHeight, BlHt: integer;
var ScrollWidth: integer; var Curs: integer): integer; override;
function Draw(Canvas: TCanvas; ARect: TRect; ClipWidth, X: integer;
Y, XRef, YRef :integer): integer; override;
procedure InsertImage(const Src: string; Stream: TMemoryStream; var Reformat: boolean);
function GetFormcontrolData: TFreeList;
procedure SetFormcontrolData(T: TFreeList);
function FindDocPos(SourcePos: integer; Prev: boolean): integer;
function CursorToXY(Canvas: TCanvas; Cursor: integer; var X: integer;
var Y: integer): boolean;
procedure ProcessInlines(SIndex: integer; Prop: TProperties; Start: 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}
SpecHtPercent: integer;
YIndent: integer; {Vertical indent}
VAlign: AlignmentType; {Top, Middle, or Bottom}
WidthAttr: integer; {Width attribute (percentage or absolute)}
AsPercent: boolean; {it's a percent}
EmSize, ExSize: integer;
PRec: PtPositionRec;
PadTop, PadRight, PadBottom, PadLeft: integer;
BrdTop, BrdRight, BrdBottom, BrdLeft: integer;
HzSpace, VrSpace: integer;
BorderStyle: BorderStyleType;
Cell: TCellObjCell;
NeedDoImageStuff: boolean;
BGImage: TImageObj;
TiledImage: TGpObject;
TiledMask, FullBG: TBitmap;
MargArray: TMarginArray;
MargArrayO: TVMarginArray;
NoMask: boolean;
BreakBefore, BreakAfter, KeepIntact: boolean;
constructor Create(Master: TSectionList; AVAlign: AlignmentType;
Attr: TAttributeList; Prop: TProperties);
constructor CreateCopy(AMasterList: TSectionList; T: TCellObj);
destructor Destroy; override;
private
procedure InitializeCell(TablePadding: integer; const BkImageName: string;
const APRec: PtPositionRec; Border: boolean);
procedure Draw(Canvas: TCanvas; const ARect: TRect; X, Y, CellSpacing: integer;
Border: boolean; Light, Dark: TColor);
procedure DrawLogic2(Canvas: TCanvas; Y, CellSpacing: integer;
var Curs: integer);
end;
const
ImageSpace = 3; {extra space for left, right images}
ListIndent = 35;
var
CurrentStyle: TFontStyles; {as set by , , etc.}
CurrentForm: ThtmlForm;
UnicodeControls: boolean;
implementation
uses
{$ifdef Delphi6_Plus}
Variants,
{$endif}
HTMLView, ReadHTML, HTMLSbs1, GDIPL2A;
var
NLevel: integer; {for debugging}
type
TSectionClass = Class of TSectionBase;
EProcessError = class(Exception);
TFormRadioButton = class(TRadioButton)
private
IDName: string;
FChecked: boolean;
procedure WMGetDlgCode(var Message: TMessage); message WM_GETDLGCODE;
protected
procedure CreateWnd; override;
function GetChecked: Boolean; override;
procedure SetChecked(Value: Boolean); override;
published
property Checked: boolean read GetChecked write SetChecked;
end;
TFormCheckBox = class(TCheckBox)
private
procedure WMGetDlgCode(var Message: TMessage); message WM_GETDLGCODE;
end;
BorderRec = class {record for inline borders}
private
BStart, BEnd: integer;
OpenStart, OpenEnd: boolean;
BRect: TRect;
MargArray: TMarginArray;
procedure DrawTheBorder(Canvas: TCanvas; XOffset, YOffSet: integer; Printing: boolean);
end;
InlineRec = class
private
StartB, EndB, IDB, StartBDoc, EndBDoc: integer;
MargArray: TMarginArray;
end;
TInlineList = class(TFreeList) {a list of InlineRec's}
private
NeedsConverting: boolean;
Owner: TSectionList;
procedure AdjustValues;
function GetStartB(I: integer): integer;
function GetEndB(I: integer): integer;
public
constructor Create(AnOwner: TSectionList);
procedure Clear;
property StartB[I: integer]: integer read GetStartB;
property EndB[I: integer]: integer read GetEndB;
end;
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;
LIndent: integer;
begin
if Assigned(Img) then
begin
IW := Img.ImageWidth + Img.HSpaceL + Img.HSpaceR;
IH := Img.ImageHeight + Img.VSpaceT + Img.VSpaceB;
if (Img.ObjAlign = ALeft) then
begin
IR := IndentRec.Create;
with IR do
begin
LIndent := LeftIndent(Y);
Img.Indent := LIndent-LfEdge+Img.HSpaceL;
X := LIndent-LfEdge + IW;
YT := Y;
YB := Y + IH;
L.Add(IR);
end;
end
else if (Img.ObjAlign = ARight) then
begin
IR := IndentRec.Create;
with IR do
begin
X := RightSide(Y) - IW;
Img.Indent := X + Img.HSpaceL;
YT := Y;
YB := Y + IH;
R.Add(IR);
end;
end;
end;
end;
procedure IndentManager.UpdateBlock(Y: integer; IW: integer; IH: integer;
Justify: AlignmentType);
{For a floating block, update the edge information. }
var
IR: IndentRec;
begin
IR := IndentRec.Create;
if (Justify = ALeft) then
begin
with IR do
begin
X := -LfEdge + IW;
YT := Y;
YB := Y + IH;
Float := True; //ID := CurrentID;
L.Add(IR);
end;
end
else if (Justify = ARight) then
begin
with IR do
begin
X := RightSide(Y) - IW;
YT := Y;
YB := Y + IH;
Float := True; //ID := CurrentID;
R.Add(IR);
end;
end;
end;
constructor TFontObj.Create(ASection: TSection; F: TMyFont; Position: integer);
begin
inherited Create;
Section := ASection;
TheFont := F;
Pos := Position;
UrlTarget := TUrlTarget.Create;
FontChanged;
end;
{$ifndef NoTabLink}
procedure TFontObj.EnterEvent(Sender: TObject);
var
List: TList;
I, J: integer;
begin
Active := True;
{Make adjacent fonts in this link active also}
List := Section.ParentSectionList.LinkList;
I := List.IndexOf(Self);
if I >= 0 then
for J := I+1 to List.Count-1 do
if (Self.UrlTarget.ID = TFontObj(List[J]).UrlTarget.ID) then
TFontObj(List[J]).Active := True
else Break;
Section.ParentSectionList.ControlEnterEvent(Self);
end;
procedure TFontObj.ExitEvent(Sender: TObject);
var
List: TList;
I, J: integer;
begin
Active := False;
{Make adjacent fonts in this link inactive also}
List := Section.ParentSectionList.LinkList;
I := List.IndexOf(Self);
if I >= 0 then
for J := I+1 to List.Count-1 do
if (Self.UrlTarget.ID = TFontObj(List[J]).UrlTarget.ID) then
TFontObj(List[J]).Active := False
else Break;
Section.ParentSectionList.PPanel.Invalidate;
end;
procedure TFontObj.AssignY(Y: integer);
var
List: TList;
I, J: integer;
begin
if UrlTarget.Url = '' then Exit;
if Assigned(TabControl) then
FYValue := Y
else
begin {Look back for the TFontObj with the TabControl}
List := Section.ParentSectionList.LinkList;
I := List.IndexOf(Self);
if I >= 0 then
for J := I-1 downto 0 do
if (Self.UrlTarget.ID = TFontObj(List[J]).UrlTarget.ID) then
begin
if Assigned(TFontObj(List[J]).TabControl) then
begin
TFontObj(List[J]).FYValue := Y;
break;
end;
end
else Break;
end;
end;
procedure TFontObj.AKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
var
Viewer: ThtmlViewer;
begin
Viewer := ThtmlViewer(Section.ParentSectionList.TheOwner);
if (Key = vk_Return) then
begin
Viewer.Url := UrlTarget.Url;
Viewer.Target := UrlTarget.Target;
Viewer.LinkAttributes.Text := UrlTarget.Attr;
Viewer.LinkText := Viewer.GetTextByIndices(UrlTarget.Start, UrlTarget.Last);
Viewer.TriggerUrlAction; {call to UrlAction via message}
end
else {send other keys to ThtmlViewer}
Viewer.KeyDown(Key, Shift);
end;
procedure TFontObj.CreateTabControl(TabIndex: integer);
var
PntPanel: TPaintPanel;
I, J: integer;
List: TList;
begin
if Assigned(TabControl) then
Exit;
{Look back for the TFontObj with the TabControl}
List := Section.ParentSectionList.LinkList;
I := List.IndexOf(Self);
if I >= 0 then
for J := I-1 downto 0 do
if (Self.UrlTarget.ID = TFontObj(List[J]).UrlTarget.ID) then
if Assigned(TFontObj(List[J]).TabControl) then
Exit;
PntPanel := TPaintPanel(Section.ParentSectionList.PPanel);
TabControl := ThtTabcontrol.Create(PntPanel);
with ThtTabcontrol(TabControl) do
begin
Left := -4000 ; {so will be invisible until placed}
Width := 1;
Height := 1;
TabStop := True;
OnEnter := EnterEvent;
OnExit := ExitEvent;
OnKeyDown := Self.AKeyDown;
end;
TabControl.Parent := PntPanel;
if TabIndex > 0 then
{Adding leading 0's to the number string allows it to be sorted numerically,
and the Count takes care of duplicates}
with Section.ParentSectionList.TabOrderList do
AddObject(Format('%.5d%.3d', [TabIndex, Count]), TabControl);
end;
{$endif}
procedure TFontObj.CreateFIArray;
begin
if not Assigned(FIArray) then
FIArray := TFontInfoArray.Create;
end;
procedure TFontObj.ReplaceFont(F: TMyFont);
begin
TheFont.Free;
TheFont := F;
FontChanged;
end;
procedure TFontObj.ConvertFont(FI: ThtFontInfo);
begin
with TheFont, FI do
begin
Name := iName;
Height := -Round(iSize * Screen.PixelsPerInch / 72);
Style := iStyle;
bgColor := ibgColor;
Color := iColor;
CharSet:= ICharSet;
FontChanged;
end;
end;
constructor TFontObj.CreateCopy(ASection: TSection; T: TFontObj);
begin
inherited Create;
Section := ASection;
Pos := T.Pos;
SScript := T.SScript;
TheFont := TMyFont.Create;
TheFont.Assign(T.TheFont);
if Assigned(T.FIArray) then
ConvertFont(T.FIArray.Ar[LFont]);
UrlTarget := TUrlTarget.Create;
UrlTarget.Copy(T.UrlTarget);
FontChanged;
end;
destructor TFontObj.Destroy;
begin
FIArray.Free;
TheFont.Free;
UrlTarget.Free;
TabControl.Free;
inherited Destroy;
end;
procedure TFontObj.SetVisited(Value: boolean);
begin
if Value <> FVisited then
begin
FVisited := Value;
if Value then
if Hover then
ConvertFont(FIArray.Ar[HVFont])
else
ConvertFont(FIArray.Ar[VFont])
else
if Hover then
ConvertFont(FIArray.Ar[HLFont])
else
ConvertFont(FIArray.Ar[LFont]);
FontChanged;
end;
end;
procedure TFontObj.SetHover(Value: boolean);
begin
if Value <> FHover then
begin
FHover := Value;
if Value then
if FVisited then
ConvertFont(FIArray.Ar[HVFont])
else ConvertFont(FIArray.Ar[HLFont])
else
if FVisited then
ConvertFont(FIArray.Ar[VFont])
else ConvertFont(FIArray.Ar[LFont]);
FontChanged;
end;
end;
procedure TFontObj.SetAllHovers(List: TList; Value: boolean);
{Set/Reset Hover on this item and all adjacent item with the same URL}
var
I, J: integer;
begin
SetHover(Value);
I := List.IndexOf(Self);
if I >= 0 then
begin
J := I+1;
while (J < List.Count) and (Self.UrlTarget.ID = TFontObj(List[J]).UrlTarget.ID) do
begin
TFontObj(List[J]).Hover := Value;
Inc(J);
end;
J := I-1;
while (J >= 0) and (Self.UrlTarget.ID = TFontObj(List[J]).UrlTarget.ID) do
begin
TFontObj(List[J]).Hover := Value;
Dec(J);
end;
end;
end;
function TFontObj.GetURL: string;
begin
try
Result := UrlTarget.Url;
except
Result := '';
{$ifdef DebugIt}
ShowMessage('Bad TFontObj, htmlsubs.pas, TFontObj.GetUrl');
{$endif}
end;
end;
procedure TFontObj.FontChanged;
begin
tmHeight := TheFont.tmHeight;
tmMaxCharWidth := TheFont.tmMaxCharWidth;
FontHeight := TheFont.tmHeight + TheFont.tmExternalLeading;
Descent := TheFont.tmDescent;
if fsItalic in TheFont.Style then {estimated overhang}
Overhang := TheFont.tmheight div 10
else Overhang := 0;
TheFont.Charset := TheFont.tmCharset;
end;
function TFontObj.GetOverhang: integer;
begin
Result := Overhang;
end;
function TFontObj.GetHeight(var Desc: integer): integer;
begin
Desc := Descent;
Result := FontHeight;
end;
constructor TFontList.CreateCopy(ASection: TSection; T: TFontList);
var
I: integer;
begin
inherited create;
for I := 0 to T.Count-1 do
Add(TFontObj.CreateCopy(ASection, TFontObj(T.Items[I])));
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.Overhang;
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;
{----------------TFontList.Decrement}
procedure TFontList.Decrement(N: integer; ParentSectionList: TSectionList);
{called when a character is removed to change the Position figure}
var
I, J: integer;
FO, FO1: TFontObj;
begin
I := 0;
while I < Count do
begin
FO := TFontObj(Items[I]);
if FO.Pos > N then
Dec(FO.Pos);
if (I > 0) and (TFontObj(Items[I-1]).Pos = FO.Pos) then
begin
FO1 := TFontObj(Items[I-1]);
J := ParentSectionList.LinkList.IndexOf(FO1);
if J >=0 then
ParentSectionList.LinkList.Delete(J);
{$ifndef NoTabLink}
if Assigned(FO1.TabControl) then
if FO.UrlTarget.Id = FO1.UrlTarget.ID then
begin {if the same link, transfer the TabControl to the survivor}
FO.TabControl := FO1.TabControl;
FO.TabControl.OnEnter := FO.EnterEvent;
FO.TabControl.OnExit := FO.ExitEvent;
FO1.TabControl := Nil;
end
else
begin {remove the TabControl from the TabOrderList}
J := ParentSectionList.TabOrderList.IndexOfObject(FO1.TabControl);
if J >= 0 then
ParentSectionList.TabOrderList.Delete(J);
end;
{$endif}
FO1.Free;
Delete(I-1);
end
else Inc(I);
end;
end;
{----------------TImageObj.Create}
constructor TImageObj.Create(MasterList: TSectionList; Position: integer; L: TAttributeList);
var
I: integer;
S: string;
NewSpace: integer;
T: TAttribute;
begin
inherited Create;
ParentSectionList := MasterList;
Pos := Position;
ObjAlign := ABottom; {default}
NewSpace := -1;
SpecHeight := -1;
SpecWidth := -1;
for I := 0 to L.Count-1 do
with TAttribute(L[I]) do
case Which of
SrcSy: Source := Trim(Name);
AltSy:
begin
FAlt := Name;
while (Length(FAlt) > 0) and (FAlt[Length(FAlt)] in [#$D, #$A]) do
Delete(FAlt, Length(FAlt), 1);
ImageTitle := FAlt; {use Alt as default Title}
FAltW := MultibyteToWideString(CodePage, FAlt);
end;
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: begin
NoBorder := Value = 0;
BorderSize := IntMin(IntMax(0, Value), 10);
end;
TranspSy: Transparent := LLCorner;
HeightSy:if System.Pos('%', Name) > 0 then
begin
if (Value >= 0) and (Value <=100) then
begin
SpecHeight := Value;
PercentHeight := True;
end;
end
else
SpecHeight := Value;
WidthSy:if System.Pos('%', Name) > 0 then
begin
if (Value >= 0) and (Value <=100) then
begin
SpecWidth := Value;
PercentWidth := True;
end;
end
else
SpecWidth := Value;
HSpaceSy: NewSpace := IntMin(40, Abs(Value));
VSpaceSy: VSpaceT := IntMin(40, Abs(Value));
ActiveSy: FHoverImage := True;
NameSy: ParentSectionList.IDNameList.AddObject(Name, Self);
end;
if L.Find(TitleSy, T) then
ImageTitle := T.Name; {has higher priority than Alt loaded above}
if L.TheID <> '' then
ParentSectionList.IDNameList.AddObject(L.TheID, Self);
if NewSpace >= 0 then
HSpaceL := NewSpace
else if ObjAlign in [ALeft, ARight] then
HSpaceL := ImageSpace {default}
else HSpaceL := 0;
HSpaceR := HSpaceL;
VSpaceB := VSpaceT;
end;
constructor TImageObj.SimpleCreate(MasterList: TSectionList; const AnURL: string);
begin
inherited Create;
ParentSectionList := MasterList;
ObjAlign := ABottom; {default}
Source := AnURL;
NoBorder := True;
BorderSize := 0;
SpecHeight := -1;
SpecWidth := -1;
end;
procedure TFloatingObj.ProcessProperties(Prop: TProperties);
const
DummyHtWd = 200;
var
MargArrayO: TVMarginArray;
MargArray: TMarginArray;
Align: AlignmentType;
EmSize, ExSize: integer;
begin
if Prop.GetVertAlign(Align) then
ObjAlign := Align;
if Prop.GetFloat(Align) and (Align <> ANone) then
begin
if HSpaceR = 0 then
begin {default is different for Align = left/right}
HSpaceR := ImageSpace;
HSpaceL := ImageSpace;
end;
ObjAlign := Align;
end;
if ImageTitle = '' then {a Title attribute will have higher priority than inherited}
ImageTitle := Prop.PropTitle;
Prop.GetVMarginArray(MargArrayO);
EmSize := Prop.EmSize;
ExSize := Prop.ExSize;
ConvInlineMargArray(MargArrayO, DummyHtWd, DummyHtWd, EmSize, ExSize, MargArray);
if MargArray[MarginLeft] <> IntNull then
HSpaceL := MargArray[MarginLeft];
if MargArray[MarginRight] <> IntNull then
HSpaceR := MargArray[MarginRight];
if MargArray[MarginTop] <> IntNull then
VSpaceT := MargArray[MarginTop];
if MargArray[MarginBottom] <> IntNull then
VSpaceB := MargArray[MarginBottom];
if Prop.GetBorderStyle <> bssNone then
begin
Inc(HSpaceL, MargArray[BorderLeftWidth]);
Inc(HSpaceR, MargArray[BorderRightWidth]);
Inc(VSpaceT, MargArray[BorderTopWidth]);
Inc(VSpaceB, MargArray[BorderBottomWidth]);
end;
if MargArray[Width] <> IntNull then
begin
PercentWidth := False;
if MargArray[Width] = Auto then
SpecWidth := -1
else if (VarType(MargArrayO[Width]) = varString)
and (System.Pos('%', MargArrayO[Width]) > 0) then
begin
PercentWidth := True;
SpecWidth := MulDiv(MargArray[Width], 100, DummyHtWd);
end
else
SpecWidth := MargArray[Width];
end;
if MargArray[Height] <> IntNull then
begin
PercentHeight := False;
if MargArray[Height] = Auto then
SpecHeight := -1
else if (VarType(MargArrayO[Height]) = varString)
and (System.Pos('%', MargArrayO[Height]) > 0) then
begin
PercentHeight := True;
SpecHeight := MulDiv(MargArray[Height], 100, DummyHtWd);
end
else
SpecHeight := MargArray[Height];
end;
if Prop.GetVertAlign(Align) then
ObjAlign := Align;
if Prop.GetFloat(Align) and (Align <> ANone) then
ObjAlign := Align;
if Prop.BorderStyleNotBlank then
begin
NoBorder := True; {will have inline border instead}
BorderSize := 0;
end;
end;
constructor TImageObj.CreateCopy(AMasterList: TSectionList; T: TImageObj);
begin
inherited CreateCopy(T);
ParentSectionList := AMasterList;
ImageKnown := T.ImageKnown;
ObjHeight := T.ObjHeight;
ObjWidth := T.ObjWidth;
SpecHeight := T.SpecHeight;
SpecWidth := T.SpecWidth;
PercentWidth := T.PercentWidth;
PercentHeight := T.PercentHeight;
Image := T.Image;
Mask := T.Mask;
IsMap := T.IsMap;
Transparent := T.Transparent;
FBitmap := Nil;
end;
destructor TImageObj.Destroy;
begin
if not ParentSectionList.IsCopy then
begin
if (Source <> '') and Assigned(OrigImage) then
ParentSectionList.BitmapList.DecUsage(Source);
if Swapped and (Image <> OrigImage) then
begin {not in cache}
Image.Free;
Mask.Free;
end;
if (OrigImage is TGifImage) and TGifImage(OrigImage).IsCopy then
OrigImage.Free;
end;
FreeAndNil(FBitmap);
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) or (Image is TGpBitmap) then
begin
if Assigned(FBitmap) then
Result := FBitmap
else
begin
if (Image is TBitmap) then
begin
FBitmap := TBitmap.Create;
FBitmap.Assign(TBitmap(Image));
if ColorBits = 8 then
FBitmap.Palette := CopyPalette(ThePalette);
end
else {it's a TGpBitmap}
FBitmap := TGpBitmap(Image).GetTBitmap;
Result := FBitmap;
end;
end
{$ifndef NoMetafile}
else if (Image is ThtMetaFile) then
Result := ThtMetaFile(Image).WhiteBGBitmap;
{$endif}
end;
procedure TImageObj.SetHover(Value: HoverType);
begin
if (Value <> FHover) and FHoverImage and (Image is TGifImage) then
with TGifImage(Image) do
begin
if Value <> hvOff then
case NumFrames of
2: CurrentFrame := 2;
3: if Value = hvOverDown then
CurrentFrame := 3
else CurrentFrame := 2;
else
begin
Animate := True;
ParentSectionList.AGifList.Add(Image);
end;
end
else
begin
Animate := False;
if NumFrames <= 3 then
CurrentFrame := 1;
ParentSectionList.AGifList.Remove(Image);
end;
FHover := Value;
ParentSectionList.PPanel.Invalidate;
end;
end;
{----------------TImageObj.ReplaceImage}
procedure TImageObj.ReplaceImage(NewImage: TStream);
var
TmpImage: TGpObject;
NonAnimated: boolean;
AMask: TBitmap;
Stream: TMemoryStream;
Tmp: TGifImage;
I: integer;
begin
Transparent := NotTransp;
AMask := Nil;
TmpImage := Nil;
Stream := TMemoryStream.Create;
try
Stream.LoadFromStream(NewImage);
if Assigned(Stream) and (Stream.Memory <> Nil) and (Stream.Size >= 1) then
begin
NonAnimated := True;
if KindOfImage(Stream.Memory) in [GIF, Gif89] then
TmpImage := CreateAGifFromStream(NonAnimated, Stream);
if Assigned(TmpImage) then
begin
if NonAnimated then
begin {else already have animated GIF}
Tmp := TGifImage(TmpImage);
TmpImage := TBitmap.Create;
TBitmap(TmpImage).Assign(Tmp.MaskedBitmap);
if Tmp.IsTransparent then
begin
AMask := TBitmap.Create;
AMask.Assign(Tmp.Mask);
Transparent := TGif;
end;
Tmp.Free;
end;
end
else
TmpImage := GetImageAndMaskFromStream(Stream, Transparent, AMask);
end;
finally
Stream.Free;
end;
if Assigned(TmpImage) then
begin
if not Swapped then
begin
{OrigImage is left in cache and kept}
if (Image is TGifImage) then
ParentSectionList.AGifList.Remove(Image);
Swapped := True;
end
else {swapped already}
begin
if (Image is TGifImage) then
begin
ParentSectionList.AGifList.Remove(Image);
end;
Image.Free;
FreeAndNil(Mask);
end;
FreeAndNil(FBitmap);
Image := TmpImage;
if (Image is TGifImage) then
begin
if not FHoverImage then
begin
TGifImage(Image).Animate := True;
ParentSectionList.AGifList.Add(Image);
end
else
begin
TGifImage(Image).Animate := False;
SetHover(hvOff);
end;
end;
Mask := AMask;
if Missing then
begin {if waiting for image, no longer want it}
with ParentSectionList.MissingImages do
for I := 0 to count-1 do
if Objects[I] = Self then
begin
Delete(I);
break;
end;
Missing := False;
end;
ParentSectionList.PPanel.Invalidate;
end;
end;
{----------------TImageObj.InsertImage}
function TImageObj.InsertImage(const UName: string; Error: boolean; var Reformat: boolean): boolean;
var
TmpImage: TgpObject;
FromCache, IsAniGIF, Delay: boolean;
begin
Result := False;
Reformat := False;
if (Image = DefBitmap) then
begin
Result := True;
if Error then
begin
Image := ErrorBitmap;
Mask := ErrorBitmapMask;
Transparent := LLCorner;
end
else
begin
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;
if not FHoverImage then
begin
ParentSectionList.AGifList.Add(Image);
TGifImage(Image).Animate := True;
if Assigned(ParentSectionList.Timer) then
ParentSectionList.Timer.Enabled := True;
end
else TGifImage(Image).Animate := False;
end
else Image := TmpImage;
OrigImage := Image;
end;
Missing := False;
if not ImageKnown then
Reformat := True; {need to get the dimensions}
end;
end;
{----------------TImageObj.DrawLogic}
procedure TImageObj.DrawLogic(SectionList: TSectionList; Canvas: TCanvas;
FO: TFontObj; AvailableWidth, AvailableHeight: integer);
{calculate the height and width}
var
TmpImage: TgpObject;
ImHeight, ImWidth: integer;
ViewImages, FromCache: boolean;
Rslt: string;
ARect: TRect;
SubstImage: Boolean;
HasBlueBox: Boolean;
begin
ViewImages := ParentSectionList.ShowImages;
TmpImage := Image;
if ViewImages and not Assigned(TmpImage) then
begin
if Source <> '' then
with SectionList do
begin
if not Assigned(GetBitmap) and not Assigned(GetImage) then
Source := (TheOwner as ThtmlViewer).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, Missing)
else Missing := True; {already in list, don't request it again}
end;
if not Assigned(TmpImage) then
begin
if Missing 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;
OrigImage := Image;
if not FHoverImage then
ParentSectionList.AGifList.Add(Image)
else TGifImage(Image).Animate := False;
end
else
begin
Image := TmpImage; //TBitmap(TmpImage);
OrigImage := Image;
end;
end;
if not ViewImages then
TmpImage := DefBitMap;
ImHeight := GetImageHeight(TmpImage);
ImWidth := GetImageWidth(TmpImage);
SubstImage := (Image = ErrorBitmap) or (TmpImage = DefBitmap);
if not ImageKnown or PercentWidth or PercentHeight then
begin
if PercentWidth then
begin
ObjWidth := MulDiv(AvailableWidth-2*BorderSize, SpecWidth, 100);
if SpecHeight >= 0 then
if PercentHeight then
ObjHeight := MulDiv(AvailableHeight-2*BorderSize, SpecHeight, 100)
else ObjHeight := SpecHeight
else ObjHeight := MulDiv(ObjWidth, ImHeight, ImWidth);
end
else if PercentHeight then
begin
ObjHeight := MulDiv(AvailableHeight-2*BorderSize, SpecHeight, 100);
if SpecWidth >= 0 then ObjWidth := SpecWidth
else ObjWidth := MulDiv(ObjHeight, ImWidth, 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 := not SubstImage;
end
else if SpecWidth >= 0 then
begin
ObjWidth := SpecWidth;
ObjHeight := MulDiv(SpecWidth, ImHeight, ImWidth);
ImageKnown := not SubstImage;
end
else
begin {neither height and width specified}
ObjHeight := ImHeight;
ObjWidth := ImWidth;
ImageKnown := not SubstImage;
end;
end;
if (not ViewImages or SubstImage) then
begin
if (SpecWidth >= 0) or (SpecHeight >= 0) then
begin {size to whatever is specified}
AltWidth := ObjWidth;
AltHeight := ObjHeight;
end
else if FAltW <> '' then {Alt text and no size specified, take as much space as necessary}
begin
Canvas.Font.Name := 'Arial';{use same font as in Draw}
Canvas.Font.Size := 8;
ARect := Rect(0, 0, 0, 0);
DrawTextW(Canvas.Handle, PWideChar(FAltW+CRLF), -1, ARect, DT_CALCRECT);
with ARect do
begin
AltWidth := Right + 16+8+2;
AltHeight := IntMax(16+8, Bottom);
end;
end
else
begin {no Alt text and no size spedified}
AltWidth := IntMax(ObjWidth, 16+8);
AltHeight := IntMax(ObjHeight, 16+8);
end;
ImageHeight := AltHeight;
ImageWidth := AltWidth;
end
else
begin
ImageHeight := ObjHeight;
ImageWidth := ObjWidth;
end;
HasBlueBox := not NoBorder and Assigned(FO) and (FO.URLTarget.Url <> '');
if HasBlueBox then
BorderSize := IntMax(1, BorderSize);
if (BorderSize > 0) then
begin
Inc(ImageHeight, 2*BorderSize); {extra pixels top and bottom for border}
Inc(ImageWidth, 2*BorderSize);
end;
end;
{----------------TImageObj.DoDraw}
procedure TImageObj.DoDraw(Canvas: TCanvas; XX: integer; Y: integer;
ddImage: TgpObject; ddMask: TBitmap);
{Y relative to top of display here}
var
DC: HDC;
Img: TBitmap;
W, H: integer;
BMHandle: HBitmap;
PrintTransparent: boolean;
begin
DC := Canvas.Handle;
if TObject(ddImage) is TGPImage then
begin
if not ParentSectionList.Printing then
StretchDrawGpImage(DC, TGPImage(ddImage),XX,Y, ObjWidth, ObjHeight)
else if not ParentSectionList.PrintBackground and (Positioning = posStatic) then {Printing}
StretchPrintGpImageOnColor(Canvas, TGpImage(ddImage), XX, Y, ObjWidth, ObjHeight)
else
StretchPrintGpImageDirect(DC, TGPImage(ddImage),XX,Y, ObjWidth, ObjHeight,
ParentSectionList.ScaleX, ParentSectionList.ScaleY);
Exit;
end;
if (ddImage is TGifImage) and not ParentSectionList.IsCopy then
with TGifImage(ddImage) do
begin
ShowIt := True;
Visible := True;
Draw(Canvas, XX, Y, ObjWidth, ObjHeight);
Exit;
end;
try
if not ParentSectionList.IsCopy then
begin
if ((Transparent <> NotTransp) or (ddImage = ErrorBitmap)) and Assigned(ddMask) then
if ddImage = ErrorBitmap then
FinishTransparentBitmap(DC, TBitmap(ddImage), Mask, XX, Y,
TBitmap(ddImage).Width, TBitmap(ddImage).Height)
else
FinishTransparentBitmap(DC, TBitmap(ddImage), Mask, XX, Y, ObjWidth, ObjHeight)
else
begin
Img := TBitmap(ddImage);
if (ddImage = DefBitMap) or (ddImage = ErrorBitmap) then
BitBlt(DC, XX, Y, Img.Width, Img.Height, Img.Canvas.Handle, 0, 0, SRCCOPY)
else if ddImage is TBitmap then
begin
SetStretchBltMode(DC, ColorOnColor);
StretchBlt(DC, XX, Y, ObjWidth, ObjHeight, Img.Canvas.Handle, 0, 0, Img.Width, Img.Height, SRCCOPY);
end
{$ifndef NoMetafile}
else if ddImage is ThtMetaFile then
Canvas.StretchDraw(Rect(XX, Y, XX+ObjWidth, Y+ObjHeight), ThtMetaFile(ddImage));
{$endif}
end;
end
else
begin {printing}
if ddImage is TGifImage then
with TGifImage(ddImage) do
begin
ddMask := Mask;
if Assigned(ddMask) then Transparent := TGif;
ddImage := MaskedBitmap;
TBitmap(ddImage).Palette := CopyPalette(ThePalette);
TBitmap(ddImage).HandleType := bmDIB;
end;
if (ddImage = DefBitMap) or (ddImage = ErrorBitmap) then
begin
W := TBitmap(ddImage).Width;
H := TBitmap(ddImage).Height;
end
else
begin
W := ObjWidth;
H := ObjHeight;
end;
PrintTransparent := ((Transparent <> NotTransp) or (ddImage = ErrorBitmap))
and Assigned(ddMask);
if PrintTransparent then
PrintTransparentBitmap3(Canvas, XX, Y, W, H, TBitmap(ddImage), ddMask, 0, TBitmap(ddImage).Height)
else if ddImage is TBitmap then
begin {printing, not transparent}
BMHandle := TBitmap(ddImage).Handle;
PrintBitmap(Canvas, XX, Y, W, H, BMHandle);
end
{$ifndef NoMetafile}
else if ddImage is ThtMetaFile then
Canvas.StretchDraw(Rect(XX, Y, XX+ObjWidth, Y+ObjHeight), ThtMetaFile(ddImage));
{$endif}
end;
except
end;
end;
{----------------TImageObj.Draw}
procedure TImageObj.Draw(Canvas: TCanvas; X: integer; TopY, YBaseline: integer;
FO: TFontObj);
var
TmpImage: TgpObject;
TmpMask: TBitmap;
MiddleAlignTop: integer;
ViewImages: boolean;
SubstImage: boolean;
Ofst: integer;
SaveColor: TColor;
ARect: TRect;
SaveWidth: Integer;
SaveStyle: TPenStyle;
YY: Integer;
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
else TmpMask := Nil;
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;
Font.Size := 8;
Font.Name := 'Arial'; {make this a property?}
Font.Style := Font.Style - [fsBold];
if SubstImage then Ofst := 4 else Ofst := 0;
if ObjAlign = AMiddle then
MiddleAlignTop := YBaseLine+FO.Descent-(FO.tmHeight div 2)-((ImageHeight-VSpaceT+VSpaceB) div 2)
else MiddleAlignTop := 0; {not used}
DrawXX := X;
case ObjAlign of
ALeft, ARight, ATop: DrawYY := TopY+VSpaceT;
AMiddle: DrawYY := MiddleAlignTop;
ABottom, ABaseline: DrawYY := YBaseLine-ImageHeight-VSpaceB;
end;
if (BorderSize > 0) then
begin
Inc(DrawXX, BorderSize);
Inc(DrawYY, BorderSize);
end;
if not SubstImage or (AltHeight >= 16+8) and (AltWidth >= 16+8) then
DoDraw(Canvas, DrawXX+Ofst, DrawYY+Ofst, TmpImage, TmpMask);
Inc(DrawYY, ParentSectionList.YOff);
SetTextAlign(Canvas.Handle, TA_Top);
if SubstImage and (BorderSize = 0) then
begin
Font.Color := FO.TheFont.Color;
{calc the offset from the image's base to the alt= text baseline}
case ObjAlign of
ATop, ALeft, ARight:
begin
if FAltW <> '' then
WrapTextW(Canvas, X+24, TopY+Ofst+VSpaceT, X+AltWidth-2, TopY+AltHeight-1+VSpaceT, FAltW);
RaisedRect(ParentSectionList, Canvas, X, TopY+VSpaceT,
X+AltWidth-1, TopY+AltHeight-1+VSpaceT, False, 1);
end;
AMiddle:
begin {MiddleAlignTop is always initialized}
if FAltW <> '' then
WrapTextW(Canvas, X+24, MiddleAlignTop+Ofst, X+AltWidth-2,
MiddleAlignTop+AltHeight-1, FAltW);
RaisedRect(ParentSectionList, Canvas, X, MiddleAlignTop,
X+AltWidth-1, MiddleAlignTop+AltHeight-1, False, 1);
end;
ABottom, ABaseline:
begin
if FAltW <> '' then
WrapTextW(Canvas, X+24, YBaseLine-AltHeight+Ofst-VSpaceB, X+AltWidth-2,
YBaseLine-VSpaceB-1, FAltW);
RaisedRect(ParentSectionList, Canvas, X, YBaseLine-AltHeight-VSpaceB,
X+AltWidth-1, YBaseLine-VSpaceB-1, False, 1);
end;
end;
end;
if (BorderSize > 0) then
begin
SaveColor := Pen.Color;
SaveWidth := Pen.Width;
SaveStyle := Pen.Style;
Pen.Color := FO.TheFont.Color;
Pen.Width := BorderSize;
Pen.Style := psInsideFrame;
Font.Color := Pen.Color;
try
if (FAltW <> '') and SubstImage then {output Alt message}
begin
YY := DrawYY-ParentSectionList.YOff;
case ObjAlign of
ALeft, ARight, ATop:
WrapTextW(Canvas, DrawXX+24, YY+Ofst, DrawXX+AltWidth-2, YY+AltHeight-1, FAltW);
AMiddle:
WrapTextW(Canvas, DrawXX+24, YY+Ofst, DrawXX+AltWidth-2,
YY+AltHeight-1, FAltW);
ABottom, ABaseline:
WrapTextW(Canvas, DrawXX+24, YY+Ofst, DrawXX+AltWidth-2,
YY+AltHeight-1, FAltW);
end;
end;
case ObjAlign of {draw border}
ALeft, ARight, ATop: Rectangle(X, TopY+VSpaceT, X+ImageWidth, TopY+VSpaceT+ImageHeight);
AMiddle: Rectangle(X, MiddleAlignTop, X+ImageWidth, MiddleAlignTop + ImageHeight);
ABottom, ABaseline: Rectangle(X, YBaseLine-ImageHeight-VSpaceB, X+ImageWidth, YBaseLine-VSpaceB);
end;
finally
Pen.Color := SaveColor;
Pen.Width:= SaveWidth;
Pen.Style:= SaveStyle;
end;
end;
if (Assigned(MyFormControl) and MyFormControl.Active or FO.Active) or
ParentSectionList.IsCopy and Assigned(ParentSectionList.LinkDrawnEvent)
and (FO.UrlTarget.Url <> '') then
begin
SaveColor := SetTextColor(Handle, clBlack);
Brush.Color := clWhite;
case ObjAlign of
ALeft, ARight, ATop:
ARect := Rect(X, TopY+VSpaceT, X+ImageWidth, TopY+VSpaceT+ImageHeight);
AMiddle:
ARect := Rect(X, MiddleAlignTop, X+ImageWidth, MiddleAlignTop + ImageHeight);
ABottom, ABaseline:
ARect := Rect(X, YBaseLine-ImageHeight-VSpaceB, X+ImageWidth, YBaseLine-VSpaceB);
end;
if not ParentSectionList.IsCopy then
Canvas.DrawFocusRect(ARect) {draw focus box}
else
ParentSectionList.LinkDrawnEvent(ParentSectionList.TheOwner, ParentSectionList.LinkPage,
FO.UrlTarget.Url, FO.UrlTarget.Target, ARect);
SetTextColor(handle, SaveColor);
end;
end;
end;
{----------------TImageObjList.CreateCopy}
constructor TImageObjList.CreateCopy(AMasterList: TSectionList; T: TImageObjList);
var
I: integer;
Item: TObject;
begin
inherited create;
for I := 0 to T.Count-1 do
begin
Item := T.Items[I];
if Item is TImageObj then
Add(TImageObj.CreateCopy(AMasterList, TImageObj(Item)))
else Add(TPanelObj.CreateCopy(AMasterList, TPanelObj(Item)));
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 := Items[I];
Exit;
end;
Result := Nil;
end;
function TImageObjList.GetHeightAt(Posn: integer; var AAlign: AlignmentType;
var FlObj: TFloatingObj) : Integer;
begin
FLObj := FindImage(Posn);
if Assigned(FLObj) then
begin
Result := FLObj.ImageHeight+FLObj.VSpaceT+FLObj.VSpaceB;
AAlign := FLObj.ObjAlign;
end
else Result := -1;
end;
function TImageObjList.GetWidthAt(Posn: integer; var AAlign: AlignmentType;
var HSpcL, HSpcR: integer; var FlObj: TFloatingObj) : integer;
begin
FLObj := FindImage(Posn);
if Assigned(FLObj) then
begin
Result := FLObj.ImageWidth;
AAlign := FLObj.ObjAlign;
HSpcL := FLObj.HSpaceL;
HSpcR := FLObj.HSpaceR;
end
else Result := -1;
end;
function TImageObjList.GetImageCountAt(Posn: integer): integer;
{Return count of chars before the next image. 0 if at the image, 99999999 if no
images after Posn}
var
I, Pos: integer;
begin
if Count = 0 then
begin
Result := 99999999;
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 := 99999999
else
Result := TFloatingObj(Items[I]).Pos - Posn;
end;
{----------------TImageObjList.Decrement}
procedure TImageObjList.Decrement(N: integer);
{called when a character is removed to change the Position figure}
var
I: integer;
begin
for I := 0 to Count-1 do
with TImageObj(Items[I]) do
if Pos > N then
Dec(Pos);
end;
{----------------TImageObjList.PtInImage}
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 := Items[I];
if Obj is TImageObj then
with TImageObj(Obj) do
begin
IX := X-DrawXX; {these are actual image, box if any is outside}
LIY := Y - DrawYY;
LimX := ImageWidth-2*BorderSize;
LimY:= ImageHeight-2*BorderSize;
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 := 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 := Items[I];
if Item is TImageObj then
with TImageObj(Item) do
begin
IX := X-DrawXX; {these are actual image, box if any is outside}
LIY := Y - DrawYY;
LimX := ImageWidth-2*BorderSize;
LimY:= ImageHeight-2*BorderSize;
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.FName <>'' then
begin
S := Radio.FName;
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.FName, S) = 0 then
begin
TFormRadioButton(Ctrl.TheControl).Checked := False;
TFormRadioButton(Ctrl.TheControl).TabStop := False; {first check turns off other tabstops}
TRadioButtonFormControlObj(Ctrl).DoOnchange;
end;
end;
end;
end;
procedure ThtmlForm.AKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
var
S: string;
Ctrl: TFormControlObj;
I: integer;
List: TList;
begin
if (Key in [vk_up, vk_down, vk_left, vk_right]) and (Sender is TFormRadioButton) then
begin
S := TFormRadioButton(Sender).IDName;
List:= TList.Create;
try
for I := 0 to ControlList.Count-1 do
begin
Ctrl := TFormControlObj(ControlList.Items[I]);
if (Ctrl is TRadioButtonFormControlObj) and
(CompareText(Ctrl.FName, S) = 0) then
List.Add(TRadioButtonFormControlObj(Ctrl).TheControl);
end;
I := List.IndexOf(Sender);
if I >= 0 then
begin
if (Key in [vk_up, vk_left]) then
begin
if I > 0 then
Dec(I);
end
else if I < List.Count-1 then
Inc(I);
TFormRadioButton(List.Items[I]).SetFocus;
end;
finally
List.Free;
end;
end
else {send other keys to ThtmlViewer}
ThtmlViewer(MasterList.TheOwner).KeyDown(Key, Shift);
end;
procedure ThtmlForm.ResetControls;
var
I: integer;
begin
for I := 0 to ControlList.Count-1 do
TFormControlObj(ControlList.Items[I]).ResetToValue;
end;
procedure ThtmlForm.ControlKeyPress(Sender: TObject; var Key: char);
begin
if (Sender is ThtEdit) then
if (Key = #13) then
begin
SubmitTheForm('');
Key := #0;
end;
end;
function ThtmlForm.GetFormSubmission: TStringList;
var
I, J: integer;
S: string;
begin
Result := 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
Result.Add(S);
Inc(J);
end;
end;
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;
if not Disabled then
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.SetFormData(SL: TStringList);
var
I, J, K, Index: integer;
Value: string;
FormControl: TFormControlObj;
begin
for I := 0 to ControlList.Count-1 do
begin
FormControl := TFormControlObj(ControlList[I]);
FormControl.SetDataInit;
Index := 0;
for J := 0 to SL.Count-1 do
if CompareText(FormControl.FName, SL.Names[J]) = 0 then
begin
K := Pos('=', SL[J]);
if K > 0 then
begin
Value := Copy(SL[J], K+1, Length(SL[J])-K);
FormControl.SetData(Index, Value);
Inc(Index);
end;
end;
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
I: integer;
begin
inherited Create;
Pos := Position;
MasterList := AMasterList;
if not Assigned(CurrentForm) then {maybe someone forgot the