{Version 9.45}
{*********************************************************}
{*                     HTMLUN2.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}

unit htmlun2;

interface

uses
  SysUtils, Classes,
  {$IFNDEF LCL}
   Windows, Messages,
  {$ELSE}
   LclIntf, LMessages, Types, LclType, LResources, IntfGraphics, HtmlMisc,
  {$ENDIF}
  Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, Clipbrd,
  StyleUn, GDIPL2A; 

const
  VersionNo = '9.45';
  MaxHScroll = 6000;  {max horizontal display in pixels}      
{$IFNDEF LCL}
  HandCursor = 10101;
{$ELSE}
  HandCursor = crHandPoint;
{$ENDIF}
  OldThickIBeamCursor = 2;
  UpDownCursor = 10103;
  UpOnlyCursor = 10104;
  DownOnlyCursor = 10105;  
  Tokenleng = 300;  
  TopLim = -200;   {drawing limits}
  BotLim = 5000;   
  FmCtl = WideChar(#2);
  ImgPan = WideChar(#4);
  BrkCh = WideChar(#8);

var
  IsWin95: Boolean;
  IsWin32Platform: boolean; {win95, 98, ME}

type
  TgpObject = TObject;
  TScriptEvent = procedure(Sender: TObject; const Name, Language,    
       Script: string) of Object;

  TFreeList = class(TList)
  {like a TList but frees it's items.  Use only descendents of TObject}
    destructor Destroy; override;
    {$Warnings Off}
    procedure Clear;       {do not override}
    end;
    {$Warnings On}

  Transparency = (NotTransp, LLCorner, TGif, TPng);
  JustifyType = (NoJustify, Left, Centered, Right, FullJustify);  
  TRowType = (THead, TBody, TFoot);

  Symb = (
    HtmlSy, TitleSy, BodySy, HeadSy, PSy, PEndSy, BSy, BEndSy, ISy, IEndSy,
    HtmlEndSy, TitleEndSy, BodyEndSy, HeadEndSy, BRSy, HeadingSy, HeadingEndSy,
    EmSy, EmEndSy, StrongSy, StrongEndSy, USy, UEndSy, HRSy,
    CiteSy, VarSy, CiteEndSy, VarEndSy, BaseSy,
       {Keep order}
    TTSy, CodeSy, KbdSy, SampSy,  TTEndSy, CodeEndSy, KbdEndSy, SampEndSy,
       {end order}
    OLSy, OLEndSy, LISy, ULSy, ULEndSy, DirSy, DirEndSy, MenuSy, MenuEndSy,
    DLSy, DLEndSy, DDSy, DTSy, AddressSy, AddressEndSy, BlockQuoteSy, BlockQuoteEndSy,
    PreSy, PreEndSy, ImageSy, Centersy, CenterEndSy,
    OtherAttribute, ASy, AEndSy, HrefSy, NameSy, SrcSy, AltSy, AlignSy,
    OtherChar, OtherSy, CommandSy, TextSy, EofSy, LinkSy, BGColorSy,
    BackgroundSy, TableSy, TableEndSy, TDSy, TDEndSy, TRSy, TREndSy, THSy, THEndSy,
    ColSpanSy, RowSpanSy, BorderSy, CellPaddingSy, CellSpacingSy, VAlignSy,
    WidthSy, CaptionSy, CaptionEndSy, StartSy, ButtonSy, InputSy, ValueSy,
    TypeSy, CheckBoxSy, RadioSy, FormSy, FormEndSy, MethodSy, ActionSy,
    CheckedSy, SizeSy, MaxLengthSy, TextAreaSy, TextAreaEndSy, ColsSy,
    RowsSy, SelectSy, SelectEndSy, OptionSy, OptionEndSy, SelectedSy,
    MultipleSy, FontSy, FontEndSy, ColorSy, FaceSy, BaseFontSy,
    TranspSy, SubSy, SubEndSy, SupSy, SupEndSy, ClearSy, IsMapSy,
    BigSy, BigEndSy, SmallSy, SmallEndSy, BorderColorSy, MapSy, MapEndSy,
    AreaSy, ShapeSy, CoordsSy, NoHrefSy, UseMapSy, HeightSy, PlainSy,
    FrameSetSy, FrameSetEndSy, FrameSy, TargetSy, NoFramesSy, NoFramesEndSy,
    NoResizeSy, ScrollingSy, PageSy, HSpaceSy, VSpaceSy, ScriptSy, ScriptEndSy,  
    LanguageSy, DivSy, DivEndSy, SSy, SEndSy, StrikeSy, StrikeEndSy,
    FrameBorderSy, MarginWidthSy, MarginHeightSy, BgSoundSy, LoopSy,
    OnClickSy, WrapSy, NoShadeSy, MetaSy, HttpEqSy, ContentSy, EncTypeSy,
    VLinkSy, OLinkSy, ActiveSy, PanelSy, NoBrSy, NoBrEndSy, WbrSy,
    ClassSy, IDSy, StyleSy, StyleEndSy, SpanSy, SpanEndSy, liAloneSy,
    RelSy, RevSy, NoWrapSy, BorderColorLightSy, BorderColorDarkSy,
    CharSetSy, RatioSy, OnFocusSy, OnBlurSy, OnChangeSy, ColSy, ColGroupSy,
    ColGroupEndSy, TabIndexSy, BGPropertiesSy, DisabledSy,
    TopMarginSy, LeftMarginSy, LabelSy, LabelEndSy, THeadSy, TBodySy, TFootSy,
    THeadEndSy, TBodyEndSy, TFootEndSy, ObjectSy, ObjectEndSy, ParamSy, 
    ReadonlySy, EolSy);   

  TAttribute = class(TObject)  {holds a tag attribute}
  public
    Which: Symb;     {symbol of attribute such as HrefSy}
    WhichName: string;
    Value: integer;  {numeric value if appropriate}
    Percent: boolean;{if value is in percent}
    Name: String;   {String (mixed case), value after '=' sign}
    CodePage: integer;
    constructor Create(ASym: Symb; AValue: integer;
           Const NameStr, ValueStr: string; ACodePage: integer);  
    destructor Destroy; override;
  end;

  TAttributeList = class(TFreeList)  {a list of tag attributes,(TAttributes)}
    private
      Prop: TProperties;
      SaveID: string;
      function GetClass: string;
      function GetID: string;
      function GetTitle: string;  
      function GetStyle: TProperties;
    public
      destructor Destroy; override;
      procedure Clear;
      function Find(Sy: Symb; var T: TAttribute): boolean;
      function CreateStringList: TStringList;   
      property TheClass: string read GetClass;
      property TheID: string read GetID;
      property TheTitle: string read GetTitle;    
      property TheStyle: TProperties read GetStyle;
    end;

  TBitmapItem = class(TObject)
  public
    AccessCount: integer;
    UsageCount: integer;     {how many in use}
    Transp: Transparency;    {identifies what the mask is for}
    MImage: TgpObject;     {main image, bitmap or animated GIF}
    Mask: TBitmap;  {its mask}
    constructor Create(AImage: TgpObject; AMask: TBitmap; Tr: Transparency);
    destructor Destroy; override;
  end;

  TStringBitmapList = class(TStringList)
      {a list of bitmap filenames and TBitmapItems}
  public
    MaxCache: integer;
    constructor Create;
    destructor Destroy; override;
    procedure Clear; override;
    function AddObject(const S: string; AObject: TObject): Integer; override;
    procedure DecUsage(const S: string);
    procedure IncUsage(const S: string);
    procedure BumpAndCheck;
    procedure PurgeCache;
    function GetImage(I: integer): TgpObject;
    procedure SetCacheCount(N: integer);
  end;

  SelTextCount = class(TObject)
  private
    Buffer: PWideChar;
    BufferLeng: integer;
    Leng: integer;
  public
    procedure AddText(P: PWideChar; Size: integer); virtual;
    procedure AddTextCR(P: PWideChar; Size: integer);
    function Terminate: integer; virtual;
    end;

  SelTextBuf = class(SelTextCount)
  public
    constructor Create(ABuffer: PWideChar; Size: integer);
    procedure AddText(P: PWideChar; Size: integer); override;
    function Terminate: integer; override;
    end;

  ClipBuffer = class(SelTextBuf)
  private
    procedure CopyToClipboard;
  public
    constructor Create(Leng: integer);
    destructor Destroy; override;
    function Terminate: integer; override;
    end;

  TutText = class   {holds start and end point of URL text} 
    Start: integer;
    Last: integer;
    end;

  TUrlTarget = Class(TObject)
    private
      function GetStart: integer;  
      function GetLast: integer;
    public
      URL,
      Target: string;
      ID: integer;
      Attr: string;   
      utText: TutText; 
      TabIndex: integer;
      constructor Create;
      procedure Copy(UT: TUrlTarget);
      destructor Destroy; override;
      procedure Assign(AnUrl, ATarget: String; L: TAttributeList; AStart: integer);   
      procedure Clear;
      procedure SetLast(List: TList; ALast: integer);
      property Start: integer read GetStart;
      property Last: integer read GetLast;
      end;

  TMapItem = class(TObject)   {holds a client map info}
    MapName: String;
    Areas: TStringList;       {holds the URL and region handle}
    AreaTargets: TStringList; {holds the target window}
    AreaTitles: TStringList;  {the Title strings}   
    constructor Create;
    destructor Destroy; override;
    function GetURL(X, Y: integer; var URLTarg: TURLTarget; var ATitle: string): boolean;  
    procedure AddArea(Attrib: TAttributeList);
    end;

  TDib = class(TObject)
    private
      Info  : PBitmapInfoHeader;
      InfoSize: integer;
      Image: Pointer;
      ImageSize : integer;
      FHandle: THandle;
      procedure InitializeBitmapInfoHeader(Bitmap: HBITMAP);
      procedure GetDIBX(DC: HDC; Bitmap: HBITMAP; Palette: HPALETTE);
      procedure Allocate(Size: integer);
      procedure DeAllocate;
    public
      constructor CreateDIB(DC: HDC; Bitmap: TBitmap);
      destructor Destroy; override;
      function CreateDIBmp: hBitmap;
      procedure DrawDIB(DC: HDC; X: Integer; Y: integer; W, H: integer;
                ROP: DWord);
    end;

  IndentRec = Class(TObject)
    X: integer;       {indent for this record}
    YT, YB: integer;  {top and bottom Y values for this record}
    ID: TObject;      {level inicator for this record, 0 for not applicable}
    Float: boolean;   {set if Floating block boundary}
    end;

  IndentManagerBasic = class(TObject)
    Width, ClipWidth: Integer;
    L, R: TFreeList;  {holds info (IndentRec's) on left and right indents}
    CurrentID: TObject;       {the current level (a TBlock pointer)}
    LfEdge, RtEdge: integer;     {current extreme edges}

    constructor Create;
    destructor Destroy; override;
    procedure Clear;
    procedure Reset(Lf, Rt: integer);
    procedure UpdateTable(Y: integer; IW: integer; IH: integer; Justify: JustifyType);
    function LeftIndent(Y: integer): integer;
    function RightSide(Y: integer): integer;
    function ImageBottom: integer;
    procedure GetClearY(var CL, CR: integer);
    function GetNextWiderY(Y: integer): integer;
    function SetLeftIndent(XLeft, Y: integer): integer;
    function SetRightIndent(XRight, Y: integer): integer;
    procedure FreeLeftIndentRec(I: integer);   
    procedure FreeRightIndentRec(I: integer);   
    end;

  AllocRec = Class(TObject)
    Ptr: Pointer;
    ASize: integer;
    AHandle: THandle;
    end;

//  IndexArray = array[1..TokenLeng] of integer;
  IndexArray = array[1..30000] of integer;  // LCL port: To avoid range-check error in TCharCollection.Add.
  PIndexArray = ^IndexArray;
//  ChrArray = array[1..TokenLeng] of WideChar;     
  ChrArray = array[1..30000] of WideChar;  // LCL port: To avoid range-check error in TokenObj.AddUnicodeChar.     

  {Simplified variant of TokenObj, to temporarily keep a string of ANSI
   characters along with their original indices.}
  TCharCollection = class
  private
    FChars: string;
    FIndices: PIndexArray;
    FCurrentIndex: Integer;
    function GetSize: Integer;
    function GetAsString: string;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Add(C: Char; Index: Integer);
    procedure Clear;
    procedure Concat(T: TCharCollection);

    property AsString: string read GetAsString;
    property Chars: string read FChars;
    property Indices: PIndexArray read FIndices;
    property Size: Integer read GetSize;
  end;

  TokenObj= class
  private
    St: WideString;
    StringOK: boolean;
    function GetString: WideString;
  public
    C: ^ChrArray;
    I: ^IndexArray;
    MaxIndex, Leng: integer;
    constructor Create;
    destructor Destroy; override;
    procedure AddUnicodeChar(Ch: WideChar; Ind: integer);
    procedure AddString(S: TCharCollection; CodePage: Integer);
    procedure Concat(T: TokenObj);
    procedure Clear;
    procedure Remove(N: integer);
    procedure Replace(N: integer; Ch: WideChar);

    property S: WideString read GetString;
    end;

  TIDObject = class(TObject)
  protected
    function GetYPosition: integer; virtual; abstract;
  public
    property YPosition: integer read GetYPosition;
    destructor Destroy; override;
    end;

  TChPosObj = class (TIDObject)
  private
    ChPos: integer;
    List: TList;
  protected
    function GetYPosition: integer; override;
    end;

  TIDNameList = class(TStringList)
  private
    OwnerList: TList;
  public
    constructor Create(List: TList);
    destructor Destroy; override;
    procedure Clear; override;
    function AddObject(const S: string; AObject: TObject): Integer; override;
    procedure AddChPosObject(const S: string; Pos: integer);
    end;

{$ifndef NoMetafile}
  ThtMetaFile = class(TMetaFile)
  private
    FBitmap, FMask: TBitmap;
    FWhiteBGBitmap: TBitmap;
    function GetBitmap: TBitmap;
    function GetMask: TBitmap;
    procedure Construct;
    function GetWhiteBGBitmap: TBitmap;
  public
    destructor Destroy; override;
    property Bitmap: TBitmap read GetBitmap;
    property Mask: TBitmap read GetMask;
    property WhiteBGBitmap: TBitmap read GetWhiteBGBitmap;   
    end;
{$endif}

  ImageType = (NoImage, Bmp, Gif, Gif89, Png, Jpg);
  SetOfChar = Set of Char;

  htColorArray = packed array[0..3] of TColor;
  htBorderStyleArray = packed array[0..3] of BorderStyleType;

var
  ColorBits: Byte;
  ThePalette: HPalette;       {the rainbow palette for 256 colors}
  PalRelative: integer;    
  DefBitMap, ErrorBitMap, ErrorBitmapMask: TBitMap;
  ABitmapList: TStringBitmapList; {the image cache}
  WaitStream: TMemoryStream;

function InSet(W: WideChar; S: SetOfChar): boolean;

function StrLenW(Str: PWideChar): Cardinal;
function StrPosW(Str, SubStr: PWideChar): PWideChar;
function StrScanW(const Str: PWideChar; Chr: WideChar): PWideChar;
function StrRScanW(const Str: PWideChar; Chr: WideChar): PWideChar;
function FitText(DC: HDC; S: PWideChar; Max, Width: Integer; var Extent: integer): Integer;
function WidePos(SubStr, S: WideString): Integer;
function WideTrim(const S : WideString) : WideString;
function WideUpperCase1(const S: WideString): WideString;
function WideLowerCase1(const S: WideString): WideString;
function WideSameText1(const S1, S2: WideString): boolean;
function WideSameStr1(const S1, S2: WideString): boolean;
function PosX(const SubStr, S: string; Offset: integer = 1): Integer; 
   {find substring in S starting at Offset}

function IntMin(A, B: Integer): Integer;
function IntMax(A, B: Integer): Integer;
procedure GetClippingRgn(Canvas: TCanvas; ARect: TRect; Printing: boolean;
          var Rgn, SaveRgn: HRgn);    

function GetImageAndMaskFromFile(const Filename: string; var Transparent: Transparency;
                            var Mask: TBitmap): TgpObject; 
function HTMLToDos(FName: string): string;
  {convert an HTML style filename to one for Dos}
function HTMLServerToDos(FName, Root: string): string;

procedure WrapTextW(Canvas: TCanvas; X1, Y1, X2, Y2: integer; S: WideString); 

procedure FinishTransparentBitmap (ahdc: HDC;
            InImage, Mask: TBitmap; xStart, yStart, W, H: integer);  
function GetImageMask(Image: TBitmap; ColorValid: boolean; AColor: TColor): TBitmap;
function TransparentGIF(const FName: string; var Color: TColor): boolean;
function Allocate(Size: integer): AllocRec;
procedure DeAllocate(AR: AllocRec);
function CopyPalette(Source: hPalette): hPalette;
procedure SetGlobalPalette(Value: HPalette);
function GetImageFromFile(const Filename: String): TBitmap;
function GetImageAndMaskFromStream(Stream: TMemoryStream;
        var Transparent: Transparency; var AMask: TBitmap): TgpObject;
function KindOfImageFile(FName: String): ImageType;  
function KindOfImage(Start: Pointer): ImageType;
procedure FillRectWhite(Canvas: TCanvas; X1, Y1, X2, Y2: integer; Color: TColor);
procedure FormControlRect(Canvas: TCanvas; X1: integer;
           Y1: integer; X2: integer; Y2: integer; Raised, PrintMonoBlack, Disabled: boolean; Color: TColor);
function GetXExtent(DC: HDC; P: PWideChar; N: integer): integer;
procedure RaisedRect(SectionList: TFreeList; Canvas: TCanvas; X1: integer;
           Y1: integer; X2: integer; Y2: integer; Raised: boolean; W: integer);
procedure RaisedRectColor(SectionList: TFreeList; Canvas: TCanvas; X1: integer;
           Y1: integer; X2: integer; Y2: integer; Light, Dark: TColor; Raised: boolean;
           W: integer);
function EnlargeImage(Image: TGpObject; W, H: integer): TBitmap;
procedure PrintBitmap(Canvas: TCanvas; X, Y, W, H: integer;
             BMHandle: HBitmap);
procedure PrintBitmap1(Canvas: TCanvas; X, Y, W, H, YI, HI: integer;
             BMHandle: HBitmap);
procedure PrintTransparentBitmap1(Canvas: TCanvas; X, Y, NewW, NewH: integer;
             Bitmap, Mask: TBitmap; YI, HI: integer);
procedure PrintTransparentBitmap3(Canvas: TCanvas; X, Y, NewW, NewH: integer;
             Bitmap, Mask: TBitmap; YI, HI: integer);
procedure DrawGpImage(Handle: THandle; Image: TGPImage; DestX, DestY: integer); overload;
procedure DrawGpImage(Handle: THandle; Image: TGpImage; DestX, DestY,
            SrcX, SrcY, SrcW, SrcH: integer); overload;
procedure StretchDrawGpImage(Handle: THandle; Image: TGpImage; DestX, DestY, DestW, DestH: integer);
procedure PrintGpImageDirect(Handle: THandle; Image: TGpImage; DestX, DestY: integer;
              ScaleX, ScaleY: single);
procedure StretchPrintGpImageDirect(Handle: THandle; Image: TGpImage;
              DestX, DestY, DestW, DestH: integer;
              ScaleX, ScaleY: single);
procedure StretchPrintGpImageOnColor(Canvas: TCanvas; Image: TGpImage;
              DestX, DestY, DestW, DestH: integer; Color: TColor = clWhite);
function htStyles(P0, P1, P2, P3: BorderStyleType): htBorderStyleArray;
function htColors(C0, C1, C2, C3: TColor): htColorArray;
procedure DrawBorder(Canvas: TCanvas; ORect, IRect: TRect; C: htColorArray;
            S: htBorderStyleArray; BGround: TColor; Print: boolean);
function MultibyteToWideString(CodePage: integer; const S: string): WideString;
function WideStringToMultibyte(CodePage: integer; W: WideString): string;   
function GetImageHeight(Image: TGpObject): integer;
function GetImageWidth(Image: TGpObject): integer;

implementation

uses
  {$IFNDEF LCL} jpeg, {$ENDIF} DitherUnit,
  {$ifndef NoOldPng}
     PngImage1,   
  {$endif}
     htmlview, htmlsubs, HtmlGif2, StylePars{$IFNDEF LCL}, ActiveX {$ENDIF};

type
  EGDIPlus = class (Exception);
  TJpegMod = class(TJpegImage)
  public
{$IFNDEF LCL}  //Don't need since TJpegImage is a bitmap.
    property Bitmap;
{$ENDIF}    
  end;

var
  DC: HDC; 

{$IFDEF CPU86}
{----------------StrLenW}
function StrLenW(Str: PWideChar): Cardinal;
{returns number of characters in a string excluding the null terminator}

asm
       MOV     EDX, EDI
       MOV     EDI, EAX
       MOV     ECX, 0FFFFFFFFH
       XOR     AX, AX
       REPNE   SCASW
       MOV     EAX, 0FFFFFFFEH
       SUB     EAX, ECX
       MOV     EDI, EDX

end;

{----------------StrPosW}
function StrPosW(Str, SubStr: PWideChar): PWideChar;
// returns a pointer to the first occurance of SubStr in Str
asm
       PUSH    EDI
       PUSH    ESI
       PUSH    EBX
       OR      EAX, EAX
       JZ      @@2
       OR      EDX, EDX
       JZ      @@2
       MOV     EBX, EAX
       MOV     EDI, EDX
       XOR     AX, AX
       MOV     ECX, 0FFFFFFFFH
       REPNE   SCASW
       NOT     ECX
       DEC     ECX
       JZ      @@2
       MOV     ESI, ECX
       MOV     EDI, EBX
       MOV     ECX, 0FFFFFFFFH
       REPNE   SCASW
       NOT     ECX
       SUB     ECX, ESI
       JBE     @@2
       MOV     EDI, EBX
       LEA     EBX, [ESI - 1]
@@1:
       MOV     ESI, EDX
       LODSW
       REPNE   SCASW
       JNE     @@2
       MOV     EAX, ECX
       PUSH    EDI
       MOV     ECX, EBX
       REPE    CMPSW
       POP     EDI
       MOV     ECX, EAX
       JNE     @@1
       LEA     EAX, [EDI - 2]
       JMP     @@3

@@2:
       XOR     EAX, EAX
@@3:
       POP     EBX
       POP     ESI
       POP     EDI
end;

{----------------StrRScanW}
function StrRScanW(const Str: PWideChar; Chr: WideChar): PWideChar; assembler;
asm
        PUSH    EDI
        MOV     EDI,Str
        MOV     ECX,0FFFFFFFFH
        XOR     AX,AX
        REPNE   SCASW
        NOT     ECX
        STD
        DEC     EDI
        DEC     EDI
        MOV     AX,Chr
        REPNE   SCASW
        MOV     EAX,0
        JNE     @@1
        MOV     EAX,EDI
        INC     EAX
        INC     EAX
@@1:    CLD
        POP     EDI
end;

{----------------StrScanW}
function StrScanW(const Str: PWideChar; Chr: WideChar): PWideChar; assembler;
asm
        PUSH    EDI
        PUSH    EAX
        MOV     EDI,Str
        MOV     ECX,$FFFFFFFF
        XOR     AX,AX
        REPNE   SCASW
        NOT     ECX
        POP     EDI
        MOV     AX,Chr
        REPNE   SCASW
        MOV     EAX,0
        JNE     @@1
        MOV     EAX,EDI
        DEC     EAX
        DEC     EAX
@@1:    POP     EDI
end;

{$ELSE}  //Pascal-ized equivalents of assembler functions.
function StrLenW(Str: PWideChar): Cardinal;
begin
  Result := Length(WideString(Str));
end;

function StrPosW(Str, SubStr: PWideChar): PWideChar;
var
  StrPos    : PWideChar;
  SubstrPos : PWideChar;
begin
  if SubStr^ = #0 then  //Make sure substring not null string
    begin
    Result := nil;
    Exit;
    end;
  Result := Str;
  while Result^ <> #0 do  //Until reach end of string
    begin
    StrPos := Result;
    SubstrPos := SubStr;
    while SubstrPos^ <> #0 do  //Until reach end of substring
      begin
      if StrPos^ <> SubstrPos^ then  //No point in continuing?
        Break;
      StrPos := StrPos + 1;
      SubstrPos := SubstrPos + 1;
      end;
    if SubstrPos^ = #0 then  //Break because reached end of substring?
      Exit;
    Result := Result + 1;
    end;
  Result := nil;
end;

function StrRScanW(const Str: PWideChar; Chr: WideChar): PWideChar;
begin
  Result := StrScanW(Str, #0);
  if Chr = #0 then  //Null-terminating char considered part of string.
    Exit;
  while Result <> Str do
    begin
    Result := Result - 1;
    if Result^ = Chr then
      Exit;
    end;
  Result := nil;
end;

function StrScanW(const Str: PWideChar; Chr: WideChar): PWideChar;
begin
  Result := Str;
  while Result^ <> #0 do
    begin
    if Result^ = Chr then
      Exit;
    Result := Result + 1;
    end;
  if Chr = #0 then
    Exit;  //Null-terminating char considered part of string. See call
           // searching for #0 to find end of string.
  Result := nil;
end;
{$ENDIF}


{----------------FitText}
function FitText(DC: HDC; S: PWideChar; Max, Width: Integer; var Extent: integer): Integer;
  {return count <= Max which fits in Width.  Return X, the extent of chars that fit}

type
//  Integers = array[1..1] of integer;
  Integers = array[1..1000] of Integer;  // LCL port: To avoid range-check error below.
var
  ExtS: TSize;
  Ints: ^Integers;
  L, H, I: integer;
begin
  Extent := 0;
  Result := 0;
  if (Width <= 0) or (Max = 0) then
    Exit;

{$IFDEF MSWINDOWS}  //Only compile if GetTextExtentExPointW exists
if not IsWin32Platform then
  begin
  GetMem(Ints, Sizeof(Integer)* Max);
  try
    {$ifdef ver120_plus}
    if GetTextExtentExPointW(DC, S, Max, Width, @Result, @Ints^, ExtS) then
    {$else}
    if GetTextExtentExPointW(DC, S, Max, Width, Result, Integer(Ints^), ExtS) then
    {$endif}
    if Result > 0 then
      Extent := Ints^[Result]
    else Extent := 0;
  finally
    FreeMem(Ints);
    end;
  end
else       {GetTextExtentExPointW not available in win98, 95}
{$ENDIF}
  begin          {optimize this by looking for Max to fit first -- it usually does}
  L := 0;
  H := Max;
  I := H;
  while L <= H do
    begin
    GetTextExtentPoint32W(DC, S, I, ExtS);
    if ExtS.cx < Width then
      L := I+1
    else H := I-1;
    if ExtS.cx = Width then
      Break;
    I := (L+H) shr 1;
    end;
  Result := I;
  Extent := ExtS.cx;
  end;
end;

{----------------WidePos}
function WidePos(SubStr, S: WideString): Integer;
// Unicode equivalent for Pos() function.
var
  P: PWideChar;
begin
  P := StrPosW(PWideChar(S), PWideChar(SubStr));
  if P = nil then
    Result := 0
  else
    Result := P - PWideChar(S) + 1;
end;

{----------------WideUpperCase1}
function WideUpperCase1(const S: WideString): WideString;
var
  Len, NewLen: Integer;
  Tmp: string;
begin
Len := Length(S);
if not IsWin32Platform then
  begin
  SetString(Result, PWideChar(S), Len);
  if Len > 0 then CharUpperBuffW(Pointer(Result), Len);
  end
else
  begin   {win95,98,ME}
  SetLength(Tmp, 2*Len);
  NewLen := WideCharToMultiByte(CP_ACP, 0, PWideChar(S), Len, PChar(Tmp), 2*Len, Nil, Nil);
  SetLength(Tmp, NewLen);
  Tmp := AnsiUppercase(Tmp);
  SetLength(Result, Len);
  MultibyteToWideChar(CP_ACP, 0, PChar(Tmp), NewLen, PWideChar(Result), Len);
  end;
end;

function WideLowerCase1(const S: WideString): WideString;    
var
  Len, NewLen: Integer;
  Tmp: string;
begin
Len := Length(S);
if not IsWin32Platform then
  begin
  SetString(Result, PWideChar(S), Len);
  if Len > 0 then CharLowerBuffW(Pointer(Result), Len);
  end
else
  begin   {win95,98,ME}
  SetLength(Tmp, 2*Len);
  NewLen := WideCharToMultiByte(CP_ACP, 0, PWideChar(S), Len, PChar(Tmp), 2*Len, Nil, Nil);
  SetLength(Tmp, NewLen);
  Tmp := AnsiLowercase(Tmp);
  SetLength(Result, Len);
  MultibyteToWideChar(CP_ACP, 0, PChar(Tmp), NewLen, PWideChar(Result), Len);
  end;
end;

function WideSameText1(const S1, S2: WideString): boolean;
begin
Result := WideUpperCase1(S1) = WideUpperCase1(S2);
end;

function WideSameStr1(const S1, S2: WideString): boolean;
begin
Result := S1 = S2;
end;

function PosX(const SubStr, S: string; Offset: integer = 1): Integer;  
{find substring in S starting at Offset}
var
  S1: string;
  I: integer;
begin
if Offset <= 1 then
  Result := Pos(SubStr, S)
else
  begin
  S1 := Copy(S, Offset, Length(S)-Offset+1);
  I := Pos(SubStr, S1);
  if I > 0 then
    Result := I+Offset-1
  else Result := 0;
  end;
end;

{$IFDEF CPU86}
function IntMin(A, B: Integer): Integer;
asm
  cmp edx, eax
  jnle @1
  mov eax, edx
@1:
end;

Function IntMax(A, B : Integer) : Integer;
asm
  cmp edx, eax
  jl @1
  mov eax, edx
@1:
end;

{$ELSE}  //Pascal-ized equivalents.
function IntMin(A, B: Integer): Integer;
begin
  if A < B then
    Result := A
  else
    Result := B;
end;

Function IntMax(A, B : Integer) : Integer;
begin
  if A > B then
    Result := A
  else
    Result := B;
end;
{$ENDIF}

procedure GetClippingRgn(Canvas: TCanvas; ARect: TRect; Printing: boolean; var Rgn, SaveRgn: HRgn);    
var
  Point: TPoint;
  SizeV, SizeW: TSize;
  HF, VF: double;
  Rslt: integer;
begin
{find a clipregion to prevent overflow.  First check to see if there is
 already a clip region.  Return the old region, SaveRgn, (or 0) so it can be
 restroed later.}
SaveRgn := CreateRectRgn(0, 0, 1, 1);
Rslt := GetClipRgn(Canvas.Handle, SaveRgn);  {Rslt = 1 for existing region, 0 for none}
if Rslt = 0 then
  begin
  DeleteObject(SaveRgn);
  SaveRgn := 0;
  end;
{Form the region}
GetWindowOrgEx(Canvas.Handle, Point); {when scrolling or animated Gifs, canvas may not start at X=0, Y=0}
with ARect do
  if not Printing then
    Rgn := CreateRectRgn(Left-Point.X, Top-Point.Y, Right-Point.X, Bottom-Point.Y)
  else
    begin
    GetViewportExtEx(Canvas.Handle, SizeV);
    GetWindowExtEx(Canvas.Handle, SizeW);
    HF := (SizeV.cx/SizeW.cx);  {Horizontal adjustment factor}
    VF := (SizeV.cy/SizeW.cy);  {Vertical adjustment factor}
    Rgn := CreateRectRgn(Round(HF*(Left-Point.X)), Round(VF*(Top-Point.Y)), Round(HF*(Right-Point.X)), Round(VF*(Bottom-Point.Y)));
    end;
if Rslt = 1 then {if there was a region, use the intersection with this region}
  CombineRgn(Rgn, Rgn, SaveRgn, Rgn_And);
SelectClipRgn(Canvas.Handle, Rgn);
end;

function HTMLServerToDos(FName, Root: string): string;
{Add Prefix Root only if first character is '\' but not '\\'}
begin
Result := Trim(HTMLToDos(FName));
if (Result <> '') and (Root <> '') then
  begin
{$IFDEF MSWINDOWS}
  if Pos('\\', Result) = 1 then
    Exit;
  if Pos(':', Result) = 2 then
    Exit;
  if Result[1] = '\' then
    Result := Root+Result;
{$ELSE}
  if Result[1] <> '/' then
    Result := Root+Result;
{$ENDIF}
  end;
end;

function HTMLToDos(FName: string): string;
{convert an HTML style filename to one for Dos}
var
  I: integer;

  procedure Replace(Old, New: char);
  var
    I: integer;
  begin
  I := Pos(Old, FName);
  while I > 0 do
    begin
    FName[I] := New;
    I := Pos(Old, FName);
    end;
  end;

  procedure ReplaceEscapeChars;  
  var
    S: string[3];
    I: integer;
  begin
  I := Pos('%', FName);
  while (I > 1) and (I <= Length(FName)-2) do
    begin
    S := '$'+FName[I+1]+FName[I+2];
    try
      FName[I] := chr(StrToInt(S));
      Delete(FName, I+1, 2);
    except   {ignore exception}
      Exit;
      end;
    I := Pos('%', FName);
    end;
  end;

begin
ReplaceEscapeChars; 
I := pos('/', FName);
if I <> 0 then
  begin
  I := Pos('file:///', Lowercase(FName));
  if I > 0 then
    System.Delete(FName, I, 8)
  else
    begin
    I := Pos('file://', Lowercase(FName));
    if I > 0 then
      System.Delete(FName, I, 7)
    else    
      begin
      I := Pos('file:/', Lowercase(FName));
      if I > 0 then
        System.Delete(FName, I, 6);
      end;
    end;
{$IFDEF MSWINDOWS}
  Replace('|', ':');
  Replace('/', '\');
{$ENDIF}
  end;
Result := FName;
end;

function WideTrim(const S: WideString): WideString;
var
  I, L: Integer;
begin
  L := Length(S);
  I := 1;
  while (I <= L) and (S[I] <= ' ') do Inc(I);
  if I > L then
    Result := ''
  else
  begin
    while S[L] <= ' ' do Dec(L);
    Result := Copy(S, I, L - I + 1);
  end;
end;

procedure WrapTextW(Canvas: TCanvas; X1, Y1, X2, Y2: integer; S: WideString);  
{Wraps text in a clipping rectangle. Font must be set on entry}
var
  ARect: TRect;
  TAlign: integer;
begin
TAlign := SetTextAlign(Canvas.Handle, TA_Top or TA_Left);
ARect := Rect(X1, Y1, X2, Y2);
DrawTextW(Canvas.Handle, PWideChar(S), Length(S), ARect, DT_Wordbreak);
SetTextAlign(Canvas.Handle, TAlign);
end;

function Allocate(Size: integer): AllocRec;
begin
Result := AllocRec.Create;
with Result do
  begin
  ASize := Size;
  if Size < $FF00 then
    GetMem(Ptr, Size)
  else
     begin
     AHandle := GlobalAlloc(HeapAllocFlags, Size);
     if AHandle = 0 then
         ABort;
     Ptr := GlobalLock(AHandle);
     end;
  end;
end;

procedure DeAllocate(AR: AllocRec);
begin
with AR do
  if ASize < $FF00 then
    Freemem(Ptr, ASize)
  else
    begin
    GlobalUnlock(AHandle);
    GlobalFree(AHandle);
    end;
AR.Free;
end;

function GetXExtent(DC: HDC; P: PWideChar; N: integer): integer;
var
  ExtS: TSize;
  Dummy: integer;

begin
{$IFDEF MSWINDOWS}  //Only compile if GetTextExtentExPointW exists
if not IsWin32Platform then
  GetTextExtentExPointW(DC, P, N, 0, @Dummy, Nil, ExtS)
else
{$ENDIF}
  GetTextExtentPoint32W(DC, P, N, ExtS);  {win95, 98 ME}
Result := ExtS.cx;
end;

procedure FillRectWhite(Canvas: TCanvas; X1, Y1, X2, Y2: integer; Color: TColor);
var
  OldBrushStyle: TBrushStyle;
  OldBrushColor: TColor;
begin
with Canvas do
  begin
  OldBrushStyle := Brush.Style;   {save style first}
  OldBrushColor := Brush.Color;
  Brush.Color := Color;     
  Brush.Style := bsSolid;
  FillRect(Rect(X1, Y1, X2, Y2));
  Brush.Color := OldBrushColor;
  Brush.Style := OldBrushStyle;    {style after color as color changes style}
  end;
end;

procedure FormControlRect(Canvas: TCanvas; X1: integer;
           Y1: integer; X2: integer; Y2: integer; Raised, PrintMonoBlack, Disabled: boolean; Color: TColor);
{Draws lowered rectangles for form control printing}
var
  OldStyle: TPenStyle;
  OldWid: integer;
  OldBrushStyle: TBrushStyle;
  OldBrushColor: TColor;
  MonoBlack: boolean;
begin
with Canvas do
  begin
  MonoBlack := PrintMonoBlack and (GetDeviceCaps(Handle, BITSPIXEL) = 1) and
          (GetDeviceCaps(Handle, PLANES) = 1);
  Dec(X2);  Dec(Y2);
  OldWid := Pen.Width;
  OldStyle := Pen.Style;
  OldBrushStyle := Brush.Style;   {save style first}
  OldBrushColor := Brush.Color;
  if not MonoBlack and Disabled then  
    Brush.Color := clBtnFace
  else Brush.Color := color;    
  Brush.Style := bsSolid;
  FillRect(Rect(X1, Y1, X2, Y2));
  Brush.Color := OldBrushColor;
  Brush.Style := OldBrushStyle;    {style after color as color changes style}

  Pen.Style := psInsideFrame;
  if MonoBlack then
    begin
    Pen.Width := 1;
    Pen.Color := clBlack;
    end
  else
    begin
    Pen.Width := 2;
    if Raised then Pen.Color := clSilver
      else Pen.Color := clBtnShadow;
    end;
  MoveTo(X1, Y2);
  LineTo(X1, Y1);
  LineTo(X2, Y1);
  if not MonoBlack then
    if Raised then Pen.Color := clBtnShadow
      else Pen.Color := clSilver;
  LineTo(X2, Y2);
  LineTo(X1, Y2);
  Pen.Style := OldStyle;
  Pen.Width := OldWid;
  end;
end;

procedure RaisedRect(SectionList: TFreeList; Canvas: TCanvas; X1: integer;
           Y1: integer; X2: integer; Y2: integer; Raised: boolean; W: integer);
{Draws raised or lowered rectangles for table borders}
var
  White, BlackBorder: boolean;
  Light, Dark: TColor;
begin
with SectionList as TSectionList, Canvas do
  begin
  White := Printing or ((Background and $FFFFFF = clWhite) or
      ((Background = clWindow) and (GetSysColor(Color_Window) = $FFFFFF)));
  BlackBorder := Printing and PrintMonoBlack and (GetDeviceCaps(Handle, BITSPIXEL) = 1) and
      (GetDeviceCaps(Handle, PLANES) = 1);
  end;
if BlackBorder then
  begin
  Light := clBlack;
  Dark := clBlack;
  end
else
  begin
  Dark := clBtnShadow;
  if White then
    Light := clSilver
   else Light := clBtnHighLight;
  end;
RaisedRectColor(SectionList, Canvas, X1, Y1, X2, Y2, Light, Dark, Raised, W);
end;

procedure RaisedRectColor1(Canvas: TCanvas; X1: integer;
           Y1: integer; X2: integer; Y2: integer; Light, Dark: TColor; Raised: boolean);
{Draws single line colored raised or lowered rectangles for table borders}
begin
Y1 := IntMax(Y1, TopLim);
Y2 := IntMin(Y2, BotLim);
with Canvas do
  begin
  if Raised then
    Pen.Color := Light
  else Pen.Color := Dark;

  MoveTo(X1, Y2);
  LineTo(X1, Y1);
  LineTo(X2, Y1);
  if not Raised then
    Pen.Color := Light
  else Pen.Color := Dark;
  LineTo(X2, Y2);
  LineTo(X1, Y2);
  end;
end;

procedure RaisedRectColor(SectionList: TFreeList; Canvas: TCanvas; X1: integer;
           Y1: integer; X2: integer; Y2: integer; Light, Dark: TColor; Raised: boolean;
           W: integer);
{Draws colored raised or lowered rectangles for table borders}
var
  Colors: htColorArray;
begin
if W = 1 then  {this looks better in Print Preview}
  RaisedRectColor1(Canvas, X1, Y1, X2, Y2, Light, Dark, Raised)
else
  begin
  if Raised then
    Colors := htColors(Light, Light, Dark, Dark)
  else Colors := htColors(Dark, Dark, Light, Light);
  DrawBorder(Canvas, Rect(X1-W+1, Y1-W+1, X2+W, Y2+W), Rect(X1+1, Y1+1, X2, Y2), Colors,
              htStyles(bssSolid, bssSolid, bssSolid, bssSolid), clNone, False);
  end;
end;

{$ifdef Ver90}
procedure Assert(B: boolean; const S: string);
begin   {dummy Assert for Delphi 2}
end;
{$endif}

destructor TFreeList.Destroy;
var
  I: integer;
begin
for I := 0 to Count-1 do
  TObject(Items[I]).Free;
inherited Destroy;
end;

procedure TFreeList.Clear;
var
  I: integer;
begin
for I := 0 to Count-1 do
  TObject(Items[I]).Free;
inherited Clear;
end;

constructor TBitmapItem.Create(AImage:TgpObject; AMask: TBitmap; Tr: Transparency);
begin
inherited Create;
MImage := AImage;
Mask := AMask;
AccessCount := 0;
Transp := Tr;
end;

destructor TBitmapItem.Destroy;
begin
Assert(UsageCount = 0, 'Freeing Image still in use'); 
MImage.Free;
Mask.Free;
inherited Destroy;
end;

constructor TStringBitmapList.Create;
begin
inherited Create;
MaxCache := 4;
CheckInitGDIPlus; 
end;

destructor TStringBitmapList.Destroy;
var
  I: integer;
begin
for I := 0 to Count-1 do
  (Objects[I] as TBitmapItem).Free;
CheckExitGDIPlus;  
inherited Destroy;
end;

function TStringBitmapList.AddObject(const S: string; AObject: TObject): Integer;
begin
Result := inherited AddObject(S, AObject);
if AObject is TBitmapItem then
  Inc(TBitmapItem(AObject).UsageCount);
end;

procedure TStringBitmapList.DecUsage(const S: string);
var
  I: integer;
begin
I := IndexOf(S);
if I >= 0 then
  with Objects[I] as TBitmapItem do
    begin
    Dec(UsageCount);
    Assert(UsageCount >= 0, 'Cache image usage count < 0');  
    end;
end;

procedure TStringBitmapList.IncUsage(const S: string);
var
  I: integer;
begin
I := IndexOf(S);
if I >= 0 then
  with Objects[I] as TBitmapItem do
    Inc(UsageCount);
end;

procedure TStringBitmapList.SetCacheCount(N: integer);
var
  I: integer;
begin
for I := Count-1 downto 0 do
  with (Objects[I] as TBitmapItem)do
    begin
    if (AccessCount > N) and (UsageCount <= 0) then     
      begin
      Delete(I);
      Free;
      end;
    end;
MaxCache := N;
end;

function TStringBitmapList.GetImage(I: integer): TgpObject;
begin
with Objects[I] as TBitmapItem do
  begin
  Result := MImage;
  AccessCount := 0;
  Inc(UsageCount);
  end;
end;

procedure TStringBitmapList.BumpAndCheck;
var
  I: integer;
  Tmp: TBitmapItem;
begin
  for I := Count-1 downto 0 do
    begin
    Tmp := (Objects[I] as TBitmapItem);
    with Tmp do
      begin
      Inc(AccessCount);
      if (AccessCount > MaxCache) and (UsageCount <= 0) then
        begin
        Delete(I);
        Free;          {the TBitmapItem}
        end;
      end;
    end;
end;

procedure TStringBitmapList.PurgeCache;
var
  I: integer;
  Tmp: TBitmapItem;
begin
for I := Count-1 downto 0 do
  begin
  Tmp := (Objects[I] as TBitmapItem);
  with Tmp do
    begin
    if (UsageCount <= 0) then
      begin
      Delete(I);
      Free;          {the TBitmapItem}
      end;
    end;
  end;
end;

procedure TStringBitmapList.Clear;
var
  I: integer;
begin
for I := 0 to Count-1 do
  (Objects[I] as TBitmapItem).Free;
inherited Clear;
end;

constructor TAttribute.Create(ASym: Symb; AValue: integer;
           Const NameStr, ValueStr: string; ACodePage: integer);
begin
inherited Create;
Which := ASym;
Value := AValue;
WhichName := NameStr;
Name := ValueStr;
CodePage := ACodePage;
end;

destructor TAttribute.Destroy;
begin
inherited Destroy;
end;

{----------------TAttributeList}
destructor TAttributeList.Destroy;
begin
Prop.Free;
inherited;
end;

procedure TAttributeList.Clear;
begin
SaveID := '';
inherited Clear;
end;

function TAttributeList.Find(Sy: Symb; var T: TAttribute): boolean;
var
  I: integer;
begin
for I := 0 to Count-1 do
  if TAttribute(Items[I]).which = Sy then
    begin
    Result := True;
    T := Items[I];
    Exit;
    end;
Result := False;
end;

function TAttributeList.CreateStringList: TStringList;
var
  I: integer;
begin
Result := TStringList.Create;
for I := 0 to Count-1 do
  with TAttribute(Items[I]) do
    Result.Add(WhichName+'='+Name);
end;

function TAttributeList.GetClass: string;
var
  T: TAttribute;
  S: string;
  I: integer;
begin
Result := '';
if Find(ClassSy, T) then
  begin
  S := Lowercase(Trim(T.Name));
  I := Pos(' ', S);
  if I <= 0 then   {a single class name}
    Result := S
  else
    begin  {multiple class names.  Format as "class1.class2.class3"}
    repeat
      Result := Result + '.' + System.Copy(S, 1, I-1);
      System.Delete(S, 1, I);
      S := Trim(S);
      I := Pos(' ', S);
    until I <= 0;
    Result := Result+'.'+S;
    Result := SortContextualItems(Result);   {put in standard multiple order}
    System.Delete(Result, 1, 1);   {remove initial '.'}
    end;
  end;
end;

function TAttributeList.GetID: string;
var
  T: TAttribute;
begin
Result := SaveID;
if (Result = '') and Find(IDSy, T) then
  begin
  Result := Lowercase(T.Name);
  SaveID := Result;
  end;
end;

function TAttributeList.GetTitle: string;    
var
  T: TAttribute;
begin
if Find(TitleSy, T) then
  Result := T.Name
else Result := '';
end;

function TAttributeList.GetStyle: TProperties;
var
  T: TAttribute;
begin
if Find(StyleSy, T) then
  begin
  Prop.Free;
  Prop := TProperties.Create;
  Result := Prop;
  ParsePropertyStr(T.Name, Result);
  end
else Result := Nil;
end;

{----------------TUrlTarget.Create}
constructor TUrlTarget.Create;
begin
inherited Create;
utText := TutText.Create;
utText.Start := -1;
utText.Last := -1;   
end;

destructor TUrlTarget.Destroy;
begin
FreeAndNil(utText);    
inherited Destroy;
end;

var
  Sequence: integer = 10;

procedure TUrlTarget.Assign(AnUrl, ATarget: String; L: TAttributeList; AStart: integer);   
var
  SL: TStringList;  
begin
Url := AnUrl;
Target := ATarget;
ID := Sequence;
Inc(Sequence);
utText.Start := AStart;
SL := L.CreateStringList;  
try
  Attr := SL.Text;
finally
  SL.Free;
  end;                     
end;

procedure TUrlTarget.Copy(UT: TUrlTarget);
begin
Url := UT.Url;
Target := UT.Target;
ID := UT.ID;
TabIndex := UT.TabIndex;
Attr := UT.Attr;   
utText.Start := UT.utText.Start;
utText.Last := UT.utText.Last;   
end;

procedure TUrlTarget.Clear;
begin
Url := '';
Target := '';
ID := 0;
TabIndex := 0;
Attr := '';
utText.Start := -1;
utText.Last := -1;   
end;

function TUrlTarget.GetStart: integer;  
begin
Result := utText.Start
end;

function TUrlTarget.GetLast: integer;  
begin
Result := utText.Last
end;

procedure TUrlTarget.SetLast(List: TList; ALast: integer);   
var
  I: integer;
begin
utText.Last := ALast;
if (List.Count > 0) then
  for I := List.Count-1 downto 0 do
    if (ID = TFontObj(List[I]).UrlTarget.ID) then
      TFontObj(List[I]).UrlTarget.utText.Last := ALast
    else Break;
end;

{----------------SelTextCount}
procedure SelTextCount.AddText(P: PWideChar; Size: integer);
var
  I: integer;
begin
for I := 0 to Size-1 do
  if not (P[I] in [FmCtl, ImgPan]) then {ImgPan and FmCtl used to mark images, form controls}
    Inc(Leng);
end;

procedure SelTextCount.AddTextCR(P: PWideChar; Size: integer);
begin
AddText(P, Size);
AddText(#13#10, 2);
end;

function SelTextCount.Terminate: integer;
begin
Result := Leng;  
end;

{----------------SelTextBuf.Create}
constructor SelTextBuf.Create(ABuffer: PWideChar; Size: integer);
begin
inherited Create;
Buffer := ABuffer;
BufferLeng := Size;
end;

procedure SelTextBuf.AddText(P: PWideChar; Size: integer);
var
  SizeM1 : integer;
  I: integer;
begin
SizeM1 := BufferLeng-1;
for I := 0 to Size-1 do
  if not (P[I] in [FmCtl, ImgPan, BrkCh]) then {ImgPan and FmCtl used to mark images, form controls}
    if Leng < SizeM1 then
      begin
      Buffer[Leng] := P[I];
      Inc(Leng);
      end;
end;

function SelTextBuf.Terminate: integer;
begin
Buffer[Leng] := #0;
Result := Leng+1;
end;

{----------------ClipBuffer.Create}
constructor ClipBuffer.Create(Leng: integer);   
begin
inherited Create(Nil, 0);
BufferLeng := Leng;
Getmem(Buffer, BufferLeng*2);
end;

destructor ClipBuffer.Destroy;
begin
if Assigned(Buffer) then FreeMem(Buffer);  
inherited Destroy;
end;

procedure ClipBuffer.CopyToClipboard;   
{$IFNDEF LCL}
{Unicode clipboard routine courtesy Mike Lischke}
var
  Data: THandle;
  DataPtr: Pointer;
begin
  Data := GlobalAlloc(GMEM_MOVEABLE + GMEM_DDESHARE, 2 * BufferLeng);
  try
    DataPtr := GlobalLock(Data);
    try
      Move(Buffer^, DataPtr^, 2 * BufferLeng);
      Clipboard.SetAsHandle(CF_UNICODETEXT, Data);
    finally
      GlobalUnlock(Data);
    end;
  except
    GlobalFree(Data);
    raise;
  end;
{$ELSE}
var
  Utf8Str : string;
begin
  Utf8Str := WideCharLenToString(Buffer, BufferLeng);
  Clipboard.AddFormat(CF_TEXT, Utf8Str[1], Length(Utf8Str));
{$ENDIF}
end;

function ClipBuffer.Terminate: integer;
begin
Buffer[Leng] := #0;
Result := Leng+1;
if IsWin32Platform then
  Clipboard.AsText := Buffer  
else
  CopyToClipboard;
end;

{----------------TMapItem.Create}
constructor TMapItem.Create;
begin
inherited Create;
Areas := TStringList.Create;
AreaTargets := TStringList.Create;
AreaTitles := TStringList.Create;  
end;

destructor TMapItem.Destroy;
var
  I: integer;
begin
for I := 0 to Areas.Count-1 do
  DeleteObject(THandle(Areas.Objects[I]));
Areas.Free;
AreaTargets.Free;
AreaTitles.Free;    
inherited Destroy;
end;

function TMapItem.GetURL(X, Y: integer; var URLTarg: TUrlTarget; var ATitle: string): boolean;  
var
  I: integer;
begin
Result := False;
with Areas do
  for I := 0 to Count-1 do
    if PtInRegion(THandle(Objects[I]), X, Y) then
      begin
      if Strings[I] <> '' then  {could be NoHRef}    
        begin
        URLTarg := TUrlTarget.Create;
        URLTarg.URL := Strings[I];
        URLTarg.Target := AreaTargets[I];
        ATitle := AreaTitles[I];   
        Result := True;
        end;
      Exit;
      end;
end;

procedure TMapItem.AddArea(Attrib: TAttributeList);
Const
  MAXCNT = 300;  
var
  I, Cnt, Rad: integer;
  HRef, S, Target, Title: string;   
  S1, Nm: string[20];
  Coords: array[0..MAXCNT] of integer;
  Rect: TRect absolute Coords;
  Handle: THandle;
  Shape: (Rec, Circle, Poly);

  procedure GetSubStr;    
  var
    J,K: integer;
  begin
  J := Pos(',', S);
  K := Pos(' ', S);   {for non comma situations (bad syntax)}
  if (J > 0) and ((K = 0) or (K > J)) then
    begin
    S1 := copy(S, 1, J-1);
    Delete(S, 1, J);
    end
  else if K > 0 then
    begin
    S1 := copy(S, 1, K-1);
    Delete(S, 1, K);
    end
  else
    begin
    S1 := Trim(S);
    S := '';
    end;
  while (Length(S) > 0) and ((S[1]=',') or (S[1]=' ')) do
    Delete(S, 1, 1);
  end;

begin
if Areas.Count >= 1000 then  
  Exit;
HRef := '';
Target := '';
Title := '';
Shape := Rec;
Cnt := 0;
Handle := 0;
for I := 0 to Attrib.Count-1 do
  with TAttribute(Attrib[I]) do
    case Which of
      HRefSy:  HRef := Name;
      TargetSy:  Target := Name;
      TitleSy:  Title := Name;    
      NoHrefSy: HRef := '';
      CoordsSy:
        begin
        S := Trim(Name);
        Cnt := 0;
        GetSubStr;
        while (S1 <> '') and (Cnt <= MAXCNT) do
          begin
          Coords[Cnt] := StrToIntDef(S1, 0);
          GetSubStr;
          Inc(Cnt);
          end;
        end;
      ShapeSy:
        begin
        Nm := copy(Lowercase(Name),1, 4);
        if Nm = 'circ' then Shape := Circle
        else if (Nm = 'poly') then Shape := Poly;
        end;
      end;
case Shape of
  Rec:
    begin
    if Cnt < 4 then Exit;
    Inc(Coords[2]);
    Inc(Coords[3]);
    Handle := CreateRectRgnIndirect(Rect);
    end;
  Circle:
    begin
    if Cnt < 3 then Exit;
    Rad := Coords[2];
    Dec(Coords[0],Rad);
    Dec(Coords[1],Rad);
    Coords[2] := Coords[0] + 2*Rad +1;
    Coords[3] := Coords[1] + 2*Rad +1;
    Handle := CreateEllipticRgnIndirect(Rect);
    end;
  Poly:
    begin
    if Cnt < 6 then Exit;
{$IFNDEF LCL}
    Handle := CreatePolygonRgn(Coords, Cnt div 2, Winding);
{$ELSE}
    Handle := CreatePolygonRgn(PPoint(@Coords), Cnt div 2, Winding);
{$ENDIF}    
    end;
  end;
if Handle <> 0 then
  begin
  Areas.AddObject(HRef, TObject(Handle));
  AreaTargets.Add(Target);
  AreaTitles.Add(Title);    
  end;
end;

function KindOfImageFile(FName: String): ImageType;
var
  Mem: TMemoryStream;
begin
Result := NoImage;
if FileExists(FName) then
  begin
  Mem := TMemoryStream.Create;
  try
    Mem.LoadFromFile(FName);
    if Mem.Size >=10 then
      Result := KindOfImage(Mem.Memory);
  finally
    Mem.Free;
    end;
  end;
end;

function KindOfImage(Start: Pointer): ImageType;
type
  ByteArray = array[0..10] of byte;
var
  PB: ^ByteArray absolute Start;
  PW: ^Word absolute Start;
  PL: ^DWord absolute Start;
begin
if PL^ = $38464947 then
  begin
  if PB^[4] = Ord('9') then Result := Gif89
  else Result := Gif;
  end
else if PW^ = $4D42 then Result := Bmp
else if PL^ = $474E5089 then Result := Png
else if PW^ = $D8FF then Result := Jpg
else Result := NoImage;
end;

{$A-} {record field alignment off for this routine}

function IsTransparent(Stream: TStream; var Color: TColor): boolean;
{Makes some simplifying assumptions that seem to be generally true for single
 images.}
Type
  RGB = record
    Red, Green, Blue: byte;
    end;

  GifHeader = record
    GIF: array[0..2] of char;
    Version: array[0..2] of char;
    ScreenWidth, ScreenHeight: Word;
    Field: Byte;
    BackGroundColorIndex: byte;
    AspectRatio: byte;
    end;
  ColorArray = array[0..255] of RGB;

var
  Header: ^GifHeader;
  X: integer;
  Colors: ^ColorArray;
  Buff: array[0..Sizeof(GifHeader)+Sizeof(ColorArray)+8] of byte;
  P: PChar;
  OldPosition: integer;

begin
Result := False;
Fillchar(Buff, Sizeof(Buff), 0);  {in case read comes short}
OldPosition := Stream.Position;
Stream.Position := 0;
Stream.Read(Buff, Sizeof(Buff));
Stream.Position := OldPosition;

Header := @Buff;
if KindOfImage(Header) <> Gif89 then Exit; 
Colors := @Buff[Sizeof(GifHeader)];
with Header^ do
  begin
  X := 1 shl ((Field and 7) +1) - 1;  {X is last item in color table}
  if X = 0 then Exit;   {no main color table}
  end;
P := PChar(Colors)+(X+1)*Sizeof(RGB);
if (P^ <> #$21) or ((P+1)^ <> #$F9) then Exit;  {extension block not found}
if (ord(P[3]) and 1 <> 1) then Exit;     {no transparent color specified}

with Colors^[Ord(P[6])] do
  Color := integer(Blue) shl 16 or integer(Green) shl 8 or integer(Red);
Result := True;
end;

{$A+}


{$A-} {record field alignment off for this routine}


function IsTransparentPng(Stream: TStream; var Color: TColor): boolean;
Type
  RGB = record
    Red, Green, Blue: byte;
    end;

  PngHeader = record
    width       : integer;
    height      : integer;
    bitDepth    : byte;
    colorType   : byte;
    compression : byte;
    filter      : byte;
    interlace   : byte;
    end;
var
  Header: PngHeader;
  CRC: integer;
  OldPosition: integer;
  pngPalette: array[0..255] of RGB;
  dataSize : integer;
  chunkType: array[0..4] of Char;
  chunkTypeStr: string;
  done : Boolean;
  Ar: Array[0..10] of byte;
  Alpha: array[0..255] of byte;   
  I: integer;

  function IntSwap(data: integer): integer;
  var
     byte0 : integer;
     byte1 : integer;
     byte2 : integer;
     byte3 : integer;
  begin
     byte0 := data and $FF;
     byte1 := (data shr 8) and $FF;
     byte2 := (data shr 16) and $FF;
     byte3 := (data shr 24) and $FF;

     result := (byte0 shl 24) or (byte1 shl 16) or (byte2 shl 8) or byte3;
  end;

begin
result := false;
OldPosition := Stream.Position;

try
   Stream.Position := 0;
   Stream.Read(Ar, 8);

   if KindOfImage(@Ar) <> Png then
     begin
     Stream.Position := OldPosition;
     Exit;
     end;

   Stream.Position := 8; {past the PNG Signature}
   done := False;

{Read Chunks}
   repeat
      Stream.Read(dataSize, 4);
      dataSize := IntSwap(dataSize);
      Stream.Read(chunkType, 4);
      chunkType[4] := #0; {make sure string is NULL terminated}
      chunkTypeStr := StrPas(chunkType);
      if chunkTypeStr = 'IHDR' then
      begin
         Stream.Read(Header, DataSize);
         Header.width := IntSwap(Header.width);
         Header.height := IntSwap(Header.height);
         Stream.Read(CRC, 4); {read it in case we need to read more}
         if (Header.colorType < 2) or (Header.colorType > 3) then
            done := True; {only type 2 and 3 use tRNS}
      end
      else if chunkTypeStr = 'PLTE' then
      begin
         Stream.Read(pngPalette, DataSize);
         Stream.Read(CRC, 4); {read it in case we need to read more}
      end
      else if chunkTypeStr =  'tRNS' then
        begin
        if Header.colorType = 3 then
          begin
          {there can be DataSize transparent or partial transparent colors.  We only accept one fully transparent color}
          Stream.Read(Alpha, DataSize);   
          for I := 0 to DataSize -1 do
            if Alpha[I] = 0 then  {0 means full transparency}   
              begin
              with pngPalette[I] do
                Color := integer(Blue) shl 16 or integer(Green) shl 8 or integer(Red);
              Result := True;
              break;
              end;
          end
        else  {has to have been 2}
          begin
            {for now I am ignoring this since I can't make one}
          end;
        done := true; {got everything we need at this point}
        end
      else if chunkTypeStr = 'IDAT' then
         done := True {if this chunk is hit there is no tRNS}
      else
         Stream.Position := Stream.Position + dataSize + 4; {additional 4 for the CRC}
      if Stream.Position >= Stream.Size then  
         Done := True;
   until done = True;
except
   end;

Stream.Position := OldPosition;
end;

{$A+}

function TransparentGIF(const FName: string; var Color: TColor): boolean;
{Looks at a GIF image file to see if it's a transparent GIF.}
{Needed for OnBitmapRequest Event handler}
var
  Stream: TFileStream;
begin
Result := False;
try
  Stream := TFileStream.Create(FName, fmShareDenyWrite or FmOpenRead);
  try
    Result := IsTransparent(Stream, Color);
  finally
    Stream.Free;
  end;
except
  end;
end;

function ConvertImage(Bitmap: TBitmap): TBitmap;
{convert bitmap into a form for BitBlt later}
  function DIBConvert: TBitmap;
  var
    DC: HDC;
    DIB: TDib;
    OldBmp: HBitmap;
    OldPal: HPalette;
    Hnd: HBitmap;
  begin
  DC := CreateCompatibleDC(0);
  OldBmp := SelectObject(DC, Bitmap.Handle);
  OldPal := SelectPalette(DC, ThePalette, False);
  RealizePalette(DC);
  DIB := TDib.CreateDIB(DC, Bitmap);
  Hnd := DIB.CreateDIBmp;
  DIB.Free;
  SelectPalette(DC, OldPal, False);
  SelectObject(DC, OldBmp);
  DeleteDC(DC);
  Bitmap.Free;
  Result := TBitmap.Create;
  Result.Handle := Hnd;
  if (ColorBits = 8) and (Result.Palette = 0) then  
    Result.Palette := CopyPalette(ThePalette);
  end;

begin
if not Assigned(Bitmap) then
  begin
  Result := Nil;
  Exit;
  end;

if ColorBits > 8 then
  begin
  if Bitmap.PixelFormat <= pf8bit then
    Result := DIBConvert
  else
    Result := Bitmap;
  Exit;
  end;

if Bitmap.HandleType = bmDIB then
  begin
  Result := GetBitmap(Bitmap);
  Bitmap.Free;
  Exit;
  end;
Result := DIBConvert;
end;

{----------------GetImageAndMaskFromFile}
function GetImageAndMaskFromFile(const Filename: String; var Transparent: Transparency;
                            var Mask: TBitmap): TgpObject;
var
  Stream: TMemoryStream;   
begin
Result := Nil;
Mask := Nil;
if not FileExists(Filename) then Exit;
if GDIPlusActive and (KindOfImageFile(Filename) = Png) then
  begin
  Result := TObject(TGPBitmap.Create(Filename));
  end
else
  begin
  Stream := TMemoryStream.Create;
  Stream.LoadFromFile(Filename);
  try
    Result := GetImageAndMaskFromStream(Stream, Transparent, Mask);
  finally
    Stream.Free;
    end;
  end;
end;

{----------------GetBitmapAndMaskFromStream}
function GetBitmapAndMaskFromStream(Stream: TMemoryStream;
        var Transparent: Transparency; var AMask: TBitmap): TBitmap;
var
  IT: ImageType;
  jpImage: TJpegMod;
  {$ifndef NoOldPng}
  PI: TPngImage;
  Color: TColor;
  Tmp: TBitmap;
  {$endif}             
begin
Result := Nil;
AMask := Nil;
if not Assigned(Stream) or (Stream.Memory = Nil) or (Stream.Size < 20) then
  Exit;
Stream.Position := 0;
IT := KindOfImage(Stream.Memory);

if not (IT in [Bmp, Jpg, Png]) then
  Exit;

Result := TBitmap.Create;
try
  if IT = Jpg then
    begin
    Transparent := NotTransp;
    jpImage := TJpegMod.Create;
    try
      jpImage.LoadFromStream(Stream);
      if ColorBits <= 8 then
        begin
{$IFNDEF LCL}
        jpImage.PixelFormat := jf8bit;
{$ELSE}
        jpImage.PixelFormat := pf8bit;
{$ENDIF}      
        if not jpImage.GrayScale and (ColorBits = 8) then
          jpImage.Palette := CopyPalette(ThePalette);
        end
{$IFNDEF LCL}
      else jpImage.PixelFormat := jf24bit;
      Result.Assign(jpImage.Bitmap);
{$ELSE}
      else jpImage.PixelFormat := pf24bit;
      Result.Assign(jpImage);
{$ENDIF}      
    finally
      jpImage.Free;                                                 
      end;
    end
  {$ifndef NoOldPng}
  else if IT = Png then
    begin
    if IsTransparentPNG(Stream, Color) then  {check for transparent PNG}
      Transparent := TPng;   
    PI := TPngImage.Create;
    try
     PI.LoadFromStream(Stream);
     Result.Assign(PI);
     if Result.Handle <> 0 then;      {force proper initiation win98/95}
    finally
     PI.Free;
     end;
    end
  {$else}
  else if IT = Png then
    Result := Nil
  {$endif}
  else
    begin
    Result.LoadFromStream(Stream);   {Bitmap}
    end;
  if Transparent = LLCorner then
    AMask := GetImageMask(Result, False, 0)
  {$ifdef NoOldPng}
     ;
  {$else}
  else if Transparent = TPng then
    begin
    AMask := GetImageMask(Result, True, Color);
    {Replace the background color with black.  This is needed if the Png is a
     background image.}
    Tmp := Result;
    Result := TBitmap.Create;
    Result.Width := Tmp.Width;
    Result.Height := Tmp.Height;
    Result.Palette := CopyPalette(ThePalette);
    with Result do
      begin
      Canvas.Brush.Color := Color;
      PatBlt(Canvas.Handle, 0, 0, Width, Height, PatCopy);
      SetBkColor(Canvas.Handle, clWhite);
      SetTextColor(Canvas.Handle, clBlack);
      BitBlt(Canvas.Handle, 0, 0, Width, Height, AMask.Canvas.Handle, 0, 0, SrcAnd);
      BitBlt(Canvas.Handle, 0, 0, Width, Height, Tmp.Canvas.Handle, 0, 0, SrcInvert);
      end;
    Tmp.Free;
    end;
  {$endif}
  Result := ConvertImage(Result);
except
  Result.Free;
  Result := Nil;
  end;
end;

var
  Unique: integer = 183902;

{----------------GetImageAndMaskFromStream}
function GetImageAndMaskFromStream(Stream: TMemoryStream;
        var Transparent: Transparency; var AMask: TBitmap): TgpObject;
var
  Filename: string;
  Path: array[0..Max_Path] of char;
  F: File;
  I: integer;
begin
Result := Nil;
AMask := Nil;
if not Assigned(Stream) or (Stream.Memory = Nil) or (Stream.Size < 20) then
  Exit;
Stream.Position := 0;
if GDIPlusActive and (KindOfImage(Stream.Memory) = png) then
  begin
  try
    GetTempPath(Max_Path, @Path);
    SetLength(Filename, Max_Path+1);
    GetTempFilename(@Path, 'png', Unique, PChar(Filename));
    Inc(Unique);
    I := Pos(#0, Filename);
    SetLength(Filename, I-1);
    AssignFile(F, Filename);
    ReWrite(F, 1);
    BlockWrite(F, Stream.Memory^, Stream.Size);
    CloseFile(F);
    Result := TgpImage.Create(Filename, True);  {True because it's a temporary file}
    Transparent :=  NotTransp;
  except
    end;
  Exit;
  end;

Result := GetBitmapAndMaskFromStream(Stream, Transparent, AMask);
{$ifndef NoMetafile}
if not Assigned(Result) then
  begin
  Result := ThtMetafile.Create;
  try
    AMask := Nil;
    Transparent := NotTransp;
    ThtMetaFile(Result).LoadFromStream(Stream);
  except
    FreeAndNil(Result);
    end;
  end;
{$endif}
end;

function GetImageMask(Image: TBitmap; ColorValid: boolean; AColor: TColor): TBitmap;
begin
try
  if ColorValid then
    Image.TransparentColor := AColor;  {color has already been selected}
  {else the transparent color is the lower left pixel of the bitmap}

  Image.Transparent := True;

  Result := TBitmap.Create;
  try
    Result.Handle := Image.ReleaseMaskHandle;
    Image.Transparent := False;
  except
    FreeAndNil(Result);
    end;
except
  Result := Nil;
  end;
end;

function GetImageFromFile(const Filename: String): TBitmap; 
{used only externally in OnBitmapRequest handler}
var
  IT: ImageType;
  Mask: TBitmap;
  Transparent: Transparency;
  Stream: TMemoryStream;
  GpObj: TGpObject;

  function GetGif: TBitmap;
  var
    TmpGif: TGifImage;
    NonAnimated: boolean;
  begin
  Result := Nil;
  TmpGif := CreateAGifFromStream(NonAnimated, Stream);
  if Assigned(TmpGif) then
    begin
    Result := TBitmap.Create;
    try
//{$IFNDEF LCL}
      Result.Assign(TmpGif.Bitmap);
//{$ENDIF}
    except
      Result.Free;
      Result := Nil;
      end;
    TmpGif.Free;
    end
  end;

begin
Result := Nil;
try
  Stream := TMemoryStream.Create;
  try
    Stream.LoadFromFile(Filename);
    IT := KindOfImage(Stream.Memory);
    if IT in [Gif, Gif89] then
      Result := GetGif
    else
      begin
      GpObj := GetImageAndMaskFromStream(Stream, Transparent, Mask);
      Mask.Free;
      if GpObj is TBitmap then
        Result := TBitmap(GpObj)
{$ifndef NoMetafile}
      else if GpObj is ThtMetafile then
        begin
        Result := TBitmap.Create;
        Result.Assign(ThtMetafile(GpObj).WhiteBGBitmap);
        GpObj.Free;
        end
{$endif}
      else if GpObj is TGpImage then
        begin
        Result := TBitmap.Create;
        Result.Assign(TGpImage(GpObj).GetTBitmap);
        GpObj.Free;
        end;
      end;
  finally
    Stream.Free;
    end;
except
  Result := Nil;
  end;
end;

{----------------FinishTransparentBitmap }
procedure FinishTransparentBitmap (ahdc: HDC;
              InImage, Mask: TBitmap; xStart, yStart, W, H: integer);
var
  bmAndBack,
  bmSave,
  bmBackOld,
  bmObjectOld : HBitmap;
  hdcInvMask,
  hdcMask,
  hdcImage: HDC;
  DestSize, SrcSize : TPoint;
  OldBack, OldFore: TColor;
{$IFNDEF LCL}
  BM: Windows.TBitmap;
{$ELSE}  
  BM: LclType.BITMAP;
{$ENDIF}
{$IFNDEF MSWINDOWS}
  ColorMask : TBitmap;
  ColorMaskIntfImg : TLazIntfImage;
  MaskIntfImg : TLazIntfImage;
{$ENDIF}
  Image: TBitmap;

begin
Image := TBitmap.Create;  {protect original image} 
try
  Image.Assign(InImage);

  hdcImage := CreateCompatibleDC (ahdc);
  SelectObject (hdcImage, Image.Handle); { select the bitmap }

  { convert bitmap dimensions from device to logical points}
  SrcSize.x := Image.Width;
  SrcSize.y := Image.Height;
  DPtoLP(hdcImage, SrcSize, 1);

  DestSize.x := W;
  DestSize.y := H;
  DPtoLP (hdcImage, DestSize, 1);

  { create a bitmap for each DC}
  { monochrome DC}
{$IFDEF MSWINDOWS}
  bmAndBack := CreateBitmap (SrcSize.x, SrcSize.y, 1, 1, nil);
{$ELSE}
   // LCL port: Both Carbon and GTK2 widgetsets have trouble with
   //  monochrome bitmaps, so create bitmap with same color format
   //  for mask inverse and also convert mask to color format.
  bmAndBack := CreateCompatibleBitmap(ahdc, SrcSize.x, SrcSize.y);
  ColorMask := TBitmap.Create;
  ColorMask.Width := Mask.Width;
  ColorMask.Height := Mask.Height;
  ColorMask.PixelFormat := Image.PixelFormat;
  ColorMaskIntfImg := ColorMask.CreateIntfImage;
  MaskIntfImg := Mask.CreateIntfImage;
  ColorMaskIntfImg.CopyPixels(MaskIntfImg);
  ColorMask.LoadFromIntfImage(ColorMaskIntfImg);
  ColorMaskIntfImg.Free;
  MaskIntfImg.Free;
{$ENDIF}

  bmSave := CreateCompatibleBitmap (ahdc, DestSize.x, DestSize.y);
  GetObject(bmSave, SizeOf(BM), @BM);
  if (BM.bmBitsPixel > 1) or (BM.bmPlanes > 1) then
    begin
    { create some DCs to hold temporary data}
    hdcInvMask   := CreateCompatibleDC(ahdc);
    hdcMask := CreateCompatibleDC(ahdc);

    { each DC must select a bitmap object to store pixel data}
    bmBackOld   := SelectObject (hdcInvMask, bmAndBack);

    { set proper mapping mode}
    SetMapMode (hdcImage, GetMapMode (ahdc));

{$IFDEF MSWINDOWS}
    bmObjectOld := SelectObject(hdcMask, Mask.Handle);
{$ELSE}
    bmObjectOld := SelectObject(hdcMask, ColorMask.Handle);
{$ENDIF}

    { create the inverse of the object mask}
    BitBlt (hdcInvMask, 0, 0, SrcSize.x, SrcSize.y, hdcMask, 0, 0, NOTSRCCOPY);

    {set the background color of the source DC to the color contained in the
     parts of the bitmap that should be transparent, the foreground to the parts that
     will show}
    OldBack := SetBkColor(ahDC, clWhite);
    OldFore := SetTextColor(ahDC, clBlack);

    { Punch out a black hole in the background where the image will go}
    SetStretchBltMode(ahDC, WhiteOnBlack);
    StretchBlt (ahDC, XStart, YStart, DestSize.x, DestSize.y, hdcMask, 0, 0, SrcSize.x, SrcSize.y, SRCAND);

    { mask out the transparent colored pixels on the bitmap}
    BitBlt (hdcImage, 0, 0, SrcSize.x, SrcSize.y, hdcInvMask, 0, 0, SRCAND);

    { XOR the bitmap with the background on the destination DC}
    SetStretchBltMode(ahDC, ColorOnColor);
    StretchBlt(ahDC, XStart, YStart, W, H, hdcImage, 0, 0, Image.Width, Image.Height, SRCPAINT);

    SetBkColor(ahDC, OldBack);
    SetTextColor(ahDC, OldFore);

    { delete the memory bitmaps}
    DeleteObject (SelectObject (hdcInvMask, bmBackOld));
    SelectObject (hdcMask, bmObjectOld);

    { delete the memory DCs}
    DeleteDC (hdcInvMask);
    DeleteDC (hdcMask);
    end
  else
    begin
    DeleteObject(bmAndBack);
    end;
  DeleteObject(bmSave);     
  DeleteDC (hdcImage);
{$IFNDEF MSWINDOWS}
  ColorMask.Free;
{$ENDIF}
finally
  Image.Free;
  end;
end;

{----------------TDib.CreateDIB}
constructor TDib.CreateDIB(DC: HDC; Bitmap: TBitmap);
{given a TBitmap, construct a device independent bitmap}
var
  ImgSize: DWord;
begin
InitializeBitmapInfoHeader(Bitmap.Handle);
ImgSize := Info^.biSizeImage;
Allocate(ImgSize);
try
  GetDIBX(DC, Bitmap.Handle, Bitmap.Palette);
except
  DeAllocate;
  Raise;
  end;
end;

destructor TDib.Destroy;
begin
DeAllocate;
inherited Destroy;
end;

procedure TDib.Allocate(Size: integer);
begin
ImageSize := Size;
if Size < $FF00 then
  GetMem(Image, Size)
else
   begin
   FHandle := GlobalAlloc(HeapAllocFlags, Size);
   if FHandle = 0 then
       ABort;
   Image := GlobalLock(FHandle);
   end;
end;

procedure TDib.DeAllocate;
begin
if ImageSize > 0 then
  begin
  if ImageSize < $FF00 then
    Freemem(Image, ImageSize)
  else
    begin
    GlobalUnlock(FHandle);
    GlobalFree(FHandle);
    end;
  ImageSize := 0;
  end;
if InfoSize > 0 then
  begin
  FreeMem(Info, InfoSize);
  InfoSize := 0;
  end;
end;

procedure TDib.InitializeBitmapInfoHeader(Bitmap: HBITMAP);
var
{$IFNDEF LCL}
  BM: Windows.TBitmap;
{$ELSE}  
  BM: LclType.BITMAP;
{$ENDIF}  
  BitCount: integer;

   function WidthBytes(I: integer): integer;
   begin
     Result := ((I + 31) div 32) * 4;
   end;

begin
GetObject(Bitmap, SizeOf(BM), @BM);
BitCount := BM.bmBitsPixel * BM.bmPlanes;
if BitCount > 8 then
  InfoSize := SizeOf(TBitmapInfoHeader)
else
  InfoSize := SizeOf(TBitmapInfoHeader) + SizeOf(TRGBQuad) * (1 shl BitCount);  
GetMem(Info, InfoSize);

with Info^ do
  begin
  biSize := SizeOf(TBitmapInfoHeader);
  biWidth := BM.bmWidth;
  biHeight := BM.bmHeight;
  biBitCount := BM.bmBitsPixel * BM.bmPlanes;
  biPlanes := 1;
  biXPelsPerMeter := 0;
  biYPelsPerMeter := 0;
  biClrUsed := 0;
  biClrImportant := 0;
  biCompression := BI_RGB;
  if biBitCount in [16, 32] then
    biBitCount := 24;
  biSizeImage := WidthBytes(biWidth * biBitCount) * biHeight;
  end;
end;

procedure TDib.GetDIBX(DC: HDC; Bitmap: HBITMAP; Palette: HPALETTE);
var
  OldPal: HPALETTE;
  Rslt: integer;
  bmInfo: PBitmapInfo;
begin
  OldPal := 0;
  if Palette <> 0 then
    begin
    OldPal := SelectPalette(DC, Palette, False);
    RealizePalette(DC);
    end;
  bmInfo := PBitmapInfo(Info);
  Rslt := GetDIBits(DC, Bitmap, 0, Info^.biHeight, Image, bmInfo^, DIB_RGB_COLORS);
  if OldPal <> 0 then
    SelectPalette(DC, OldPal, False);
  if Rslt = 0 then
    begin
    OutofMemoryError;
    end;
end;

procedure TDib.DrawDIB(DC: HDC; X: Integer; Y: integer; W, H: integer;
          ROP: DWord);
var
  bmInfo: PBitmapInfo;
begin
bmInfo := PBitmapInfo(Info);
with Info^ do
  StretchDIBits(DC, X, Y, W, H, 0, 0, biWidth, biHeight, Image,
      bmInfo^, DIB_RGB_COLORS, ROP);
end;

function TDib.CreateDIBmp: hBitmap;
var
  bmInfo: PBitmapInfo;
  DC: HDC;
  OldPal: HPalette;
begin
bmInfo := PBitmapInfo(Info);
DC := GetDC(0);
OldPal := SelectPalette(DC, ThePalette, False);
RealizePalette(DC);
try
  Result := CreateDIBitmap(DC, bmInfo^.bmiHeader, CBM_INIT, Image,
            bmInfo^, DIB_RGB_COLORS);
finally
  SelectPalette(DC, OldPal, False);
  ReleaseDC(0, DC);
  end;
end;

{----------------IndentManagerBasic.Create}
constructor IndentManagerBasic.Create;
begin
inherited Create;
R := TFreeList.Create;
L := TFreeList.Create;
end;

destructor IndentManagerBasic.Destroy;
begin
R.Free;
L.Free;
inherited Destroy;
end;

procedure IndentManagerBasic.Clear;
begin
R.Clear;
L.Clear;
CurrentID := Nil;
end;

{----------------IndentManagerBasic.Reset}
procedure IndentManagerBasic.Reset(Lf, Rt: integer);
begin
LfEdge := Lf;
RtEdge := Rt;
CurrentID := Nil;
end;

procedure IndentManagerBasic.UpdateTable(Y: integer; IW: integer; IH: integer;
                           Justify: JustifyType);
{Given a floating table, update the edge information. }
var
  IR: IndentRec;
begin
  IR := IndentRec.Create;
  if (Justify = Left) then
    begin
    with IR do
      begin
      X := -LfEdge + IW;
      YT := Y;
      YB := Y + IH;
      L.Add(IR);
      end;
    end
  else if (Justify = Right) then
    begin
    with IR do
      begin
      X := RightSide(Y) - IW;
      YT := Y;
      YB := Y + IH;
      R.Add(IR);
      end;
    end;
end;

const
  BigY = 9999999;

function IndentManagerBasic.LeftIndent(Y: integer): integer;
var
  I: integer;
begin
Result := -99999;
for I := 0 to L.Count-1 do
  with IndentRec(L.Items[I]) do
    begin
    if (Y >= YT) and (Y < YB) and (Result < X) then
      if not Assigned(ID) or (ID = CurrentID) then
        Result := X;
    end;
if Result = -99999 then  
  Result := 0;
Inc(Result, LfEdge);
end;

function IndentManagerBasic.RightSide(Y: integer): integer;
{returns the current right side dimension as measured from the left, a positive
 number}
var
  I: integer;
  IR: IndentRec;
begin
Result := 99999;
for I := 0 to R.Count-1 do
  begin
  IR := IndentRec(R.Items[I]);
  with IR do
    if (Y >= YT) and (Y < YB) and (Result > X) then
      if not Assigned(ID) or (ID = CurrentID) then
        Result := X;
  end;
if Result = 99999 then
  Result := RtEdge     
else Inc(Result, LfEdge);
end;

function IndentManagerBasic.ImageBottom: integer;
{finds the bottom of the last floating image}
var
  I: integer;
begin
Result := 0;
for I := 0 to L.Count-1 do
  with IndentRec(L.Items[I]) do
    if not Assigned(ID) and (YB > Result) then  
      Result := YB;
for I := 0 to R.Count-1 do
  with IndentRec(R.Items[I]) do
    if not Assigned(ID) and (YB > Result) then
      Result := YB;
end;

procedure IndentManagerBasic.GetClearY(var CL, CR: integer);
{returns the left and right Y values which will clear image margins}
var
  I: integer;
begin
CL := -1;
for I := 0 to L.Count-1 do
  with IndentRec(L.Items[I]) do
    if not Assigned(ID)and (YB > CL) then
      CL := YB;
CR := -1;
for I := 0 to R.Count-1 do
  with IndentRec(R.Items[I]) do
    if not Assigned(ID)and (YB > CR) then
      CR := YB;
Inc(CL);
Inc(CR);
end;

function IndentManagerBasic.GetNextWiderY(Y: integer): integer;
{returns the next Y value which offers a wider space or Y if none}
var
  I, CL, CR: integer;
begin
CL := Y;
for I := 0 to L.Count-1 do
  with IndentRec(L.Items[I]) do
    if not Assigned(ID)and (YB > Y) and ((YB < CL) or (CL = Y)) then
      CL := YB;
CR := Y;
for I := 0 to R.Count-1 do
  with IndentRec(R.Items[I]) do
    if not Assigned(ID)and (YB > Y) and ((YB < CR) or (CR = Y)) then
      CR := YB;
if CL = Y then
  Result := CR
else if CR = Y then
  Result := CL
else Result := IntMin(CL, CR);
end;

function IndentManagerBasic.SetLeftIndent(XLeft, Y: integer): integer;
var
  IR: IndentRec;
begin
IR := IndentRec.Create;
with IR do
  begin
  YT := Y;
  YB := BigY;
  X := XLeft;
  ID := CurrentID;
  end;
Result := L.Add(IR);
end;

function IndentManagerBasic.SetRightIndent(XRight, Y: integer): integer;
var
  IR: IndentRec;
begin
IR := IndentRec.Create;
with IR do
  begin
  YT := Y;
  YB := BigY;  
  X := XRight;
  ID := CurrentID;
  end;
Result := R.Add(IR);
end;

procedure IndentManagerBasic.FreeLeftIndentRec(I: integer);  
begin
IndentRec(L.Items[I]).Free;
L.Delete(I);
end;

procedure IndentManagerBasic.FreeRightIndentRec(I: integer);
begin
IndentRec(R.Items[I]).Free;
R.Delete(I);
end;

procedure SetGlobalPalette(Value: HPalette);
begin
end;

function CopyPalette(Source: hPalette): hPalette;
var
  LP: ^TLogPalette;
  NumEntries: integer;
begin
Result := 0;
if ColorBits > 8 then    
  Exit;
GetMem(LP, Sizeof(TLogPalette) + 256*Sizeof(TPaletteEntry));
try
  with LP^ do
    begin
    palVersion := $300;
    palNumEntries := 256;
    NumEntries := GetPaletteEntries(Source, 0, 256, palPalEntry);
    if NumEntries > 0 then
      begin
      palNumEntries := NumEntries;
      Result := CreatePalette(LP^);
      end;
    end;
finally
  FreeMem(LP, Sizeof(TLogPalette) + 256*Sizeof(TPaletteEntry));
  end;
end;

procedure CalcPalette(DC: HDC);
{calculate a rainbow palette, one with equally spaced colors}
const
  Values: array[0..5] of integer = (55, 115, 165, 205, 235, 255);
var
  LP: ^TLogPalette;
  I, J, K, Sub: integer;
begin
GetMem(LP, Sizeof(TLogPalette) + 256*Sizeof(TPaletteEntry));
try
  with LP^ do
    begin
    palVersion := $300;
    palNumEntries := 256;
    GetSystemPaletteEntries(DC, 0, 256, palPalEntry);
    Sub := 10;  {start at entry 10}
    for I := 0 to 5 do
      for J := 0 to 5 do
        for K := 0 to 5 do
          if not ((I=5) and (J=5) and (K=5)) then  {skip the white}
            with palPalEntry[Sub] do
              begin
              peBlue := Values[I];
              peGreen := Values[J];
              peRed := Values[K];
              peFlags := 0;
              Inc(Sub);
              end;
    for I := 1 to 24 do
       if not (I in [7, 15, 21]) then   {these would be duplicates}
          with palPalEntry[Sub] do
            begin
            peBlue := 130 + 5*I;
            peGreen := 130 + 5*I;
            peRed := 130 + 5*I;
            peFlags := 0;
            Inc(Sub);
            end;
    Sub := 245;
    with palPalEntry[Sub] do    
      begin
      peBlue := 254;
      peGreen := 255;
      peRed := 255;
      peFlags := 0;
      end;
    ThePalette := CreatePalette(LP^);
    end;
finally
  FreeMem(LP, Sizeof(TLogPalette) + 256*Sizeof(TPaletteEntry));
  end;
end;

const
  DefaultBitmap = 1002;
  ErrBitmap = 1001;
  ErrBitmapMask = 1005;
  Hand_Cursor = 1003;
  ThickIBeam_Cursor = 1006;

procedure ThisExit; far;
begin
if ThePalette <> 0 then
  DeleteObject(ThePalette);
DefBitMap.Free;
ErrorBitMap.Free;
ErrorBitMapMask.Free;
WaitStream.Free;
end;

{----------------TIDNameList}
constructor TIDNameList.Create(List: TList);
begin
inherited Create;
Sorted := True;
OwnerList := List;
end;

destructor TIDNameList.Destroy;
begin
Clear;
inherited
end;

procedure TIDNameList.Clear;
var
  I: integer;
begin
for I := 0 to Count-1 do
  try       
    if Objects[I] is TChPosObj then
      Objects[I].Free;
  except
    end; 
inherited Clear;
end;

function TIDNameList.AddObject(const S: string; AObject: TObject): Integer;
var
  I: integer;
begin
if Find(S, I) then
  begin
  try
    if Objects[I] is TChPosObj then
      Objects[I].Free;
  except
    end;
  Delete(I);
  end;
Result := inherited AddObject(S, AObject);
end;

procedure TIDNameList.AddChPosObject(const S: string; Pos: integer);
var
  ChPosObj: TChPosObj;
begin
ChPosObj := TChPosObj.Create;
ChPosObj.List := OwnerList;
ChPosObj.ChPos := Pos;
AddObject(S, ChPosObj);
end;

destructor TIDObject.Destroy;
begin
inherited;
end;

{----------------TChPosObj.GetYPosition:}
function TChPosObj.GetYPosition: integer;
var
  Pos, X, Y: integer;
begin
with List as TSectionList do
  begin
  Pos := FindDocPos(ChPos, False);
  if CursorToXY(Nil, Pos, X, Y) then
      Result := Y
  else Result := 0;
  end;
end;

{$ifndef NoMetafile}
procedure ThtMetaFile.Construct;  
var
  Tmp: TBitmap;
  pe: TPaletteEntry;
  Color: TColor;
begin
if not Assigned(FBitmap) then
  begin
  FBitmap := TBitmap.Create;
  try
    FBitmap.Width := Width;
    FBitmap.Height := Height;
    PatBlt(FBitmap.Canvas.Handle, 0, 0, Width, Height, Blackness);
    FBitmap.Canvas.Draw(0, 0, Self);

    Tmp := TBitmap.Create;
    try
      Tmp.Width := Width;
      Tmp.Height := Height;
      Tmp.PixelFormat := pf8Bit;
      {pick an odd color from the palette to represent the background color,
       one not likely in the metafile}
      GetPaletteEntries(Tmp.Palette, 115, 1, pe);
      Color := pe.peBlue shl 16 or pe.peGreen shl 8 or pe.peRed;
      Tmp.Canvas.Brush.Color := Color;
      Tmp.Canvas.FillRect(Rect(0, 0, Width, Height));
      Tmp.Canvas.Draw(0, 0, Self);

      FMask := GetImageMask(Tmp, False, Color);
    finally
      Tmp.Free;
      end;
  except
    FreeAndNil(FBitmap);
    end;
  end;
end;

function ThtMetaFile.GetBitmap: TBitmap;
begin
Construct;
Result := FBitmap;
end;

function ThtMetaFile.GetMask: TBitmap;
begin
Construct;
Result := FMask;
end;

function ThtMetaFile.GetWhiteBGBitmap: TBitmap;    
begin
if not Assigned(FWhiteBGBitmap) then
  begin
  FWhiteBGBitmap := TBitmap.Create;
  try
    FWhiteBGBitmap.Width := Width;
    FWhiteBGBitmap.Height := Height;
    PatBlt(FWhiteBGBitmap.Canvas.Handle, 0, 0, Width, Height, Whiteness);
    FWhiteBGBitmap.Canvas.Draw(0, 0, Self);
  except
    FreeAndNil(FWhiteBGBitmap);
    end;
  end;
Result := FWhiteBGBitmap;
end;

destructor ThtMetaFile.Destroy;
begin
FreeAndNil(FBitmap);
FreeAndNil(FMask);
FreeAndNil(FWhiteBGBitmap);  
inherited;
end;
{$endif}

function InSet(W: WideChar; S: SetOfChar): boolean;
begin
if Ord(W) > 255 then
  Result := False
else
  Result := Char(W) in S;
end;

{----------------TCharCollection.GetAsString:}
function TCharCollection.GetAsString: string;
begin
  Result := Copy(FChars, 1, FCurrentIndex);
end;

function TCharCollection.GetSize: Integer;

begin
  Result := FCurrentIndex;
end;

constructor TCharCollection.Create;
begin
inherited;
SetLength(FChars, TokenLeng);
GetMem(FIndices, TokenLeng*Sizeof(integer));
FCurrentIndex := 0;
end;

destructor TCharCollection.Destroy;
begin
FreeMem(FIndices);
inherited;
end;

procedure TCharCollection.Add(C: Char; Index: Integer);
begin
  if FCurrentIndex = Length(FChars) then
  begin
    SetLength(FChars, FCurrentIndex + 50);
    ReallocMem(FIndices, (FCurrentIndex+50)*Sizeof(integer));
  end;
  Inc(FCurrentIndex);
  FIndices^[FCurrentIndex] := Index;
  FChars[FCurrentIndex] := C;
end;

procedure TCharCollection.Clear;
begin
  FCurrentIndex := 0;
  FChars := '';
end;

procedure TCharCollection.Concat(T: TCharCollection);
var
  K: integer;
begin
  K := FCurrentIndex + T.FCurrentIndex;
  if K >= Length(FChars) then
  begin
    SetLength(FChars, K + 50);
    ReallocMem(FIndices, (K+50)*Sizeof(integer));
  end;
  Move(PChar(T.FChars)^, FChars[FCurrentIndex + 1], T.FCurrentIndex);
  Move(T.FIndices^[1], FIndices^[FCurrentIndex + 1], T.FCurrentIndex * Sizeof(Integer));
  FCurrentIndex := K;
end;
{----------------TokenObj.Create}
constructor TokenObj.Create;    
begin
inherited;
GetMem(C, TokenLeng * Sizeof(WideChar));
GetMem(I, TokenLeng*Sizeof(integer));
MaxIndex := TokenLeng;
Leng := 0;
St := '';
StringOK := True;
end;

destructor TokenObj.Destroy;
begin
FreeMem(I);
FreeMem(C);
inherited;
end;

procedure TokenObj.AddUnicodeChar(Ch: WideChar; Ind: integer);
{Ch must be Unicode in this method}
begin
if Leng >= MaxIndex then
  begin
  ReallocMem(C, (MaxIndex + 50) * Sizeof(WideChar));
  ReallocMem(I, (MaxIndex+50)*Sizeof(integer));
  Inc(MaxIndex, 50);
  end;
Inc(Leng);
C^[Leng] := Ch;
I^[Leng] := Ind;
StringOK := False;
end;

procedure TokenObj.Clear;
begin
Leng := 0;
St := '';
StringOK := True;
end;

function MultibyteToWideString(CodePage: integer; const S: string): WideString;
var
  NewLen, Len: integer;
begin
Len := Length(S);
{$ifdef Delphi6_Plus}
if IsWin95 and (CodePage = CP_UTF8) then
  begin
  {Provide initial space. The resulting string will never be longer than the
   UTF-8 encoded string.}
  SetLength(Result, Len+1);  {add 1 for #0 terminator}
  NewLen := UTF8ToUnicode(PWideChar(Result), Len+1, PChar(S), Len) - 1;  {subtr 1 as don't want to count null terminator}
  end
else
{$endif}
  begin
  {Provide initial space. The resulting string will never be longer than the
   UTF-8 or multibyte encoded string.}
  SetLength(Result, 2 * Len);
  NewLen := MultiByteToWideChar(CodePage, 0, PChar(S), Len, PWideChar(Result), Len);
  if NewLen = 0 then
    { Invalid code page. Try default.}
    NewLen := MultiByteToWideChar(CP_ACP, 0, PChar(S), Len, PWideChar(Result), Len);
  end;
SetLength(Result, NewLen);
end;

function WideStringToMultibyte(CodePage: integer; W: WideString): string;   
var
  NewLen, Len: integer;
begin
{$ifdef Delphi6_Plus}
if CodePage = CP_UTF8 then  {UTF-8 encoded string.}
  Result := UTF8Encode(W)
else
{$endif}
  begin
  Len := Length(W);
  SetLength(Result, 3*Len);
  NewLen := WideCharToMultiByte(CodePage, 0, PWideChar(W), Len, PChar(Result), 3*Len, Nil, Nil);
  if NewLen = 0 then
    { Invalid code page. Try default.}
    NewLen := WideCharToMultiByte(CP_ACP, 0, PWideChar(W), Len, PChar(Result), 3*Len, Nil, Nil);
  SetLength(Result, NewLen);
  end;
end;

function ByteNum(CodePage: integer; P: PChar): integer;  
var
  P1: PChar;
begin
if CodePage <> CP_UTF8 then
  begin
  P1 := CharNextEx(CodePage, P, 0);
  if Assigned(P1) then
    Result := P1 - P
  else Result := 0;
  end
else
  case ord(P^) of  {UTF-8}
    0:        Result := 0;
    1..127:   Result := 1;
    192..223: Result := 2;
    224..239: Result := 3;
    240..247: Result := 4;
  else Result := 1;   {error}
  end; 
end;

procedure TokenObj.AddString(S: TCharCollection; CodePage: Integer);
// Takes the given string S and converts it to Unicode using the given code page.
// If we are on Windows 95 then CP_UTF8 (and CP_UTF7) are not supported.
// We compensate for this by using a Delphi function.
// Note: There are more code pages (including CP_UTF7), which are not supported
// on all platforms. These are rather esoteric and therefore not considered here.

var
  WS: WideString;
  I, J, N,
  Len, NewLen: Integer;

begin
  Len := S.FCurrentIndex;
{$ifdef Delphi6_Plus}
  if IsWin95 and (CodePage = CP_UTF8) then
  begin
    {Provide initial space. The resulting string will never be longer than the
     UTF-8 encoded string.}
    SetLength(WS, Len+1);  {add 1 for #0 terminator}
    NewLen := UTF8ToUnicode(PWideChar(WS), Len+1, PChar(S.FChars), Len) - 1;  {subtr 1 as don't want to count null terminator}
  end
  else
{$endif}
  begin
    {Provide initial space. The resulting string will never be longer than the
     UTF-8 or multibyte encoded string.}
    SetLength(WS, 2 * Len);
    NewLen := MultiByteToWideChar(CodePage, 0, PChar(S.FChars), Len, PWideChar(WS), Len);
    if NewLen = 0 then
      { Invalid code page. Try default.}
      NewLen := MultiByteToWideChar(CP_ACP, 0, PChar(S.FChars), Len, PWideChar(WS), Len);
  end;

  {Store the wide string and character indices.}
  if Len = NewLen then    {single byte character set or at least no multibyte conversion}
    for I := 1 to NewLen do
      AddUnicodeChar(WS[I], S.FIndices[I])
  else
    begin     {multibyte character set}
    J := 1;
    for I := 1 to NewLen do
      begin
      AddUnicodeChar(WS[I], S.FIndices[J]);
      {find index for start of next character}
      N := ByteNum(CodePage, @S.FChars[J]);    
      if N > 0 then
        J := J + N
      else
        Break;
      end;
    end;
end;

procedure TokenObj.Concat(T: TokenObj);
var
  K: integer;
begin
K := Leng + T.Leng;
if K > MaxIndex then
  begin
  ReallocMem(C, (K + 50) * Sizeof(WideChar));
  ReallocMem(I, (K+50)*Sizeof(integer));
  MaxIndex := K+50;
  end;
Move(T.C^, C^[Leng + 1], T.Leng * Sizeof(WideChar));
Move(T.I^, I^[Leng+1], T.Leng*Sizeof(integer));
Leng := K;
StringOK := False;
end;

procedure TokenObj.Remove(N: integer);
begin    {remove a single character}
if N <= Leng then
  begin
  Move(C^[N + 1], C^[N], (Leng - N) * Sizeof(WideChar));
  Move(I^[N+1], I^[N], (Leng-N)*Sizeof(integer));
  if StringOK then
    Delete(St, N, 1);
  Dec(Leng);
  end;
end;

procedure TokenObj.Replace(N: integer; Ch: WideChar);
begin    {replace a single character}
if N <= Leng then
  begin
  C^[N] := Ch;
  if StringOK then
    St[N] := Ch;
  end;
end;

function TokenObj.GetString: WideString;
begin
if not StringOK then
  begin
  SetLength(St, Leng);
  Move(C^, St[1], SizeOf(WideChar) * Leng);
  StringOK := True;
  end;
Result := St;
end;

{----------------BitmapToRegion}
function BitmapToRegion(ABmp: TBitmap; XForm: PXForm; TransparentColor: TColor): HRGN;
{Find a Region corresponding to the non-transparent area of a bitmap.

 Thanks to Felipe Machado.  See http://www.delphi3000.com/
 Minor modifications made.}
const
  AllocUnit = 100;
type
  PRectArray = ^TRectArray;
  TRectArray = Array[0..(MaxInt div SizeOf(TRect))-1] of TRect;
var
  pr: PRectArray;    // used to access the rects array of RgnData by index
  h: HRGN;           // Handles to regions
  RgnData: PRgnData; // Pointer to structure RGNDATA used to create regions
  lr, lg, lb: Byte; // values for lowest and hightest trans. colors
  x,y, x0: Integer;  // coordinates of current rect of visible pixels
  b: PByteArray;     // used to easy the task of testing the byte pixels (R,G,B)
  ScanLinePtr: Pointer; // Pointer to current ScanLine being scanned
  ScanLineInc: Integer; // Offset to next bitmap scanline (can be negative)
  maxRects: Cardinal;   // Number of rects to realloc memory by chunks of AllocUnit
  bmp: TBitmap;
begin
  Result := 0;
  lr := GetRValue(TransparentColor);
  lg := GetGValue(TransparentColor);
  lb := GetBValue(TransparentColor);
  { ensures that the pixel format is 32-bits per pixel }
  bmp := TBitmap.Create;
  try
    bmp.Assign(ABmp);
    bmp.PixelFormat := pf32bit;
    { alloc initial region data }
    maxRects := AllocUnit;
    GetMem(RgnData,SizeOf(TRgnDataHeader) + (SizeOf(TRect) * maxRects));
    FillChar(RgnData^, SizeOf(TRgnDataHeader) + (SizeOf(TRect) * maxRects), 0); 
    try
      with RgnData^.rdh do
      begin
        dwSize := SizeOf(TRgnDataHeader);
        iType := RDH_RECTANGLES;
        nCount := 0;
        nRgnSize := 0;
        SetRect(rcBound, MAXLONG, MAXLONG, 0, 0);
      end;
      { scan each bitmap row - the orientation doesn't matter (Bottom-up or not) }
{$IFNDEF LCL}  //For now
      ScanLinePtr := bmp.ScanLine[0];
      if bmp.Height > 1 then   
        ScanLineInc := Integer(bmp.ScanLine[1]) - Integer(ScanLinePtr)
      else ScanLineInc := 0;   
{$ENDIF}
      for y := 0 to bmp.Height - 1 do
      begin
        x := 0;
        while x < bmp.Width do
        begin
          x0 := x;
          while x < bmp.Width do
          begin
            b := @PByteArray(ScanLinePtr)[x*SizeOf(TRGBQuad)];
            // BGR-RGB: Windows 32bpp BMPs are made of BGRa quads (not RGBa)
            if (b[2] = lr) and
               (b[1] = lg) and
               (b[0] = lb) then
              Break; // pixel is transparent
            Inc(x);
          end;
          { test to see if we have a non-transparent area in the image }
          if x > x0 then
          begin
            { increase RgnData by AllocUnit rects if we exceeds maxRects }
            if RgnData^.rdh.nCount >= maxRects then
            begin
              Inc(maxRects,AllocUnit);
              ReallocMem(RgnData,SizeOf(TRgnDataHeader) + (SizeOf(TRect) * MaxRects));
              pr := @RgnData^.Buffer;    
              FillChar(pr^[maxRects-AllocUnit], AllocUnit*SizeOf(TRect), 0);   
            end;
            { Add the rect (x0, y)-(x, y+1) as a new visible area in the region }
            pr := @RgnData^.Buffer; // Buffer is an array of rects
            with RgnData^.rdh do
            begin
              SetRect(pr[nCount], x0, y, x, y+1);
              { adjust the bound rectangle of the region if we are "out-of-bounds" }
              if x0 < rcBound.Left then rcBound.Left := x0;
              if y < rcBound.Top then rcBound.Top := y;
              if x > rcBound.Right then rcBound.Right := x;
              if y+1 > rcBound.Bottom then rcBound.Bottom := y+1;
              Inc(nCount);
            end;
          end; // if x > x0
          { Need to create the region by muliple calls to ExtCreateRegion, 'cause }
          { it will fail on Windows 98 if the number of rectangles is too large   }
          if RgnData^.rdh.nCount = 2000 then
          begin
            h := ExtCreateRegion(XForm, SizeOf(TRgnDataHeader) + (SizeOf(TRect) * maxRects), RgnData^);
            if Result > 0 then
            begin // Expand the current region
              CombineRgn(Result, Result, h, RGN_OR);
              DeleteObject(h);
            end
            else  // First region, assign it to Result
              Result := h;
            RgnData^.rdh.nCount := 0;
            SetRect(RgnData^.rdh.rcBound, MAXLONG, MAXLONG, 0, 0);
          end;
          Inc(x);
        end; // scan every sample byte of the image
{$IFNDEF FPC}
        Inc(Integer(ScanLinePtr), ScanLineInc);
{$ELSE}
        Inc(ScanLinePtr, ScanLineInc);  // LCL port: removed cast for 64-bits.
{$ENDIF}
      end;
      { need to call ExCreateRegion one more time because we could have left    }
      { a RgnData with less than 2000 rects, so it wasn't yet created/combined  }
      if RgnData^.rdh.nCount > 0 then  {LDB  0 Count causes exception and abort in Win98}
        h := ExtCreateRegion(XForm, SizeOf(TRgnDataHeader) + (SizeOf(TRect) * MaxRects), RgnData^)
      else h := 0;
      if Result > 0 then
      begin
        CombineRgn(Result, Result, h, RGN_OR);
        DeleteObject(h);
      end
      else
        Result := h;
    finally
      FreeMem(RgnData,SizeOf(TRgnDataHeader) + (SizeOf(TRect) * MaxRects));
    end;
  finally
    bmp.Free;
    end;
end;

{----------------EnlargeImage}
function EnlargeImage(Image: TGpObject; W, H: integer): TBitmap;
{enlarge 1 pixel images for tiling.  Returns a TBitmap regardless of Image type}
var
  NewBitmap: TBitmap;
begin
Result := TBitmap.Create;
if Image is TGpBitmap then
  NewBitmap := TGpBitmap(Image).GetTBitmap
else
  NewBitmap := TBitmap(Image);
Result.Assign(NewBitmap);
if NewBitmap.Width = 1 then
  Result.Width := IntMin(100, W)
else
  Result.Width := NewBitmap.Width;
if NewBitmap.Height = 1 then
  Result.Height := IntMin(100, H)
else
  Result.Height := NewBitmap.Height;
Result.Canvas.StretchDraw(Rect(0,0,Result.Width, Result.Height), NewBitmap);
if Image is TGpImage then
  NewBitmap.Free;
end;

{----------------PrintBitmap}
procedure PrintBitmap(Canvas: TCanvas; X, Y, W, H: integer;
             BMHandle: HBitmap);
{Y relative to top of display here}
var
  OldPal: HPalette;
  DC: HDC;
  Info: PBitmapInfo;
  Image: AllocRec;
  ImageSize: DWord;
  InfoSize: DWord;
begin
if BMHandle = 0 then
  Exit;
DC := Canvas.Handle;
try
{$IFNDEF LCL}
  GetDIBSizes(BMHandle, InfoSize, ImageSize);
{$ENDIF}
  GetMem(Info, InfoSize);
  try
    Image := Allocate(ImageSize);
    OldPal := SelectPalette(DC, ThePalette, False);
    try
{$IFNDEF LCL}
      GetDIB(BMHandle, ThePalette, Info^, Image.Ptr^);
{$ENDIF}
      RealizePalette(DC);
      with Info^.bmiHeader do
        StretchDIBits(DC, X, Y, W, H,
           0, 0, biWidth, biHeight, Image.Ptr, Info^, DIB_RGB_COLORS, SRCCOPY);
    finally
      DeAllocate(Image);
      SelectPalette(DC, OldPal, False);
     end;
  finally
   FreeMem(Info, InfoSize);
   end;
except
  end;
end;

{----------------PrintBitmap1}
procedure PrintBitmap1(Canvas: TCanvas; X, Y, W, H, YI, HI: integer;
             BMHandle: HBitmap);
{Y relative to top of display here}
var
  OldPal: HPalette;
  DC: HDC;
  Info: PBitmapInfo;
  Image: AllocRec;
  ImageSize: DWord;
  InfoSize: DWord;
begin
if BMHandle = 0 then
  Exit;
DC := Canvas.Handle;
try
{$IFNDEF LCL}
  GetDIBSizes(BMHandle, InfoSize, ImageSize);
{$ENDIF}
  GetMem(Info, InfoSize);
  try
    Image := Allocate(ImageSize);
    OldPal := SelectPalette(DC, ThePalette, False);
    try
{$IFNDEF LCL}
      GetDIB(BMHandle, ThePalette, Info^, Image.Ptr^);
{$ENDIF}
      RealizePalette(DC);
      with Info^.bmiHeader do
        StretchDIBits(DC, X, Y, biWidth, HI,
           0, YI, biWidth, HI, Image.Ptr, Info^, DIB_RGB_COLORS, SRCCOPY);
    finally
      DeAllocate(Image);
      SelectPalette(DC, OldPal, False);
     end;
  finally
   FreeMem(Info, InfoSize);
   end;
except
  end;
end;

{----------------PrintTransparentBitmap1}
procedure PrintTransparentBitmap1(Canvas: TCanvas; X, Y, NewW, NewH: integer;
             Bitmap, Mask: TBitmap; YI, HI: integer);
{Y relative to top of display here}
{This routine prints transparently but only on a white background}
{X, Y are point where upper left corner will be printed.
 NewW, NewH are the Width and Height of the output (possibly stretched)
 Vertically only a portion of the Bitmap, Mask may be printed starting at
   Y=YI in the bitmap and a height of HI
}
var
  OldPal: HPalette;
  DC: HDC;
  Info: PBitmapInfo;
  Image: AllocRec;
  ImageSize: DWord;
  InfoSize: DWord;
  Abitmap: TBitmap;

begin
ABitmap := TBitmap.Create;
try
  Abitmap.Assign(Bitmap);
  ABitmap.Height := HI;
  SetBkColor(ABitmap.Canvas.Handle, clWhite);     
  SetTextColor(ABitmap.Canvas.Handle, clBlack);   
  BitBlt(ABitmap.Canvas.Handle, 0, 0, Bitmap.Width, HI, Bitmap.Canvas.Handle, 0, YI, SrcCopy);
  BitBlt(ABitmap.Canvas.Handle, 0, 0, Bitmap.Width, HI, Mask.Canvas.Handle, 0, YI, SRCPAINT);
  DC := Canvas.Handle;
{$IFNDEF LCL}
  GetDIBSizes(ABitmap.Handle, InfoSize, ImageSize);
{$ENDIF}
  GetMem(Info, InfoSize);
  try
    Image := Allocate(ImageSize);
    OldPal := SelectPalette(DC, ThePalette, False);
    try
{$IFNDEF LCL}
      GetDIB(ABitmap.Handle, ThePalette, Info^, Image.Ptr^);
{$ENDIF}
      RealizePalette(DC);
      with Info^.bmiHeader do
        StretchDIBits(DC, X, Y, NewW, NewH,
           0, 0, biWidth, biHeight, Image.Ptr, Info^, DIB_RGB_COLORS, SRCCOPY);
    finally
      DeAllocate(Image);
      SelectPalette(DC, OldPal, False);
     end;
  finally
   FreeMem(Info, InfoSize);
   end;
finally
  ABitmap.Free;
  end;
end;

{----------------PrintTransparentBitmap3}
procedure PrintTransparentBitmap3(Canvas: TCanvas; X, Y, NewW, NewH: integer;
             Bitmap, Mask: TBitmap; YI, HI: integer);
{Y relative to top of display here}
{This routine prints transparently on complex background by printing through a clip region}
{X, Y are point where upper left corner will be printed.
 NewW, NewH are the Width and Height of the output (possibly stretched)
 Vertically only a portion of the Bitmap, Mask may be printed starting at
   Y=YI in the bitmap and a height of HI
}
var
  OldPal: HPalette;
  DC: HDC;
  Info: PBitmapInfo;
  Image: AllocRec;
  ImageSize: DWord;
  InfoSize: DWord;
  hRgn, OldRgn: THandle;
  Rslt: integer;
  XForm: TXForm;
  SizeV, SizeW: TSize;
  HF, VF: double;
  ABitmap, AMask: TBitmap;
  BitmapCopy: boolean;

begin
{the following converts the black masked area in the image to white.  This may look
 better in WPTools which currently doesn't handle the masking}
if (Bitmap.Handle = 0) or (HI <= 0) or (Bitmap.Width <= 0) then
  Exit;
BitmapCopy := Bitmap.Height <> HI;
try
  if BitmapCopy then
    begin
    ABitmap := TBitmap.Create;
    AMask := TBitmap.Create;
    end
  else
    begin
    ABitmap := Bitmap;
    AMask := Mask;
    end;
  try
    if BitmapCopy then
      begin
      Abitmap.Assign(Bitmap);
      ABitmap.Height := HI;
      BitBlt(ABitmap.Canvas.Handle, 0, 0, Bitmap.Width, HI, Bitmap.Canvas.Handle, 0, YI, SrcCopy);
      AMask.Assign(Mask);
      AMask.Height := HI;
      BitBlt(AMask.Canvas.Handle, 0, 0, AMask.Width, HI, Mask.Canvas.Handle, 0, YI, SrcCopy);
      end;

    SetBkColor(ABitmap.Canvas.Handle, clWhite);     
    SetTextColor(ABitmap.Canvas.Handle, clBlack);
    BitBlt(ABitmap.Canvas.Handle, 0, 0, Bitmap.Width, HI, AMask.Canvas.Handle, 0, 0, SRCPAINT);

    DC := Canvas.Handle;
    {calculate a transform for the clip region as it may be a different size than
     the mask and needs to be positioned on the canvas.}
    GetViewportExtEx(DC, SizeV);
    GetWindowExtEx(DC, SizeW);
    HF := (SizeV.cx/SizeW.cx);  {Horizontal adjustment factor}
    VF := (SizeV.cy/SizeW.cy);  {Vertical adjustment factor}

    XForm.eM11 := HF * (NewW/Bitmap.Width);
    XForm.eM12 := 0;
    XForm.eM21 := 0;
    XForm.eM22 := VF * (NewH/HI);
    XForm.edx := HF*X;
    XForm.edy := VF*Y;          

    {Find the region for the white area of the Mask}
    hRgn := BitmapToRegion(AMask, @XForm, $FFFFFF);
    if hRgn <> 0 then  {else nothing to output--this would be unusual}
      begin
      OldRgn := CreateRectRgn(0,0,1,1);  {a valid region is needed for the next call}
      Rslt := GetClipRgn(DC, OldRgn);    {save the Old clip region}
      try
        if Rslt = 1 then
          CombineRgn(hRgn, hRgn, OldRgn, RGN_AND);
        SelectClipRgn(DC, hRgn);
{$IFNDEF LCL}
        GetDIBSizes(ABitmap.Handle, InfoSize, ImageSize);   
{$ENDIF}
        GetMem(Info, InfoSize);
        try
          Image := Allocate(ImageSize);
          OldPal := SelectPalette(DC, ThePalette, True);
          try
{$IFNDEF LCL}
            GetDIB(ABitmap.Handle, ThePalette, Info^, Image.Ptr^);  
{$ENDIF}
            RealizePalette(DC);
            with Info^.bmiHeader do
              StretchDIBits(DC, X, Y, NewW, NewH,
                 0, 0, biWidth, biHeight, Image.Ptr, Info^, DIB_RGB_COLORS, SRCCOPY);
          finally
            DeAllocate(Image);
            SelectPalette(DC, OldPal, False);
           end;
        finally
         FreeMem(Info, InfoSize);
         end;
      finally
        if Rslt = 1 then
          SelectClipRgn(DC, OldRgn)
        else SelectClipRgn(DC, 0);
        DeleteObject(hRgn);
        DeleteObject(OldRgn);
        end;
      end;
  finally
    if BitmapCopy then
      begin
      ABitmap.Free;
      AMask.Free;
      end;
    end;
except
  end;
end;

type
  BorderPointArray = array[0..3] of TPoint;

function htStyles(P0, P1, P2, P3: BorderStyleType): htBorderStyleArray;
begin
Result[0] := P0;
Result[1] := P1;
Result[2] := P2;
Result[3] := P3;
end;

procedure DrawGpImage(Handle: THandle; Image: TGpImage; DestX, DestY: integer);
{Draws the entire image as specified at the point specified}
var
  g: TGpGraphics;
begin
g := TGPGraphics.Create(Handle);
try
  g.DrawImage(Image, DestX, DestY, Image.Width, Image.Height);
except
  end;
g.Free;
end;

procedure DrawGpImage(Handle: THandle; Image: TGpImage; DestX, DestY,
            SrcX, SrcY, SrcW, SrcH: integer);
{Draw a portion of the image at DestX, DestY.  No stretching}
var
  g: TGpGraphics;
begin
g := TGPGraphics.Create(Handle);
try
  g.DrawImage(Image, DestX, DestY, SrcX, SrcY, SrcW, SrcH);
except
  end;
g.Free;
end;

procedure StretchDrawGpImage(Handle: THandle; Image: TGpImage; DestX, DestY,
             DestW, DestH: integer);
{Draws the entire image in the rectangle specified}
var
  g: TGpGraphics;
begin
g := TGPGraphics.Create(Handle);
try
  g.DrawImage(Image, DestX, DestY, DestW, DestH);
except
  end;
g.Free;
end;

procedure StretchPrintGpImageDirect(Handle: THandle; Image: TGpImage;
              DestX, DestY, DestW, DestH: integer;
              ScaleX, ScaleY: single);
{Prints the entire image at the point specified with the height and width specified}
var
  g: TGpGraphics;
begin
g := TGPGraphics.Create(Handle);
try
  g.ScaleTransform(ScaleX, ScaleY);
  g.DrawImage(Image, DestX, DestY, DestW, DestH);
except
  end;
g.Free;
end;

procedure StretchPrintGpImageOnColor(Canvas: TCanvas; Image: TGpImage;
              DestX, DestY, DestW, DestH: integer; Color: TColor = clWhite);
var
  g: TGpGraphics;
  bg: TBitmap;
begin   {Draw image on white background first, then print}
bg := TBitmap.Create;
bg.Width := TGPImage(Image).Width;
bg.Height := TGPImage(Image).Height;
bg.Canvas.Brush.Color := Color;
bg.Canvas.FillRect(Rect(0, 0, bg.Width, bg.Height));
g := TGPGraphics.Create(bg.Canvas.Handle);
g.DrawImage(TGPImage(Image),0,0, bg.Width, bg.Height);
g.Free;
Canvas.StretchDraw(Rect(DestX, DestY, DestX+DestW, DestY+DestH), bg);
bg.Free;
end;

procedure PrintGpImageDirect(Handle: THandle; Image: TGpImage; DestX, DestY: integer;
              ScaleX, ScaleY: single);
{Prints the entire image as specified at the point specified}
var
  g: TGpGraphics;
begin
g := TGPGraphics.Create(Handle);
try
  g.ScaleTransform(ScaleX, ScaleY);
  g.DrawImage(Image, DestX, DestY, Image.Width, Image.Height);
except
  end;
g.Free;
end;

function Points(P0, P1, P2, P3: TPoint): BorderPointArray;
begin
Result[0] := P0;
Result[1] := P1;
Result[2] := P2;
Result[3] := P3;
end;

function htColors(C0, C1, C2, C3: TColor): htColorArray;
begin
Result[0] := C0;
Result[1] := C1;
Result[2] := C2;
Result[3] := C3;
end;

procedure DrawOnePolygon(Canvas: TCanvas; P: BorderPointArray; Color: TColor;
             Side: integer; Printing: boolean);
{Here we draw a 4 sided polygon (by filling a region).  This represents one
 side (or part of a side) of a border.
 For single pixel thickness, drawing is done by lines for better printing}
type SideArray = array[0..3, 1..4] of integer;

const
  AD: SideArray = ((0,1,0,3),
                   (0,1,1,1),
                   (2,0,2,1),    
                   (1,3,3,3));
  AP: SideArray = ((0,1,0,3),    
                   (0,1,2,1),
                   (2,0,2,2), 
                   (1,3,3,3));
var
  R: HRgn;
  OldWidth: integer;
  OldStyle: TPenStyle;
  OldColor: TColor;
  Thickness: integer;
  P1, P2: TPoint;
  I: SideArray;
begin
if Side in [0,2] then
  Thickness := Abs(P[2].X - P[1].X)
else Thickness := Abs(P[1].Y - P[2].Y);
if Thickness = 1 then
  begin
  with Canvas do
    begin
    OldColor := Pen.Color;
    OldStyle := Pen.Style;
    OldWidth := Pen.Width;
    Pen.Color := Color;
    Pen.Style := psSolid;
    Pen.Width := 1;
    if Printing then    
      I := AP
    else I := AD;
    P1 := Point(P[I[Side,1]].X, P[I[Side,2]].Y);
    P2 := Point(P[I[Side,3]].X, P[I[Side,4]].Y);   
    MoveTo(P1.X, P1.Y);
    LineTo(P2.X, P2.Y);
    Pen.Width := OldWidth;
    Pen.Style := OldStyle;
    Pen.Color := OldColor;
    end;
  end
else
  begin
  R := CreatePolygonRgn(P, 4, Alternate);
  try
    with Canvas do
      begin
      Brush.Style := bsSolid;
      Brush.Color := Color;
      FillRgn(Handle, R, Brush.Handle);
      end;
  finally
    DeleteObject(R);
    end;
  end;
end;

{----------------DrawBorder}
procedure DrawBorder(Canvas: TCanvas; ORect, IRect: TRect; C: htColorArray;
            S: htBorderStyleArray; BGround: TColor; Print: boolean);
{Draw the 4 sides of a border.  The sides may be of different styles or colors.
 The side indices, 0,1,2,3, represent left, top, right, bottom.
 ORect is the outside rectangle of the border, IRect the inside Rectangle.
 BGround is the background color used for the bssDouble style}
var
  PO, PI, PM, P1, P2, Bnd: BorderPointArray;
  I: integer;
  Color: TColor;
  MRect: TRect;
  lb: TLogBrush;
  Pn, OldPn: HPen;
  W, D: array[0..3] of integer;
  InPath: boolean;
  PenType, Start: integer;
  StyleSet: set of BorderStyleType;
  OuterRegion, InnerRegion: THandle;
  Brush: TBrush;

  function Darker(Color: TColor): TColor;
  {find a somewhat darker color for shading purposes}
  const
    F = 0.75;
  var
    Red, Green, Blue: Byte;      
  begin
  if Color and $80000000 = $80000000 then
    Color := GetSysColor(Color and $FFFFFF)
  else Color := Color and $FFFFFF;
  Red := Color and $FF;
  Green := (Color and $FF00) shr 8;
  Blue := (Color and $FF0000) shr 16;
  Result := RGB(Round(F*Red), Round(F*Green), Round(F*Blue));
  end;

begin
{Limit the borders to somewhat more than the screen size}
ORect.Bottom := IntMin(ORect.Bottom, BotLim);
ORect.Top := IntMax(ORect.Top, TopLim);
IRect.Bottom := IntMin(IRect.Bottom, BotLim);
IRect.Top := IntMax(IRect.Top, TopLim);

{Find out what style types are represented in this border}
StyleSet := [];
for I := 0 to 3 do
  Include(StyleSet, S[I]);

{find the outside and inside corner points for the border segments}
with ORect do
  begin
  PO[0] := Point(Left, Bottom);
  PO[1] := TopLeft;
  PO[2] := Point(Right, Top);
  PO[3] := BottomRight;
  end;
with IRect do
  begin
  PI[0] := Point(Left, Bottom);
  PI[1] := TopLeft;
  PI[2] := Point(Right, Top);
  PI[3] := BottomRight;
  end;

{Points midway between the outer and inner rectangle are needed for
 ridge, groove, dashed, dotted styles}
if [bssRidge, bssGroove, bssDotted, bssDashed] * StyleSet <> [] then
  begin
  MRect := Rect((ORect.Left+IRect.Left) div 2, (ORect.Top+IRect.Top) div 2,
                (ORect.Right+IRect.Right) div 2, (ORect.Bottom+IRect.Bottom) div 2);
  with MRect do
    begin
    PM[0] := Point(Left, Bottom);
    PM[1] := TopLeft;
    PM[2] := Point(Right, Top);
    PM[3] := BottomRight;
    end;
  end;

{Widths are needed for Dashed, Dotted, and Double}
W[0] := IRect.Left-Orect.Left;
W[1] := IRect.Top-Orect.Top;
W[2] := ORect.Right-IRect.Right;
W[3] := ORect.Bottom-IRect.Bottom;

{the Double style needs the space between inner and outer rectangles divided
 into three parts}
if bssDouble in StyleSet then
  begin
  for I := 0 to 3 do
    begin
    D[I] := W[I] div 3;
    if W[I] mod 3 = 2 then
      Inc(D[I]);
    end;

  with ORect do
    MRect := Rect(Left+D[0], Top+D[1], Right-D[2], Bottom-D[3]);

  with MRect do
    begin
    P1[0] := Point(Left, Bottom);
    P1[1] := TopLeft;
    P1[2] := Point(Right, Top);
    P1[3] := BottomRight;
    end;

  with IRect do
    MRect := Rect(Left-D[0], Top-D[1], Right+D[2], Bottom+D[3]);

  with MRect do
    begin
    P2[0] := Point(Left, Bottom);
    P2[1] := TopLeft;
    P2[2] := Point(Right, Top);
    P2[3] := BottomRight;
    end;
  end;

{double, dotted, dashed styles need a background fill}
if (BGround <> clNone) and ([bssDouble, bssDotted, bssDashed] * StyleSet <> []) then
  begin
  with ORect do
    OuterRegion := CreateRectRgn(Left, Top, Right, Bottom);
  with IRect do
    InnerRegion := CreateRectRgn(Left, Top, Right, Bottom);
  CombineRgn(OuterRegion, OuterRegion, InnerRegion, RGN_DIFF);
  Brush := TBrush.Create;
  try
    Brush.Color := BGround or PalRelative;
    Brush.Style := bsSolid;
    FillRgn(Canvas.Handle, OuterRegion, Brush.Handle);
  finally
    Brush.Free;
    DeleteObject(OuterRegion);
    DeleteObject(InnerRegion);
    end;
  end;

InPath := False;
Pn := 0;
OldPn := 0;
Start := 0;

try
  for I := 0 to 3 do
    if S[I] in [bssSolid, bssInset, bssOutset] then
      begin
      Bnd[0] := PO[I];
      Bnd[1] := PO[(I+1) Mod 4];
      Bnd[2] := PI[(I+1) Mod 4];
      Bnd[3] := PI[I];
      Color := C[I] or PalRelative;
      case S[I] of
        bssSolid:
          DrawOnePolygon(Canvas, Bnd, Color, I, Print);
        bssInset:
          begin
          if I in [0,1] then
            Color := Darker(C[I]) or PalRelative;
          DrawOnePolygon(Canvas, Bnd, Color, I, Print);
          end;
        bssOutset:
          begin
          if (I in [2,3]) then
            Color := Darker(C[I]) or PalRelative;
          DrawOnePolygon(Canvas, Bnd, Color, I, Print);
          end;
        end;
      end
    else if S[I] in [bssRidge, bssGroove] then
      begin    {ridge or groove}
      Color := C[I] or PalRelative;
      Bnd[0] := PO[I];
      Bnd[1] := PO[(I+1) Mod 4];
      Bnd[2] := PM[(I+1) Mod 4];
      Bnd[3] := PM[I];
      case S[I] of
        bssGroove:
          begin
          if I in [0,1] then
            Color := Darker(C[I]) or PalRelative;
          DrawOnePolygon(Canvas, Bnd, Color, I, Print);
          end;
        bssRidge:
          begin
          if (I in [2,3]) then
            Color := Darker(C[I]) or PalRelative;
          DrawOnePolygon(Canvas, Bnd, Color, I, Print);
          end;
        end;
      Color := C[I] or PalRelative;  
      Bnd[0] := PM[I];
      Bnd[1] := PM[(I+1) Mod 4];
      Bnd[2] := PI[(I+1) Mod 4];
      Bnd[3] := PI[I];
      case S[I] of
        bssRidge:
          begin
          if I in [0,1] then
            Color := Darker(C[I]) or PalRelative;
          DrawOnePolygon(Canvas, Bnd, Color, I, Print);
          end;
        bssGroove:
          begin
          if (I in [2,3]) then
            Color := Darker(C[I]) or PalRelative;
          DrawOnePolygon(Canvas, Bnd, Color, I, Print);
          end;
        end;
      end
    else if S[I] = bssDouble then
      begin
      Color := C[I] or PalRelative;
      Bnd[0] := PO[I];
      Bnd[1] := PO[(I+1) Mod 4];
      Bnd[2] := P1[(I+1) Mod 4];
      Bnd[3] := P1[I];
      DrawOnePolygon(Canvas, Bnd, Color, I, Print);
      Bnd[0] := P2[I];
      Bnd[1] := P2[(I+1) Mod 4];
      Bnd[2] := PI[(I+1) Mod 4];
      Bnd[3] := PI[I];
      DrawOnePolygon(Canvas, Bnd, Color, I, Print);
      end
    else if S[I] in [bssDashed, bssDotted] then
      begin
      if not InPath then
        begin
        lb.lbStyle := BS_SOLID;
        lb.lbColor := C[I] or PalRelative;
        lb.lbHatch := 0;
        if S[I] = bssDotted then
          PenType := PS_Dot or ps_EndCap_Round
        else PenType := PS_Dash or ps_EndCap_Square;
        Pn := ExtCreatePen(PS_GEOMETRIC or PenType or ps_Join_Miter, W[I], lb, 0, Nil);
        OldPn := SelectObject(Canvas.Handle, Pn);
        BeginPath(Canvas.Handle);
{$IFNDEF LCL}
        Windows.movetoEx(Canvas.Handle, PM[I].x, PM[I].y, Nil);
{$ELSE}
        LclIntf.movetoEx(Canvas.Handle, PM[I].x, PM[I].y, Nil);
{$ENDIF}        
        Start := I;
        InPath := True;
        end;
{$IFNDEF LCL}
      Windows.LineTo(Canvas.Handle, PM[(I+1) mod 4].x, PM[(I+1) mod 4].y);
{$ELSE}
      LclIntf.LineTo(Canvas.Handle, PM[(I+1) mod 4].x, PM[(I+1) mod 4].y);
{$ENDIF}      
      if (I=3) or (S[I+1] <> S[I]) or (C[I+1] <> C[I]) or (W[I+1] <> W[I]) then
        begin
        if (I=3) and (Start=0) then
          CloseFigure(Canvas.Handle);   {it's a closed path}
        EndPath(Canvas.Handle);
        StrokePath(Canvas.Handle);
        SelectObject(Canvas.Handle, OldPn);
        DeleteObject(Pn);
        Pn := 0;
        InPath := False;
        end;
      end;
finally
  if Pn <> 0 then
    begin
    SelectObject(Canvas.Handle, OldPn);
    DeleteObject(Pn);
    end;
  end;
end;

{ TgpObject }

function GetImageHeight(Image: TGpObject): integer;
begin
if Image is TBitmap then
  Result := TBitmap(Image).Height
else if Image is TGpImage then
  Result := TGpImage(Image).Height
else if Image is TGifImage then
  Result := TGifImage(Image).Height
{$ifndef NoMetafile}
else if Image is ThtMetaFile then
  Result := ThtMetaFile(Image).Height
{$endif}
else Raise(EGDIPlus.Create('Not a TBitmap, TGifImage, TMetafile, or TGpImage'));
end;

function GetImageWidth(Image: TGpObject): integer;
begin
if Image is TBitmap then
  Result := TBitmap(Image).Width
else if Image is TGpImage then
  Result := TGpImage(Image).Width
else if Image is TGifImage then
  Result := TGifImage(Image).Width
{$ifndef NoMetafile}
else if Image is ThtMetaFile then
  Result := ThtMetaFile(Image).Width
{$endif}
else Raise(EGDIPlus.Create('Not a TBitmap, TGifImage, TMetafile, or TGpImage'));
end;

initialization
DC := GetDC(0);
try
  ColorBits := GetDeviceCaps(DC, BitsPixel)*GetDeviceCaps(DC, Planes);

  if ColorBits <= 4 then
    ColorBits := 4
  else if ColorBits <= 8 then
    ColorBits := 8
  else  ColorBits := 24;

  ThePalette := 0;
  if ColorBits = 8 then
    CalcPalette(DC);
  if ColorBits <= 8 then     {use Palette Relative bit only when Palettes used}
    PalRelative := $2000000
  else PalRelative := 0;
finally
  ReleaseDC(0, DC);
  end;

IsWin95 := (Win32Platform = VER_PLATFORM_WIN32_WINDOWS) and (Win32MinorVersion in [0..9]);
IsWin32Platform := Win32Platform = VER_PLATFORM_WIN32_WINDOWS;

{$ifdef UseElPack}
UnicodeControls := True;
{$endif}

{$ifdef UseTNT}
UnicodeControls := not IsWin32Platform;
{$endif}

{$IFDEF LCL}
  {$I htmlun2.lrs}
{$ENDIF}

DefBitMap := TBitmap.Create;
ErrorBitMap := TBitmap.Create;
ErrorBitMapMask := TBitmap.Create;
{$IFNDEF LCL}
DefBitMap.Handle := LoadBitmap(HInstance, MakeIntResource(DefaultBitmap));
ErrorBitMap.Handle := LoadBitmap(HInstance, MakeIntResource(ErrBitmap));
ErrorBitMapMask.Handle := LoadBitmap(HInstance, MakeIntResource(ErrBitmapMask));
Screen.Cursors[HandCursor] := LoadCursor(HInstance, MakeIntResource(Hand_Cursor));
Screen.Cursors[UpDownCursor] := LoadCursor(HInstance, 'UPDOWNCURSOR');
Screen.Cursors[UpOnlyCursor] := LoadCursor(HInstance, 'UPONLYCURSOR');
Screen.Cursors[DownOnlyCursor] := LoadCursor(HInstance, 'DOWNONLYCURSOR');
{$ELSE}
DefBitMap.LoadFromLazarusResource('DefaultBitmap');
ErrorBitMap.LoadFromLazarusResource('ErrBitmap');
ErrorBitMapMask.LoadFromLazarusResource('ErrBitmapMask');
//Don't need since equal to crHandPoint (and jumps around on Carbon).
//Screen.Cursors[HandCursor] := LoadCursorFromLazarusResource('Hand_Cursor');
Screen.Cursors[UpDownCursor] := LoadCursorFromLazarusResource('UPDOWNCURSOR');
Screen.Cursors[UpOnlyCursor] := LoadCursorFromLazarusResource('UPONLYCURSOR');
Screen.Cursors[DownOnlyCursor] := LoadCursorFromLazarusResource('DOWNONLYCURSOR');
{$ENDIF}

WaitStream := TMemoryStream.Create;

Finalization
ThisExit;
end.