httputil.pas

ThreadPro 是本人开发的一套用于多线程编程的 Delphi 基础类库

unit HTTPutil;

interface

uses
  StrUtils, Classes, SysUtils, Forms, Registry, Windows, IniFiles, StdCtrls, ComCtrls, 
  ShellAPI, Clipbrd, Dialogs, CheckLst, Menus;

  //
  procedure GetIniSecStrings(Ini : TiniFile; Sec : String; Strs : TStrings);
  function MsgBox(Info: String; Style: integer): integer;
  procedure SleepX(sec : Byte);

  //Html Parse functions
  function FindTagHtmlByAttrPos(str: string ; front : boolean; posi : integer): Integer;
  function GetAttrValue(TagHtml,AttrName : string):string;
  function FindAttrEnd(str : string; posi : integer) : Integer;
  function GetTagHtml(Html : string; InnerPos : Integer):string;
  function FindAttrPos(Html,AttrName,AttrValue : string; NeedAttrValue : Boolean = True): Integer;
  function GetTagInnerHtml(Html,TagName : string; var EndPos : Integer): string;
  function GetTagInnerHtmls(Html,TagName : string; Htmls : TStringList):Integer;
  function GetTagInnerHtmlByAttr(Html,TagName,AttrName,AttrValue : string):string;

  function GetValByName(Html, TagValue: string) : string;
  function GetLinkTextByUniqueURL(HTML,URL : string):string;

  function ExtractHtmlTagValues(const HtmlText: string; TagName, AttribName: string; var Values: TStringList): integer;

  //codec functions
  function URLEncode(const msg : String) : String;
  function UrlDecode(const EncodedStr: String): String;
  Function HexToInt(Hex :String):Int64;

  //string util functions
  function FormatStrNum(Num : Integer; Len : ShortInt): String;
  procedure GetColumnFromLstV(LstV : TListView; Sl : TStringList; idx : Byte);
  function LStrDiv(Str,Spl : string): string;
  function RStrDiv(Str,Spl : string): string;
  function ExStrSeg(Str,Spl : string; Idx : Integer): string;
  function RndStr(Len : Byte): string;
  function RndNum(Len : Byte):string;
  function RndStrNum(Len : Byte):string;
  function RndCnChr(dLen : Byte):string;
  function RndIdx(Range : Integer):Integer;
  function RndSlItem(sl : TStringList):string;
  procedure RemoveSubStr(const SubStr:string; var Str : string);
  function BoolToStr(b : boolean): string;
  function BoolToInt(b : boolean): SmallInt;
  function IsNum(s : string): boolean;
  function ExtractNum(s : string; pos : integer): Integer;
  function MemoToStr(Strs : TStrings ; Sp : string): string;
  function GetDigAt(s, sp : string; front : boolean): string;
  function ParseUrl(Url : string; Host : Boolean) : string;
  procedure RmHtmlTags(var src : string);

  //stdctrl functions
  procedure AddLstBPro(ListBox : TListBox; str : string; Insert : boolean; MaxLine : Integer);
  procedure ChkLstV(LstV : TListView; Chk : Boolean);
  function ChkSelLstV(LstV : TListView; Chk : Boolean): Integer;
  procedure RfhLstV(LstV : TListView);
  procedure eplstV(lst : TListView; FileName,Sp : String);
  function CopyLv(lv : TListView) : Integer;
  {<<<< Added 2006.6.21 <<<<}
  procedure AddLv(Lv : TListView; SubItems : TStringList; MakeVisible : Boolean = True; Checked : Boolean = True; ImgIdx : SmallInt = -1; Data : Pointer= nil);
  procedure RfhLvItem(Lv : TListView; NewText : string ;Row : Integer; Col : Byte; MakeVisible : Boolean = True; Checked : Boolean = True; ImgIdx : SmallInt = -1; Data : Pointer= nil);
  procedure InitProgressBar(pb : TProgressBar; Max : Integer);
  function CheckLvDupItem(Lv : TListView; Item : string; Col : Byte):Boolean;
  procedure SaveDialogSlExec(Owner : TComponent; FileType,FileExt : string;Items : TStrings);
  procedure OpenDialogSlExec(Owner : TComponent; FileType,FileExt : string;Items : TStrings);
  procedure ClrPopLst(PM : TPopupMenu);
  procedure CheckChkLst(ChkLst : TCheckListBox; check : Boolean);
  
  //Shell
  procedure OpenUrlLv(Lv : TListView; Col : Byte; Prefix : string = '');
  procedure OpenUrlLst(Lst : TListBox);
  procedure OpenUrl(Url : string);

implementation

procedure RemoveSubStr(const SubStr : string; var Str : string);
var
  iPos : Integer;
begin
  Repeat
    iPos := Pos(SubStr,Str);
    if iPos>0 then
    Delete(Str,iPos,Length(SubStr));
  Until iPos = 0;
end;

procedure GetIniSecStrings(Ini : TiniFile; Sec : String; Strs : TStrings);
var
  i : Integer;
  Keys : TStringList;
  Value : String;
begin
  Strs.Clear;
  Keys := TStringList.Create;
  Ini.ReadSection(Sec,Keys);
  for i:=0 to Keys.Count-1 do
  begin
    Value := Ini.ReadString(Sec,Keys[i],'');
    Strs.Add(Value);
  end;
  Keys.Free;
end;

function MsgBox(Info: String; Style: integer): integer;
begin
  with Application do
  begin
    NormalizeTopMosts;
    Result := MessageBox(PChar(Info), '信息提示',Style);
    RestoreTopMosts;
  end;
end;

procedure SleepX(sec : Byte);
var
  i : Integer;
begin
  for i:=1 to 10*sec do
  begin
    Sleep(100);
    Application.ProcessMessages;
  end;
end;

function FindTagHtmlByAttrPos(str: string ; front : boolean; posi : integer): Integer;
var
  i: integer;
begin
  Result := -1;
  if Front then
  begin
    for i:=posi-1 downto 1 do
    if Str[i]='<' then
    begin
      Result := i;
      break;
    end;
  end else begin
    for i := posi+1 to length(Str) do
    if Str[i]='>' then
    begin
      Result := i;
      break;
    end;
  end;
end;

function FindAttrEnd (str : string; posi : integer) : Integer;
var
  i: integer;
begin
  Result := -1;
  for i:=posi to length(str) do
  begin
    if str[i] in ['"','''',' ','>'] then
    begin
      result := i-1;
      break;
    end;
  end;
end;

function FindAttrPos(Html,AttrName,AttrValue : string; NeedAttrValue : Boolean = True): Integer;
const
  TR : Array[0..2] of string[1] = ('"','''','');
var
  i : Byte;
  StrToFind : string;
begin
  for i:=Low(TR) to High(TR) do
  begin
    StrToFind := LowerCase(AttrName)+'='+TR[i];
    if NeedAttrValue then
    StrToFind := StrToFind + LowerCase(AttrValue)+TR[i];
    Result := Pos(StrToFind,LowerCase(Html));
    if Result>0 then
    begin
      Result := Result + Length(StrToFind);
      Break;
    end;
  end;
end;

function GetTagInnerHtml(Html,TagName : string; var EndPos : Integer): string;
var
  iPos : Integer;
  TagStr : string;
begin
  Result := '';  Html := LowerCase(Html);  TagName := LowerCase(TagName);
  iPos := Pos('<'+TagName,Html);
  if iPos>0 then
  begin
    Delete(Html,1,iPos-1);
    TagStr := '</'+TagName;
    EndPos := Pos(TagStr,Html);
    if EndPos>0 then
    begin
      Result := Copy(Html,1,EndPos+Length(TagStr));
      Inc(EndPos,iPos+Length(TagStr));
    end;
  end;
end;

function GetTagInnerHtmls(Html,TagName : string; Htmls : TStringList):Integer;
var
  EndPos : Integer;
  InnerHtml : string;
begin
  repeat
    InnerHtml := GetTagInnerHtml(Html,TagName,EndPos);
    if InnerHtml<>'' then
    begin
      Htmls.Add(InnerHtml);
      Delete(Html,1,EndPos-1);
    end;
  until InnerHtml = '';
  Result := Htmls.Count;
end;

function GetTagHtml(Html : string; InnerPos : Integer):string;
var
  iBeginPos,iEndPos : Integer;
begin
  iBeginPos := FindTagHtmlByAttrPos(Html,TRUE ,InnerPos);
  iEndPos := FindTagHtmlByAttrPos(Html,FALSE,InnerPos);
  Result := Copy(Html,iBeginPos,iEndPos-iBeginPos+1);
end;

function GetAttrValue(TagHtml,AttrName : string):string;
var
  iPos, Ct: Integer;
begin
  iPos := FindAttrPos(TagHtml,AttrName,'',False);
  if iPos>0 then
  begin
    Ct := FindAttrEnd(TagHtml,iPos)-iPos+1;
    Result := Copy(TagHtml,iPos,Ct);
  end;
end;

//unsatisfied use
function GetValByName(Html, TagValue: string) : string;
var
  iPos: Integer;
  TagHtml : string;
begin
  iPos := FindAttrPos(Html,'NAME',TagValue);
  if iPos>0 then
  begin
    TagHtml := GetTagHtml(Html,iPos);
    Result := GetAttrValue(TagHtml,'VALUE');
  end;
end;


function GetTagInnerHtmlByAttr(Html,TagName,AttrName,AttrValue : string):string;
var
  Forms : TStringList;
  FormFound,i,iPos : Byte;
  TagHtml : string;
begin
  Result := '';
  Forms := TStringList.Create;
  FormFound := GetTagInnerHtmls(Html,TagName,Forms);
  if FormFound > 0 then
  for i:=0 to FormFound-1 do
  begin
    TagHtml := GetTagHtml(Forms[i],Length(TagName));
    iPos := FindAttrPos(TagHtml,AttrName,AttrValue);
    if iPos>0 then
    begin
      Result := Forms[i];
      Break;
    end;
  end;
  Forms.Free;
end;



function ExtractHtmlTagValues(const HtmlText: string; TagName, AttribName: string; var Values: TStringList): integer;

function FindFirstCharAfterSpace(const Line: string; StartPos: integer): Integer;
var i: integer;
begin
  Result := -1;
  for i := StartPos to Length(Line) do
  begin
    if (Line[i] <> ' ') then
    begin
      Result := i;
      exit; 
    end; 
  end; 
end; 

function FindFirstSpaceAfterChars(const Line: string; StartPos: integer): Integer; 
begin 
  Result := PosEx(' ', Line, StartPos);
end; 

function FindFirstSpaceBeforeChars(const Line: string; StartPos: integer): Integer;
var i: integer; 
begin 
  Result := 1; 
  for i := StartPos downto 1 do 
  begin 
    if (Line[i] = ' ') then 
    begin 
      Result := i; 
      exit; 
    end; 
  end; 
end; 

var InnerTag: string; 
    LastPos, LastInnerPos: Integer; 
    SPos, LPos, RPos: Integer; 
    AttribValue: string; 
    ClosingChar: char; 
    TempAttribName: string; 
begin 
  Result := 0;
  LastPos := 1;
  while (true) do
  begin
    // find outer tags '<' & '>'
    LPos := PosEx('<', HtmlText, LastPos);
    if (LPos <= 0) then break;
    RPos := PosEx('>', HtmlText, LPos+1);
    if (RPos <= 0) then
      LastPos := LPos + 1
    else
      LastPos := RPos + 1; 

    // get inner tag 
    InnerTag := Copy(HtmlText, LPos+1, RPos-LPos-1); 
    InnerTag := Trim(InnerTag); // remove spaces 
    if (Length(InnerTag) < Length(TagName)) then continue; 

    // check tag name 
    if (SameText(Copy(InnerTag, 1, Length(TagName)), TagName)) then 
    begin 
      // found tag 
      AttribValue := ''; 
      LastInnerPos := Length(TagName)+1; 
      while (LastInnerPos < Length(InnerTag)) do 
      begin 
        // find first '=' after LastInnerPos 
        RPos := PosEx('=', InnerTag, LastInnerPos); 
        if (RPos <= 0) then break; 

        // this way you can check for multiple attrib names and not a specific attrib 
        SPos := FindFirstSpaceBeforeChars(InnerTag, RPos); 
        TempAttribName := Trim(Copy(InnerTag, SPos, RPos-SPos)); 
        if (true) then 
        begin 
          // found correct tag 
          LPos := FindFirstCharAfterSpace(InnerTag, RPos+1); 
          if (LPos <= 0) then 
          begin 
            LastInnerPos := RPos + 1; 
            continue; 
          end; 
          LPos := FindFirstCharAfterSpace(InnerTag, LPos); // get to first char after '=' 
          if (LPos <= 0) then continue; 
          if ((InnerTag[LPos] <> '"') and (InnerTag[LPos] <> '''')) then 
          begin 
            // AttribValue is not between '"' or ''' so get it 
            RPos := FindFirstSpaceAfterChars(InnerTag, LPos+1); 
            if (RPos <= 0) then 
              AttribValue := Copy(InnerTag, LPos, Length(InnerTag)-LPos+1) 
            else 
              AttribValue := Copy(InnerTag, LPos, RPos-LPos+1); 
          end 
          else 
          begin 
            // get url between '"' or ''' 
            ClosingChar := InnerTag[LPos]; 
            RPos := PosEx(ClosingChar, InnerTag, LPos+1); 
            if (RPos <= 0) then 
              AttribValue := Copy(InnerTag, LPos+1, Length(InnerTag)-LPos-1) 
            else 
              AttribValue := Copy(InnerTag, LPos+1, RPos-LPos-1) 
          end; 

          if (SameText(TempAttribName, AttribName)) and (AttribValue <> '') then 
          begin 
            Values.Add(AttribValue);
            inc(Result); 
          end; 
        end; 

        if (RPos <= 0) then 
          LastInnerPos := Length(InnerTag) 
        else 
          LastInnerPos := RPos+1; 
      end; 
    end; 
  end; 
end;

function URLEncode(const msg : String) : String;
var
    I : Integer;
begin
    Result := '';
    for I := 1 to Length(msg) do begin
        if msg[I] = ' ' then
            Result := Result + '+'
        else if msg[I] in ['a'..'z', 'A'..'Z', '0'..'9'] then
            Result := Result + msg[I]
        else
            Result := Result + '%' + IntToHex(ord(msg[I]), 2);
    end;
end;


function UrlDecode(const EncodedStr: String): String;
var
  I: Integer;
begin
  Result := '';
  if Length(EncodedStr) > 0 then
  begin
    I := 1;
    while I <= Length(EncodedStr) do
    begin
      if EncodedStr[I] = '%' then
        begin
          Result := Result + Chr(HexToInt(EncodedStr[I+1]
                                       + EncodedStr[I+2]));
          I := Succ(Succ(I));
        end
      else if EncodedStr[I] = '+' then
        Result := Result + ' '
      else
        Result := Result + EncodedStr[I];

      I := Succ(I);
    end;
  end;
end;

Function HexToInt(Hex :String):Int64;
Var Sum : Int64;
    I,L : Integer;
Begin
L := Length(Hex);
Sum := 0;
For I := 1 to L Do
   Begin
   Sum := Sum * 16;
   If ( Ord(Hex[I]) >= Ord('0')) and (Ord(Hex[I]) <= Ord('9')) then
      Sum := Sum + Ord(Hex[I]) - Ord('0')
   else If ( Ord(Hex[I]) >= Ord('A') ) and (Ord(Hex[I]) <= Ord('F')) then
      Sum := Sum + Ord(Hex[I]) - Ord('A') + 10
   else If ( Ord(Hex[I]) >= Ord('a') ) and ( Ord(Hex[I]) <= Ord('f')) then
      Sum := Sum + Ord(Hex[I]) - Ord('a') + 10
   else
      Begin
      Sum := -1;
      break;
      End;
   End;
Result := Sum;
End;



procedure AddLstBPro(ListBox : TListBox; str : string; Insert : boolean; MaxLine : Integer);
var
  Ct : Integer;
begin
  with ListBox do
  begin
    Ct := Count;
    if InSert then
    begin
      if Ct > MaxLine then
      Items.Delete(Ct-1);
      Items.Insert(0,str);
    end else begin
      if Ct > MaxLine then
      Items.Delete(0);
      Items.Add(str);
    end;
  end;
end;