gethis.txt

Delphi 取IE历史记录列表的两个例子程序

uses shlobj,Activex,ComObj;

 

function GetHistoryToday(List: TStrings): Integer;
var
  pvDesktop:        IShellFolder;
  pvFolder:        IShellFolder;
  pvToday:        IShellFolder;
  pvEnumToday:    IEnumIDList;
  pvEnumHist:    IEnumIDList;
  pvMalloc:        IMalloc;
  pidlHistory:    PItemIDList;
  pidlToday:        PItemIDList;
  pidlItem:        PItemIDList;
  lpValue:        TStrRet;
  lpItem:        TStrRet;
  szValue:        String;
  cbCount:        Cardinal;

  function StrRetToStr(StrRet: TStrRet): String;
  begin
      case StrRet.uType of
      STRRET_CSTR    :  SetString(result, StrRet.cStr, lstrlen(StrRet.cStr));
      STRRET_OFFSET  :  SetLength(result, 0);
      STRRET_WSTR    :  result:=StrRet.pOleStr;
      else
      SetLength(result, 0);
      end;
  end;  
 
begin 
 
  // Check list
  if Assigned(List) then
  begin
    // Lock list  
    List.BeginUpdate;  
    // Resource protection  
    try
      // Clear the list
      List.Clear;
      // Get malloc
      if (SHGetMalloc(pvMalloc) = S_OK) then
      begin
        // Get desktop folder
        if (SHGetDesktopFolder(pvDesktop) = S_OK) then
        begin
          // Get history pidl
          if (SHGetSpecialFolderLocation(GetDesktopWindow, CSIDL_HISTORY, pidlHistory) = S_OK) then
          begin
            // Bind to folder interface
            if (pvDesktop.BindToObject(pidlHistory, nil, IID_IShellFolder, pvFolder) = S_OK) then
            begin
              // Locate the folder for "Today"
              if (pvFolder.EnumObjects(0, SHCONTF_FOLDERS or SHCONTF_INCLUDEHIDDEN, pvEnumHist) = S_OK) then
              begin
                // Enumerate items
                while (pvEnumHist.Next(1, pidlItem, cbCount) = S_OK) do
                begin
                  // Get display name of pidl
                  if (pvFolder.GetDisplayNameOf(pidlItem, SHGDN_NORMAL or SHGDN_INFOLDER, lpValue) = S_OK) then
                  begin
                    // Resource protection
                    try
                      // Check for "Today"
                      if (CompareText(StrRetToStr(lpValue), '今天') = 0) then
                      begin
                        // Switch pidls
                        pidlToday:=pidlItem;
                        // Bind to folder  interface
                        if (pvFolder.BindToObject(pidlToday, nil, IID_IShellFolder, pvToday) = S_OK) then
                        begin
                          // Get enumerator for "Today" folder
                          if (pvToday.EnumObjects(0, SHCONTF_FOLDERS or SHCONTF_NONFOLDERS or SHCONTF_INCLUDEHIDDEN, pvEnumToday) = S_OK) then
                          begin
                            // Enumerate items
                            while (pvEnumToday.Next(1, pidlItem, cbCount) = S_OK) do
                            begin
                              // Get the url
                              if (pvToday.GetDisplayNameOf(pidlItem, SHGDN_NORMAL or SHGDN_INFOLDER, lpItem) = S_OK) then
                              begin
                                // Resource protection
                                try
                                  // Get the string value
                                  szValue:=StrRetToStr(lpItem);
                                  // Check URL string
                                  if (Length(szValue) > 0) then List.Add(szValue);
                                finally
                                  // Free string memory
                                 if (lpItem.uType = STRRET_WSTR) then pvMalloc.Free(lpItem.pOleStr);
                                end;
                              end;
                              // Free memory
                              CoTaskMemFree(pidlItem);
                            end;
                            // Release interface
                            pvEnumToday:=nil;
                          end;
                          // Release interface
                          pvToday:=nil;
                        end;
                        // Free memory
                        CoTaskMemFree(pidlToday);
                        // Done processing
                        break;
                      end;
                    finally
                      // Free string memory
                      if (lpValue.uType = STRRET_WSTR) then pvMalloc.Free(lpValue.pOleStr);
                    end;
                  end;
                  // Free the pidl
                  CoTaskMemFree(pidlItem);
                end;
                // Release interface
                pvEnumHist:=nil;
              end;
              // Release interface
              pvFolder:=nil;
            end;
            // Free memory
            pvMalloc.Free(pidlHistory);
          end;
          // Release interface
          pvDesktop:=nil;
        end;
        // Release interface
        pvMalloc:=nil;
      end;
    finally
      // Unlock the list
      List.EndUpdate;
    end;
    // Return list count
    result:=List.Count;
  end
  else
    // No list
    result:=(-1);  
 
end; 

procedure TForm1.Button4Click(Sender: TObject);
var
  TemList:TStrings;
begin
  TemList:=TStringList.Create;
  if GetHistoryToday(TemList) > 0 then
    Memo1.Lines.CommaText:=TemList.CommaText;
  TemList.Free;
end;

第二种方法
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls,Activex,   Comobj;

const
//   GUID   定义：
  IID_IEnumStatUrl:     TGUID='{3C374A42-BAE4-11CF-BF7D-00AA006946EE}';
  IID_IUrlHistoryStg:   TGUID='{3C374A41-BAE4-11CF-BF7D-00AA006946EE}';
  IID_IUrlHistoryStg2:  TGUID='{AFA0DC11-C313-11d0-831A-00C04FD5AE38}';
  IID_IURLHistoryNotify:TGUID='{BC40BEC1-C493-11d0-831B-00C04FD5AE38}';
  CLSID_CUrlHistory:    TGUID='{3C374A40-BAE4-11CF-BF7D-00AA006946EE}';

type 
  //   TSTATURL   数据结构：
  PSTATURL=^TSTATURL;
  STATURL=record
    cbSize:DWORD;                           //   结构的大小
    pwcsUrl:Pointer;                     //   URL   是   PWideChar   ，原贴定义为   DWord
    pwcsTitle:Pointer;                 //   History   标题,原贴定义为   DWord
    ftLastVisited:FILETIME;
    ftLastUpdated:FILETIME;
    ftExpires:FILETIME;
    dwFlags:DWORD;
  end;
  TSTATURL=STATURL;

  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:STATURL):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;

 

type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    Button1: TButton;
    Button2: TButton;
    Edit1: TEdit;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var 
    UrlHistory:   IUrlHistoryStg2; 
    Enum:IEnumSTATURL; 
    urlSTATURL:TSTATURL; 
    fetched:Longint; 
    P:PWideChar; 
begin
//   初始化   STATURL   数据结构
  ZeroMemory(@urlSTATURL,SizeOf(TSTATURL));

  //   创建   IUrlHistoryStg2   实例
  if CoCreateInstance(CLSID_CUrlHistory,nil,CLSCTX_INPROC_SERVER,IID_IUrlHistoryStg2,UrlHistory)=1   then
  begin
    MessageBox(0,'IUrlHistoryStg2   没有创建','',MB_OK);
    exit;
  end;
  
//获得枚举接口   ->   IEnumSTATURL
  if UrlHistory.EnumUrls(Enum)=1  then
    MessageBox(0,'IEnumSTATURL   接口没有找到','',MB_OK);
  
//   找到一个，删除一个 
  while   Enum.Next(1,urlSTATURL,@fetched)<>1   do
  begin
    P:=urlSTATURL.pwcsUrl;
    if Pos('http://',p)>0 then
    listbox1.Items.Add(p);
    {
    if   UrlHistory.DeleteUrl(P,0)=1   then
        begin
          MessageBox(0,'删除出错','',MB_OK);
          Break;
        end;
        }
  end;   
end;