首页  编辑  

历史记录URL单元

Tags: /超级猛料/OS.操作系统/IE.扩展/历史记录、Cache、收藏夹、Cookie/   Date Created:

//***********************************************************

//            UrlHistory ver 1.00 (July 27, 2000)           *

//                                                          *

//                       For Delphi 4 & 5                   *

//                     Freeware Component                   *

//                            by                            *

//                     Per Linds?Larsen                    *

//                   per.lindsoe@larsen.dk                  *

//                                                          *

//                                                          *

//        Documentation and updated versions:               *

//                                                          *

//               http://www.euromind.com/iedelphi           *

//               http://www.intelligo.net/iedelphi          *

//***********************************************************

unit UrlHistory;

interface

uses

 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

 Activex, Comobj;

const

 STATURL_QUERYFLAG_ISCACHED = $00010000;

 STATURL_QUERYFLAG_NOURL = $00020000;

 STATURL_QUERYFLAG_NOTITLE = $00040000;

 STATURL_QUERYFLAG_TOPLEVEL = $00080000;

 STATURLFLAG_ISCACHED = $00000001;

 STATURLFLAG_ISTOPLEVEL = $00000002;

 IID_IEnumStatUrl: TGUID = (D1: $3C374A42; D2: $BAE4; D3: $11CF; D4: ($BF, $7D, $00, $AA, $00, $69, $46, $EE));

 IID_IUrlHistoryStg: TGUID = (D1: $3C374A41; D2: $BAE4; D3: $11CF; D4: ($BF, $7D, $00, $AA, $00, $69, $46, $EE));

 IID_IUrlHistoryStg2: TGUID = (D1: $AFA0DC11; D2: $C313; D3: $831A; D4: ($83, $1A, $00, $C0, $4F, $D5, $AE, $38));

 IID_IUrlHistoryNotify: TGUID = (D1: $BC40BEC1; D2: $C493; D3: $11D0; D4: ($83, $1B, $00, $C0, $4F, $D5, $AE, $38));

 SID_IEnumStatUrl = '{3C374A42-BAE4-11CF-BF7D-00AA006946EE}';

 SID_IUrlHistoryStg = '{3C374A41-BAE4-11CF-BF7D-00AA006946EE}';

 SID_IUrlHistoryStg2 = '{AFA0DC11-C313-11d0-831A-00C04FD5AE38}';

 SID_IURLHistoryNotify = '{BC40BEC1-C493-11d0-831B-00C04FD5AE38}';

 CLSID_CUrlHistory: TGUID = '{3C374A40-BAE4-11CF-BF7D-00AA006946EE}';

type

 TSTATURL = record

   cbSize: DWORD;

   pwcsUrl: DWORD;

   pwcsTitle: DWORD;

   ftLastVisited: FILETIME;

   ftLastUpdated: FILETIME;

   ftExpires: FILETIME;

   dwFlags: DWORD;

 end;

 PEntry = ^TEntry;

 TEntry = record

   Url: string;

   Title: string;

   Lastvisited,

     LastUpdated,

     Expires: TDateTime;

 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;

 IUrlHistoryNotify = interface(IOleCommandTarget)

   ['{BC40BEC1-C493-11d0-831B-00C04FD5AE38}']

 end;

 TSortDirectionOption = (sdAscending, sdDescending);

 TSortFieldOption = (sfTitle, sfURL, sfLastVisited, sfLastUpdated, sfExpires);

 TSearchFieldOption = (seBoth, seTitle, seURL);

type

 TOnAcceptEvent = Procedure(Title, Url : String; LastVisited, LastUpdated, Expires: TDateTime;

                               var Accept : Boolean) of object;

 TOnDeleteEvent = procedure(Title, Url : String; LastVisited, LastUpdated, Expires: TDateTime;

                               var Delete : Boolean) of object;

 TUrlHistory = class(TComponent)

 private

   { Private declarations }

   FSearch : String;

   FAccept : Boolean;

   FDelete : Boolean;

   FOnDelete : TOnDeleteEvent;

   FOnAccept : TOnAcceptEvent;

   FSortDirection: TSortDirectionOption;

   FSortField: TSortFieldOption;

   FSearchField: TSearchFieldOption;

   Stg: IUrlHistoryStg2;

   Enum: IEnumStatUrl;

 protected

   { Protected declarations }

   procedure ClearList;

   procedure Accept(Title, Url : String; LastVisited, LastUpdated, Expires: TDateTime;

                               var Accept : Boolean);

   procedure Delete(Title, Url : String; LastVisited, LastUpdated, Expires: TDateTime;

                               var Delete : Boolean);

   procedure Loaded; override;

 public

   Items: TList;

   { Public declarations }

   constructor Create(AOwner: TComponent); override;

   destructor Destroy; override;

   function Enumerate: Integer;

   function DeleteEntries: Integer;

   function AddUrl(Url: PWideChar; Title: PWideChar): HResult;

   function DeleteUrl(Url: PWideChar): HResult;

   function QueryUrl(Url: PWideChar; var Entry: TEntry): HResult;

   function ClearHistory: HResult;

 published

   { Published declarations }

   property OnAccept : TOnAcceptEvent read FOnAccept write FOnAccept;

   property OnDelete : TOnDeleteEvent read FOnDelete write FOnDelete;

   property SortField: TSortFieldOption read FSortField write FSortField;

   property SearchField: TSearchFieldOption read FSearchField write FSearchField;

   property Search : String read FSearch write FSearch;

   property SortDirection: TSortDirectionOption read FSortDirection write FSortDirection;

 end;

procedure Register;

implementation

var

 Ascending: Boolean;

procedure Register;

begin

 RegisterComponents('Samples', [TUrlHistory]);

end;

function TitleSortFunc(Item1, Item2: Pointer): Integer;

begin

 if ((PEntry(Item1).Title < PEntry(Item2).Title) and Ascending)

   or ((PEntry(Item1).Title > PEntry(Item2).Title) and not Ascending)

   then result := -1

 else

   if PEntry(Item1).Title = PEntry(Item2).Title then result := 0

   else Result := 1;

end;

function UrlSortFunc(Item1, Item2: Pointer): Integer;

begin

 if ((PEntry(Item1).Url < PEntry(Item2).Url) and Ascending)

   or ((PEntry(Item1).Url > PEntry(Item2).Url) and not Ascending)

   then result := -1

 else

   if PEntry(Item1).Url = PEntry(Item2).Url then result := 0

   else Result := 1;

end;

function LastVisitedSortFunc(Item1, Item2: Pointer): Integer;

begin

 if ((PEntry(Item1).LastVisited < PEntry(Item2).LastVisited) and Ascending)

   or ((PEntry(Item1).LastVisited > PEntry(Item2).LastVisited) and not Ascending)

   then result := -1

 else

   if PEntry(Item1).LastVisited = PEntry(Item2).LastVisited then result := 0

   else Result := 1;

end;

function LastUpdatedSortFunc(Item1, Item2: Pointer): Integer;

begin

 if ((PEntry(Item1).LastUpdated < PEntry(Item2).LastUpdated) and Ascending)

   or ((PEntry(Item1).LastUpdated > PEntry(Item2).LastUpdated) and not Ascending)

   then result := -1

 else

   if PEntry(Item1).LastUpdated = PEntry(Item2).LastUpdated then result := 0

   else Result := 1;

end;

function ExpiresSortFunc(Item1, Item2: Pointer): Integer;

begin

 if ((PEntry(Item1).Expires < PEntry(Item2).Expires) and Ascending)

   or ((PEntry(Item1).Expires > PEntry(Item2).Expires) and not Ascending)

   then result := -1

 else

   if PEntry(Item1).Expires = PEntry(Item2).Expires then result := 0

   else Result := 1;

end;

function FileTimeToDt(Ft: TFileTime): TDateTime;

var

 l: Integer;

 lft: TFileTime;

begin

 FileTimeToLocalFiletime(Ft, lft);

 if FileTimeToDosDateTime(lft, Longrec(l).Hi, Longrec(l).Lo) then

   result := FiledateToDatetime(l) else

   result := 0;

end;

{ TUrlHistory }

function TUrlHistory.AddUrl(Url, Title: PWideChar): HResult;

begin

 Result := Stg.AddUrl(Url, Title, 0);

end;

function TUrlHistory.ClearHistory: HResult;

begin

 Result:=Stg.ClearHistory;

end;

constructor TUrlHistory.Create(AOwner: TComponent);

begin

 inherited;

end;

function TUrlHistory.DeleteUrl(Url: PWideChar): HResult;

begin

 Result:=stg.DeleteUrl(Url, 0);

end;

procedure TUrlHistory.ClearList;

var

 I: Integer;

begin

 if Items <> nil then

 begin

   for I := 0 to Items.Count - 1 do

     Dispose(PEntry(Items[i]));

   items.Clear;

 end;

end;

function TUrlHistory.Enumerate: Integer;

var

 staturl: TStaturl;

 title, Url: string;

 Entry: PEntry;

 Fetched: Integer;

begin

 ClearList;

 Stg.EnumUrls(Enum);

 while enum.next(1, StatUrl, @Fetched) = S_OK do

 begin

Url:=PWidechar(Pointer(Staturl.pwcsUrl));

Title := PWidechar(Pointer(Staturl.pwcsTitle));

If FSearch<>'' then

If ((FSearchField=seUrl) and (Pos(FSearch,Url)=0)) or

((FSearchField=seTitle) and (Pos(FSearch,Title)=0)) or

((FSearchField=seBoth) and ((Pos(FSearch,Url)=0)) or (Pos(FSearch,Title)=0))

then Continue;

   Entry := New(PEntry);

   Entry.Url := Url;

   Entry.Title := Title;

   Entry.Lastvisited := FileTimeToDt(Staturl.ftLastVisited);

   Entry.LastUpdated := FileTimeToDt(Staturl.ftLastUpdated);

   Entry.Expires := FileTimeToDt(Staturl.ftExpires);

   FAccept:=True;

   If Assigned(FOnAccept) then FOnAccept(Entry.Title,Entry.Url,Entry.LastVisited,Entry.LastUpdated,Entry.Expires,FAccept);

   If FAccept then Items.Add(Entry);

 end;

 Ascending := BOOL(FSortDirection = sdAscending);

 case FSortField of

   sfTitle: items.Sort(TitleSortFunc);

   sfUrl: items.Sort(UrlSortFunc);

   sfLastVisited: items.Sort(LastVisitedSortFunc);

   sfLastUpdated: items.Sort(LastUpdatedSortFunc);

   sfExpires: items.Sort(ExpiresSortFunc);

 end;

 Result := Items.Count;

end;

procedure TUrlHistory.Loaded;

begin

 inherited;

 Items := TList.Create;

 Stg := CreateComObject(CLSID_CUrlHistory) as IUrlHistoryStg2;

end;

destructor TUrlHistory.Destroy;

begin

 Clearlist;

 if Items <> nil then Items.Free;

 inherited;

end;

procedure TUrlHistory.Accept(Title, Url: String; LastVisited, LastUpdated,

 Expires: TDateTime; var Accept: Boolean);

begin

end;

procedure TUrlHistory.Delete(Title, Url: String; LastVisited, LastUpdated,

 Expires: TDateTime; var Delete: Boolean);

begin

end;

function TUrlHistory.DeleteEntries: Integer;

var

StatUrl : TStatUrl;

Fetched : Integer;

begin

Result:=0;

 Stg.EnumUrls(Enum);

 while enum.next(1, StatUrl, @Fetched) = S_OK do

 begin

 FDelete := False;

 If Assigned(FOnDelete) then

 FOnDelete(PWidechar(Pointer(Staturl.pwcsUrl)),

   PWidechar(Pointer(Staturl.pwcsTitle)),

   FileTimeToDt(Staturl.ftLastVisited),

   FileTimeToDt(Staturl.ftLastUpdated),

   FileTimeToDt(Staturl.ftExpires),

   FDelete);

 If FDelete then

 begin

 Stg.DeleteUrl(PWidechar(Pointer(Staturl.pwcsUrl)),0);

 Inc(Result);

 end;

end;

end;

function TUrlHistory.QueryUrl(Url: PWideChar; var Entry: TEntry): HResult;

var

Staturl : TStaturl;

begin

Result:=Stg.QueryUrl(Url,0,Staturl);

if Result=S_OK then begin

   Entry.Url := PWidechar(Pointer(Staturl.pwcsUrl));

   Entry.Title := PWidechar(Pointer(Staturl.pwcsTitle));

   Entry.Lastvisited := FileTimeToDt(Staturl.ftLastVisited);

   Entry.LastUpdated := FileTimeToDt(Staturl.ftLastUpdated);

   Entry.Expires := FileTimeToDt(Staturl.ftExpires);

  end;

end;

end.