htmlun2.pas

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

       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;

{----------------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;
var
  ExtS: TSize;
  Ints: ^Integers;
  L, H, I: integer;

begin
if not IsWin32Platform then   
  begin
  Extent := 0;
  Result := 0;
  if (Width <= 0) or (Max = 0) then
    Exit;
  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}
  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 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;

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
  if Pos('\\', Result) = 1 then
    Exit;
  if Pos(':', Result) = 2 then
    Exit;
  if Result[1] = '\' then
    Result := Root+Result;
  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;
  Replace('|', ':');
  Replace('/', '\');
  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
if not IsWin32Platform then
  GetTextExtentExPointW(DC, P, N, 0, @Dummy, Nil, ExtS)
else
  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;