htmlun2.pas

来自「查看html文件的控件」· PAS 代码 · 共 2,486 行 · 第 1/5 页

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

{$i htmlcons.inc}

unit HTMLUn2;

interface
uses
  Windows, SysUtils, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, ExtCtrls, Clipbrd, StyleUn, GDIPL2A; 

const
  VersionNo = '9.4a';
  HandCursor = 1;
  ThickIBeamCursor = 2;
  UpDownCursor = 3;
  UpOnlyCursor = 4;
  DownOnlyCursor = 5;
  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}
  private
    function GetNameW: WideString;
  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;
    property NameW: WideString read GetNameW;  
  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;
  PIndexArray = ^IndexArray;
  ChrArray = array[1..TokenLeng] of WideChar;     

  {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 Metafile}
  ThtMetaFile = class(TMetaFile)
  private
    FBitmap, FMask: TBitmap;
    function GetBitmap: TBitmap;
    function GetMask: TBitmap;
    procedure Construct;
  public
    destructor Destroy; override;
    property Bitmap: TBitmap read GetBitmap;
    property Mask: TBitmap read GetMask;
    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}
  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 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 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
   jpeg, DitherUnit,
  {$ifndef NoOldPng}
     PngImage1,   
  {$endif}
     htmlview, htmlsubs, HtmlGif2, StylePars, ActiveX;

type
  EGDIPlus = class (Exception);
  TJpegMod = class(TJpegImage)
  public
    property Bitmap;
  end;

var
  DC: HDC; 

{----------------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