htmlun2.pas

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

           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;
end;

destructor TStringBitmapList.Destroy;
var
  I: integer;
begin
for I := 0 to Count-1 do
  (Objects[I] as TBitmapItem).Free;
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;

function TAttribute.GetNameW: WideString;
begin
Result := MultibyteToWideString(CodePage, Name);   
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;   
{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;
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;