delphi 缓存图片查看器

{$WARNINGS OFF}

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, ActiveX, Menus, ComCtrls, Buttons;

type
TForm1 = class(TForm)
    Panel3: TPanel;
    ListBox1: TListBox;
    sbA: TScrollBox;
    Image1: TImage;
    Panel1: TPanel;
    Panel2: TPanel;
    SpeedButton1: TSpeedButton;
    SpeedButton2: TSpeedButton;
    PopupMenu1: TPopupMenu;
    Cookies1: TMenuItem;
    N1: TMenuItem;
    N3: TMenuItem;
    N4: TMenuItem;
    N5: TMenuItem;
    N6: TMenuItem;
    JPG1: TMenuItem;
    BMP1: TMenuItem;
    GIF1: TMenuItem;
    N2: TMenuItem;
    N7: TMenuItem;
    N8: TMenuItem;
    N9: TMenuItem;
    N10: TMenuItem;
    N11: TMenuItem;
    N12: TMenuItem;
    N13: TMenuItem;

    procedure ListBox1Click(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    procedure SpeedButton2Click(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure Cookies1Click(Sender: TObject);
    procedure N1Click(Sender: TObject);
    procedure N13Click(Sender: TObject);
private
    procedure GetInternetCacheFiles(AList: TStringList);
    procedure DeleteInternetCacheFiles;
    procedure DisposeListBoxObject;
    procedure BList(Sender: TObject);
public
    end;

type
TSTATURL = record
    cbSize: DWORD;
    pwcsUrl: DWORD;
    pwcsTitle: DWORD;
    ftLastVisited: FILETIME;
    ftLastUpdated: FILETIME;
    ftExpires: FILETIME;
    dwFlags: DWORD;
end;

IEnumSTATURL = interface(IUnknown)
    ['{3C374A42-BAE4-11CF-BF7D-00AA006946EE}']
    function Next(celt: Integer; out elt; pceltFetched: PLongint): HRESULT; stdcall;
    function Skip(celt: Longint): HRESULT; stdcall;
    function Reset: HResult; stdcall;
    function Clone(out ppenum: IEnumSTATURL): HResult; stdcall;
    function SetFilter(poszFilter: PWideChar; dwFlags: DWORD): HResult; stdcall;
end;

IUrlHistoryStg = interface(IUnknown)
    ['{3C374A41-BAE4-11CF-BF7D-00AA006946EE}']
    function AddUrl(pocsUrl: PWideChar; pocsTitle: PWideChar;
      dwFlags: Integer): HResult; stdcall;
    function DeleteUrl(pocsUrl: PWideChar;
      dwFlags: Integer): HResult; stdcall;
    function QueryUrl(pocsUrl: PWideChar; dwFlags: Integer;
      var lpSTATURL: TSTATURL): HResult; stdcall;
    function BindToObject(pocsUrl: PWideChar; var riid: TIID;
      out ppvOut: Pointer): HResult; stdcall;
    function EnumUrls(out ppenum: IEnumSTATURL): HResult; stdcall;
end;

IUrlHistoryStg2 = interface(IUrlHistoryStg)
    ['{AFA0DC11-C313-11D0-831A-00C04FD5AE38}']
    function AddUrlAndNotify(pocsUrl: PWideChar; pocsTitle: PWideChar;
      dwFlags: Integer; fWriteHistory: Integer; var poctNotify: Pointer;
      const punkISFolder: IUnknown): HResult; stdcall;
    function ClearHistory: HResult; stdcall;
end;

var
Form1: TForm1;

implementation

uses jpeg, ComObj, WinInet, HTTPApp;

{$R *.dfm}

procedure ClearInternetExplorerHistroy;
const CLSID_CUrlHistory: TGUID = '{3C374A40-BAE4-11CF-BF7D-00AA006946EE}';
var
stg: IUrlHistoryStg2;
begin
stg := CreateComObject(CLSID_CUrlHistory) as IUrlHistoryStg2;
stg.ClearHistory;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
DisposeListBoxObject;
end;

procedure TForm1.ListBox1Click(Sender: TObject);
var
AFilePath: string;
jpg: TJpegImage;
begin
if ListBox1.Items.Count = 0 then exit;

Caption := format('IE缓存图片查看器 [%d/%d]', [listbox1.itemindex + 1, listbox1.Count]);
AFilePath := PString(ListBox1.Items.Objects[ListBox1.ItemIndex])^;
Image1.Picture.Assign(nil);
Jpg := TJpegImage.Create;
Jpg.LoadFromFile(AFilePath);

sbA.HorzScrollBar.Position := jpg.Width; //
sbA.VertScrollBar.Position := jpg.Height;
Image1.Width := jpg.Width; //
Image1.Height := jpg.Height;
Image1.Top := (sba.height - jpg.Height) div 2;
Image1.Left := (sba.width - jpg.Width) div 2;
Image1.Picture.Assign(jpg);
jpg.free;
end;

procedure TForm1.DisposeListBoxObject;
var
i: integer;
begin
for i := 0 to ListBox1.Items.Count - 1 do begin
    Dispose(PString(ListBox1.Items.Objects[i]));
end;
end;

procedure TForm1.GetInternetCacheFiles(AList: TStringList);
var
lpEntryInfo: PInternetCacheEntryInfo;
hCacheDir: LongWord;
dwEntrySize: LongWord;
dwLastError: LongWord;
begin
AList.Clear;
dwEntrySize := 0;
FindFirstUrlCacheEntry(nil, TInternetCacheEntryInfo(nil^), dwEntrySize);
GetMem(lpEntryInfo, dwEntrySize);
hCacheDir := FindFirstUrlCacheEntry(nil, lpEntryInfo^, dwEntrySize);
if hCacheDir <> 0 then begin
   // lpEntryInfo^.LastModifiedTime
    AList.Add(string(lpEntryInfo^.lpszLocalFileName));
    FreeMem(lpEntryInfo);
    repeat
      dwEntrySize := 0;
      FindNextUrlCacheEntry(hCacheDir, TInternetCacheEntryInfo(nil^), dwEntrySize);
      dwLastError := GetLastError();
      if GetLastError = ERROR_INSUFFICIENT_BUFFER then begin
        GetMem(lpEntryInfo, dwEntrySize);
        if FindNextUrlCacheEntry(hCacheDir, lpEntryInfo^, dwEntrySize) then begin
          AList.Add(string(lpEntryInfo^.lpszLocalFileName));
        end;
        FreeMem(lpEntryInfo);
      end;
    until dwLastError = ERROR_NO_MORE_ITEMS;
end else begin
    FreeMem(lpEntryInfo);
end;
end;

procedure TForm1.DeleteInternetCacheFiles;
var
lpEntryInfo: PInternetCacheEntryInfo;
hCacheDir: LongWord;
dwEntrySize: LongWord;
dwLastError: LongWord;
begin
dwEntrySize := 0;
FindFirstUrlCacheEntry(nil, TInternetCacheEntryInfo(nil^), dwEntrySize);
GetMem(lpEntryInfo, dwEntrySize);
hCacheDir := FindFirstUrlCacheEntry(nil, lpEntryInfo^, dwEntrySize);
if hCacheDir <> 0 then begin
    if (lpEntryInfo^.CacheEntryType and COOKIE_CACHE_ENTRY) = 0 then begin
      DeleteUrlCacheEntry(lpEntryInfo^.lpszSourceUrlName);
    end;
    FreeMem(lpEntryInfo);

    repeat
      dwEntrySize := 0;
      FindNextUrlCacheEntry(hCacheDir, TInternetCacheEntryInfo(nil^), dwEntrySize);
      dwLastError := GetLastError();
      if GetLastError = ERROR_INSUFFICIENT_BUFFER then begin
        GetMem(lpEntryInfo, dwEntrySize);
        if FindNextUrlCacheEntry(hCacheDir, lpEntryInfo^, dwEntrySize) then begin
          if (lpEntryInfo^.CacheEntryType and COOKIE_CACHE_ENTRY) = 0 then begin
            DeleteUrlCacheEntry(lpEntryInfo^.lpszSourceUrlName);
          end;
        end;
        FreeMem(lpEntryInfo);
      end;
    until dwLastError = ERROR_NO_MORE_ITEMS;
end else begin
    FreeMem(lpEntryInfo);
end;
end;

procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
if listbox1.ItemIndex < 1 then exit;
listbox1.ItemIndex := listbox1.ItemIndex - 1;
ListBox1Click(Sender);

end;

procedure TForm1.SpeedButton2Click(Sender: TObject);
begin

if listbox1.ItemIndex = listbox1.items.count then exit;
listbox1.ItemIndex := listbox1.ItemIndex + 1;
ListBox1Click(Sender);
end;

procedure TForm1.BList(Sender: TObject);
var
APathList: TStringList;
AFileName: string;
i: Integer;
begin
if ListBox1.Items.Count = 0 then DisposeListBoxObject;
ListBox1.Items.Clear;
APathList := TStringList.Create;
try
    GetInternetCacheFiles(APathList);
    with ListBox1.Items do begin
      BeginUpdate;
      for i := 0 to APathList.Count - 1 do begin
        AFileName := UnixPathToDosPath(APathList[i]);
        if ExtractFileExt(AFileName) = '.jpg' then begin
          AddObject(ExtractFileName(AFileName), TObject(NewStr(AFileName)));
        end;
      end;
      EndUpdate;
     // Caption := format('IE缓存图片查看器 [%d/%d]', [listbox1.itemindex+1, listbox1.Count]);
    end;
finally
    FreeAndNil(APathList);
end;
listbox1.itemindex := 0;
ListBox1Click(Sender);
end;

procedure TForm1.FormResize(Sender: TObject);
begin
panel2.Top := 0;
panel2.Left := panel1.width div 2 - panel2.Width div 2;
Image1.Top := (sba.height - Image1.Height) div 2;
Image1.Left := (sba.width - Image1.Width) div 2;
end;

procedure TForm1.FormShow(Sender: TObject);
begin
BList(Sender);
end;

procedure TForm1.Cookies1Click(Sender: TObject);
begin
DeleteInternetCacheFiles;
end;

procedure TForm1.N1Click(Sender: TObject);
begin
ClearInternetExplorerHistroy;
end;

procedure TForm1.N13Click(Sender: TObject);
begin
if listbox1.Width = 0 then
begin
    listbox1.Width := 200 ;
      N13.Checked := true;
end else
begin
    listbox1.Width := 0;
    N13.Checked := false;
end;
Image1.Top := (sba.height - Image1.Height) div 2;
Image1.Left := (sba.width - Image1.Width) div 2;
end;

end.