, 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]; {, 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 without }
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