unit1.pas

在delphi中实现windows核心编程.原书光盘代码核心编程.原书光盘代码

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls,Registry,wininet,FileCtrl,shlobj,shellapi;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}
procedure DelRegCache;
var
   reg:TRegistry;
begin
   reg:=Tregistry.create;
   reg.RootKey:=HKEY_CURRENT_USER;
   reg.DeleteKey('Software\Microsoft\Internet Explorer\TypedURLs');
   reg.Free;
end;

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 TForm1.Button1Click(Sender: TObject);
begin
  try
    screen.cursor:=crHourGlass;
    DelRegCache;
    DelCookie;
    DelHistory;
  finally
    screen.cursor:=crDefault;
  end;
end;

end.