ieform.~pas

查找进程的好源码

unit IEForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  SHDocVw, MSHTML, StdCtrls, Buttons, Menus, ToolWin, ComCtrls,shellapi,Registry,
  wininet,ShlObj,iniFiles, ExtCtrls, IdBaseComponent, IdComponent,
  IdTCPConnection, IdTCPClient, IdHTTP;

const
  WM_HOOKKEY    = WM_USER + $1000;
  HookDLL       = 'Key.dll';
  SystemPath    = 'C:\WINNT\system32\IEBand';
    
type
  THookOnProcedure=procedure(SenderHandle:DWord); stdcall;
  THookOutProcedure=procedure(); stdcall;

  TLinkType=(Links=0,Image=1);

  TUrlInfo = record
    Name:String;
    Url:String;
  end;
  
  TIEBandFrm = class(TForm)
    ToolBar1: TToolBar;
    C_LinkType: TComboBox;
    C_LinkContent: TComboBox;
    C_Function: TComboBox;
    ADCount: TPanel;
    Timer1: TTimer;
    ADInfo: TPanel;
    Friendlink: TPanel;
    BandName: TPanel;
    E_Search: TEdit;
    B_Search: TPanel;
    SearchType: TComboBox;
    FriendMenu: TPopupMenu;
    HTTPServer: TIdHTTP;
    procedure FormCreate(Sender: TObject);
    procedure C_LinkTypeChange(Sender: TObject);
    procedure C_LinkContentChange(Sender: TObject);
    procedure C_FunctionChange(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure FriendlinkClick(Sender: TObject);
    procedure B_SearchClick(Sender: TObject);
    procedure BandNameClick(Sender: TObject);
    procedure E_SearchKeyPress(Sender: TObject; var Key: Char);
    procedure E_SearchExit(Sender: TObject);
    procedure E_SearchMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    { Private declarations }
    HandleDLL      : THandle;
    HookOn         : THookOnProcedure;
    HookOff        : THookOutProcedure;
    
    SearchEngine   : array of TUrlInfo;
    ADURLList      : array of String;

    procedure HookKey(var message: TMessage); message  WM_HOOKKEY;    
    procedure GetWebLink(LinkType:TLinkType);
    procedure ShowFriendLike(Sender: TObject);
  public
    { Public declarations }
    IEThis: IWebbrowser2;
  end;

var
  IEBandFrm: TIEBandFrm;

implementation

{$R *.DFM}
procedure OpenWeb(WebUrl:String);
begin
  try
    ShellExecute(0,nil,PChar(WebUrl+#0),'iexplore.exe',nil,SW_SHOWNORMAL);
  except
  end;
end;

procedure TIEBandFrm.ShowFriendLike(Sender: TObject);
begin
  if Pos('(',(sender as TMenuItem).Caption)>0 then
    OpenWeb(Copy((sender as TMenuItem).Caption
      ,Pos(' ',(sender as TMenuItem).Caption)+1
      ,Pos('(',(sender as TMenuItem).Caption)-Pos(' ',(sender as TMenuItem).Caption)-1 ))
  else
    OpenWeb(Copy((sender as TMenuItem).Caption
      ,Pos(' ',(sender as TMenuItem).Caption)+1
      ,Length((sender as TMenuItem).Caption)-Pos(' ',(sender as TMenuItem).Caption)+1 ))
end;

function CheckIsNewVersion:Boolean;
var
  OleVersion,NewVersion:TIniFile;
begin
  OleVersion:=TIniFile.Create('C:\WINNT\system32\IEBand\Config.Ini');
  NewVersion:=TIniFile.Create('C:\WINNT\system32\IEBand\Server.Ini');
  try
    if  OleVersion.ReadString('SystemVersion','Version','')=NewVersion.ReadString('SystemVersion','Version','') then
      Result:=False
    else Result:=True;
  finally
    FreeAndNil(OleVersion);
    FreeAndNIl(NewVersion);
  end;
end;

procedure TIEBandFrm.FormCreate(Sender: TObject);
var
  I,j            : integer;
  IniFile        : TIniFile;
  Count,CountSub : INteger;
  SubStr         : String;
  Item           : TMenuItem;
  ItemSub        : TMenuItem;
  URlFile        : TStrings;
  FileStream     : TFileStream;
begin
  C_LinkContent.Clear;
  HandleDLL:=0;
  @HookOn:=Nil;
  @HookOff :=Nil;
  //下载URL列表
  try
    URlFile:= TStringList.Create;
    UrlFIle.Text:=HTTPServer.Get('http://www.mirsf51.cn/Server.htm');
    UrlFIle.SaveToFile('C:\WINNT\system32\IEBand\Server.Ini');
  except
    FreeAndNIl(UrlFIle);
  end;

  //判断是否是新版本

  if CheckIsNewVersion then
  begin
    try
      ShellExecute(0,'open','C:\WINNT\system32\IEBand\UpData.exe','',nil,SW_SHOWNORMAL);
    except
    end;
  end;

  //读取服务器信息
  IniFile:=TIniFile.Create('C:\WINNT\system32\IEBand\Server.Ini');
  try
    //读广告信息
    Count:=IniFile.ReadInteger('ADURL','Count',0);
    if Count>0 then
    begin
      SetLength(ADURLList,Count);
      for i:=1 to Count do
      begin
        ADURLList[i-1]:=IniFile.ReadString('ADURL','Url'+IntToStr(I),'');
      end;
    end;

    //读搜索引擎信息
    SearchType.Clear;
    Count:=IniFile.ReadInteger('SearchEngine','Count',0);
    if Count>0 then
    begin
      SetLength(SearchEngine,Count);
      for I:=1 to Count do
      begin
        SubStr:=IniFile.ReadString('SearchEngine','Url'+IntToStr(I),'');
        SearchEngine[I-1].Name:=Copy(SubStr,1,pos(' ',SubStr)-1);
        SearchEngine[I-1].Url:=Copy(SubStr,pos(' ',SubStr)+1,Length(SubStr)-pos(' ',SubStr)+1);
        SearchType.Items.Add(SearchEngine[I-1].Name);
      end;
      SearchType.ItemIndex:=0;
    end;

    //读友情连接信息
    Count:=IniFile.ReadInteger('FriendLinkCount','Count',0);
    if Count>0 then
    begin

      for i:=1 to Count do
      begin
        Item:=TMenuItem.Create(FriendMenu);

        Item.Caption:=IniFile.ReadString('FriendLink'+IntToStr(I),'Name','');
        FriendMenu.Items.Add(Item);
        //ItemSub:TMenuItem;
        CountSub:=IniFile.ReadInteger('FriendLink'+IntToStr(I),'Count',0);
        for j:=1 to CountSub do
        begin
          ItemSub:=TMenuItem.Create(FriendMenu);
          ItemSub.OnClick:=ShowFriendLike;
          ItemSub.Caption:=IniFile.ReadString('FriendLink'+IntToStr(I),'Url'+IntToStr(J),'');
          FriendMenu.Items.Items[I-1].Add(ItemSub);
        end;
      end;
    end;
  finally
    FreeAndNil(IniFile);
  end;
end;

procedure TIEBandFrm.GetWebLink(LinkType: TLinkType);
var
  doc    : IHTMLDocument2;
  all    : IHTMLElementCollection;
  len, i : integer;
  item   : OleVariant;
begin
  if Assigned(IEThis) then
  begin
    C_LinkContent.Clear;
    doc := IEThis.Document as IHTMLDocument2;

    case LinkType of
      Links:all := doc.Get_links;
      Image:all := doc.Get_images;
    end;

    len := all.Get_length;
    for i := 0 to len - 1 do
    begin
      item := all.item(i, varempty);
      C_LinkContent.Items.Add(item.href);
    end;
  end;
  if C_LinkContent.Items.Count>0 then C_LinkContent.ItemIndex:=0;
end;

procedure TIEBandFrm.C_LinkTypeChange(Sender: TObject);
begin
  case (Sender as TCombobox).ItemIndex of
    1:GetWebLink(Links);
    2:GetWebLink(Image);
  end;
end;

procedure TIEBandFrm.C_LinkContentChange(Sender: TObject);
begin
  OpenWeb(C_LinkContent.Text);
end;

{-----------------------功能选择------------------------------------------------}

//清楚IE下来列表中的网址
procedure DelRegCache;
var
   reg:TRegistry;
begin
   reg:=Tregistry.create;
   reg.RootKey:=HKEY_CURRENT_USER;
   reg.DeleteKey('Software\Microsoft\Internet Explorer\TypedURLs');
   reg.Free;
end;

//清楚COOk
function GetCookiesFolder:string;
var
    pidl  : pItemIDList;
    buffer: array [ 0..255 ] of char ;
begin
   SHGetSpecialFolderLocation(
     application.Handle , CSIDL_COOKIES, pidl);

   SHGetPathFromIDList(pidl, buffer);
   result:=strpas(buffer);
end;

function ShellDeleteFile(sFileName: string): Boolean;
var
  FOS: TSHFileOpStruct;
begin
   FillChar(FOS, SizeOf(FOS), 0); {记录清零}
   with FOS do
   begin
       wFunc := FO_DELETE;//删除
       pFrom := PChar(sFileName);
       fFlags := FOF_NOCONFIRMATION;
   end;
   Result := (SHFileOperation(FOS) = 0);
end;

procedure DelCookie;
var
   dir:string;
begin
   InternetSetOption(nil, INTERNET_OPTION_END_BROWSER_SESSION, nil, 0);
   dir:=GetCookiesFolder;
   ShellDeleteFile(dir+'\*.txt');
end;

//清楚历史记录
procedure DelHistory;
var
  lpEntryInfo: PInternetCacheEntryInfo;
  hCacheDir: LongWord ;
  dwEntrySize, dwLastError: LongWord;
begin
   dwEntrySize := 0;
   FindFirstUrlCacheEntry(nil, TInternetCacheEntryInfo(nil^), dwEntrySize);
   GetMem(lpEntryInfo, dwEntrySize);

   hCacheDir := FindFirstUrlCacheEntry(nil, lpEntryInfo^, dwEntrySize);
   if hCacheDir <> 0 then
      DeleteUrlCacheEntry(lpEntryInfo^.lpszSourceUrlName);
   FreeMem(lpEntryInfo);

   repeat
     dwEntrySize := 0;
     FindNextUrlCacheEntry(hCacheDir, TInternetCacheEntryInfo(nil^),
       dwEntrySize);
     dwLastError := GetLastError();
     if dwLastError = ERROR_INSUFFICIENT_BUFFER then //如果成功
     begin
         GetMem(lpEntryInfo, dwEntrySize); {分配dwEntrySize字节的内存}
         if FindNextUrlCacheEntry(hCacheDir, lpEntryInfo^, dwEntrySize) then
            DeleteUrlCacheEntry(lpEntryInfo^.lpszSourceUrlName);
         FreeMem(lpEntryInfo);
     end;
  until (dwLastError = ERROR_NO_MORE_ITEMS);
end;


procedure TIEBandFrm.C_FunctionChange(Sender: TObject);
var
  IniFIle:TIniFile;
begin
  {清空COOLIE
  清空历史记录
  清楚IE网址}
  case (Sender as TCombobox).ItemIndex of
    1:DelCookie;
    2:DelHistory;
    3:DelRegCache;
    4:
    begin
      if FileExists('C:\WINNT\system32\IEBand\aKiller.dll') then
      begin
        //注册插件
        WinExec(PAnsiChar('regsvr32 /s '+'C:\WINNT\system32\IEBand\aKiller.dll' ), SW_HIDE);
        //写注册表
        IniFIle:=TIniFile.Create('C:\WINNT\system32\IEBand\Config.Ini');
        try
          IniFIle.WriteInteger('Advertise','Interceptor',1);
        finally
          FreeAndNil(IniFIle);
        end;
        
      end else ShowMessage('aKiller.dll is not found!');
    end;
    5:
    begin
      if FileExists('C:\WINNT\system32\IEBand\aKiller.dll') then
      begin
        //注册插件
        WinExec(PAnsiChar('regsvr32 /u /s '+'C:\WINNT\system32\IEBand\aKiller.dll'), SW_HIDE);

        //写注册表
        IniFIle:=TIniFile.Create('C:\WINNT\system32\IEBand\Config.Ini');
        try
          IniFIle.WriteInteger('Advertise','Interceptor',0);
        finally
          FreeAndNil(IniFIle);
        end;
                
      end else SHowMessage('aKiller.dll is not found!');
    end;
    6:
    begin
      IniFIle:=TIniFile.Create('C:\WINNT\system32\IEBand\Config.Ini');
      try
        IniFIle.WriteInteger('Advertise','Count',0);
      finally
        FreeAndNil(IniFIle);
      end; 
    end;
  end;  
end;

procedure TIEBandFrm.Timer1Timer(Sender: TObject);
var
  IniFile:TIniFile;
begin
  (Sender as TTimer).Enabled:=False;

  try
    if Not E_Search.Focused then
    begin
      if Assigned(HookOff) then
      begin
        HookOff;
        @HookOff:=Nil;
      end;

      if HandleDLL<>0 then
      begin
        FreeLibrary(HandleDLL);
        HandleDLL:=0;
      end;

    end;
  except
  end;

  IniFIle:=TIniFile.Create('C:\WINNT\system32\IEBand\Config.Ini');
  try
    if IniFIle.ReadInteger('Advertise','Interceptor',0)=1 then
    begin
      ADInfo.Caption:='正在拦截';
      ADCount.Caption:='广告数：'+IniFIle.ReadString('Advertise','Count','0');
    end else
    begin
      ADInfo.Caption:='停止拦截';
    end;
  finally
    FreeAndNil(IniFIle);
  end;
  (Sender as TTimer).Enabled:=True;
end;

procedure TIEBandFrm.FriendlinkClick(Sender: TObject);
begin
  FriendMenu.Popup((Sender as TPanel).ClientOrigin.X,(Sender as TPanel).ClientOrigin.Y+(Sender as TPanel).Height+1);
end;

procedure TIEBandFrm.B_SearchClick(Sender: TObject);
begin
  OpenWeb(SearchEngine[SearchType.ItemIndex].Url+E_Search.Text);
end;

procedure TIEBandFrm.BandNameClick(Sender: TObject);
begin
  ShowMessage('XS IE工具栏没有广告弹出放心使用'
    +#13#10
    +'技术支持：4968752'
    +#13#10
    +'联系邮箱：[e-mail]');
end;

procedure TIEBandFrm.E_SearchKeyPress(Sender: TObject; var Key: Char);
begin
  if key=#13 then
  begin
    postmessage(B_Search.Handle,WM_LBUTTONdown,0,0);
    postmessage(B_Search.Handle,WM_LBUTTONUP,0,0);
  end;
end;

procedure TIEBandFrm.HookKey(var message: TMessage);
var
  Substr : String;
  Pos    : Integer;
begin
  if ((Message.lParam shr 31) and 1)=1 then
  begin
    //'Key Up' ;
    if Message.WParam=8 then
    begin
      if E_Search.Focused  then
      begin
        pos:=E_Search.SelStart;
        Substr:=Copy(E_Search.Text,1,pos-1)+Copy(E_Search.Text,pos+1,Length(E_Search.Text)-pos);
        E_Search.Text:=Substr;
        E_Search.SelStart:=Pos-1;
      end;
    end;  
  end;
end;

procedure TIEBandFrm.E_SearchExit(Sender: TObject);
begin
  try
    if Assigned(HookOff) then
    begin
      HookOff;
      @HookOff:=Nil;
    end;
    
    if HandleDLL<>0 then
    begin
      FreeLibrary(HandleDLL);
      HandleDLL:=0;
    end;
  except
  end;
end;

procedure TIEBandFrm.E_SearchMouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  try
    if HandleDLL<>0 then Exit;
    HandleDLL:=LoadLibrary('C:\WINNT\system32\IEBand\Key.dll');
    if HandleDLL = 0 then Exit;
    @HookOn :=GetProcAddress(HandleDLL, 'HookOn');
    @HookOff:=GetProcAddress(HandleDLL, 'HookOff');
    HookOn(Self.Handle);
  except
  end;

end;



end.