htmlun2.pas

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

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;
    Handle := CreatePolygonRgn(Coords, Cnt div 2, Winding);
    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;
  W: WideString;
begin
Result := Nil;
Mask := Nil;
if not FileExists(Filename) then Exit;
if GDIPlusActive and (KindOfImageFile(Filename) = Png) then
  begin
  W := Filename;
  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
        jpImage.PixelFormat := jf8bit;
        if not jpImage.GrayScale and (ColorBits = 8) then
          jpImage.Palette := CopyPalette(ThePalette);
        end
      else jpImage.PixelFormat := jf24bit;
      Result.Assign(jpImage.Bitmap);
    finally
      jpImage.Free;
      end;
    end
  {$ifndef NoOldPng}
  else if IT = Png then