一个IE工具单元

Tags: /超级猛料/OS.操作系统/IE.扩展/工具栏和工具单元/ Date Created:

(*******************************

* IEUTILS 1.00 (July 27, 2000)*

*******************************)

unit IEUtils;

interface

uses

IEConst, dialogs,Inifiles, Registry, Sysutils, ShellApi, Windows, Activex, Shlobj;

function IE5_Installed: Boolean;

function GetIEVersion: string;

function StringToVarArray(const S: string): Variant;

function VarArrayToString(const V: Variant): string;

function Encode(const S: string): string;

function IsFolder(ShellFolder: IShellFolder; ID: PItemIDList): Boolean;

function IsFolderEx(ChannelShortcut: String; ShellFolder: IShellFolder; ID: PItemIDList): Boolean;

function IsChannel(ChannelShortcut: String; ShellFolder: IShellFolder; ID: PItemIDList): Boolean;

function GetDisplayName(Folder: IShellFolder; pidl: PItemIDList): string;

function GetImageIndex(pidl: PItemIDList): integer;

function ExtractUrl(ShellFolder: IShellFolder; pidl: PItemIDList): string;

function ResolveChannel(pFolder: IShellFolder; pidl: PItemIDList; var lpszURL: string): HRESULT;

function ResolveLink(const path: string): string;

function GetFileName(Folder: IShellFolder; pidl: PItemIDList): string;

function ResolveUrlIni(Filename: string): string;

function ResolveUrlIntShCut(Filename: string): string;

procedure DisposePIDL(ID: PItemIDList);

function CopyITEMID(Malloc: IMalloc; ID: PItemIDList): PItemIDList;

function NextPIDL(IDList: PItemIDList): PItemIDList;

function GetPIDLSize(IDList: PItemIDList): Integer;

procedure StripLastID(IDList: PItemIDList);

function CreatePIDL(Size: Integer): PItemIDList;

function CopyPIDL(IDList: PItemIDList): PItemIDList;

function ConcatPIDLs(IDList1, IDList2: PItemIDList): PItemIDList;

implementation

uses comobj;

function StringToVarArray(const S: string): Variant;

begin

Result := Unassigned;

if S <> '' then

begin

Result := VarArrayCreate([0, Length(S) - 1], varByte);

Move(Pointer(S)^, VarArrayLock(Result)^, Length(S));

VarArrayUnlock(Result);

end;

function VarArrayToString(const V: Variant): string;

var

i, j: Integer;

begin

if VarIsArray(V) then

for I := 0 to VarArrayHighBound(V, 1) do

begin

j := V[i];

result := result + chr(j);

end;

function Encode(const S: string): string;

var

I: Integer;

Hex: string;

begin

for I := 1 to Length(S) do

case S[i] of

' ': result := Result + '+';

'A'..'Z', 'a'..'z', '*', '@', '.', '_', '-',

'0'..'9', '$', '!', '''', '(', ')':

result := Result + s[i];

else

begin

Hex := IntToHex(ord(S[i]), 2);

if Length(Hex) = 2 then Result := Result + '%' + Hex else

Result := Result + '%0' + hex;

end;

function IE5_Installed: Boolean;

var

Reg: TRegistry;

S: string;

begin

Reg := TRegistry.Create;

with Reg do begin

RootKey := HKEY_LOCAL_MACHINE;

OpenKey('Software\Microsoft\Internet Explorer', False);

if ValueExists('Version') then S := ReadString('Version')

else S := '0';

CloseKey;

Free;

end;

Result := (StrToInt(S[1]) > 4);

end;

function GetIEVersion: string;

var

SysDir: PChar;

Info: Pointer;

InfoData: Pointer;

InfoSize: LongInt;

Len: DWORD;

FName: Pchar;

SystemDir, Infotype: string;

LangPtr: Pointer;

begin

Len := MAX_PATH + 1;

GetMem(SysDir, Len);

try

if Windows.GetSystemDirectory(SysDir, Len) <> 0 then

SystemDir := SysDir;

finally

FreeMem(SysDir);

end;

result := '';

InfoType := 'FileVersion';

FName := Pchar(SystemDir + '\shdocvw.dll');

InfoSize := GetFileVersionInfoSize(Fname, Len);

if (InfoSize > 0) then

begin

GetMem(Info, InfoSize);

try

if GetFileVersionInfo(FName, Len, InfoSize, Info) then

begin

Len := 255;

if VerQueryValue(Info, '\VarFileInfo\Translation', LangPtr, Len) then

InfoType := Format('\StringFileInfo\%0.4x%0.4x\%s'#0, [LoWord(LongInt(LangPtr^)),

HiWord(LongInt(LangPtr^)), InfoType]);

if VerQueryValue(Info, Pchar(InfoType), InfoData, len) then

Result := strPas(InfoData);

end;

finally

FreeMem(Info, InfoSize);

end;

function ResolveUrlIni(Filename: string): string;

var

ini: TiniFile;

begin

result := '';

ini := TIniFile.create(fileName);

try

result := ini.ReadString('InternetShortcut', 'URL', '');

finally

ini.free;

end;

function ResolveUrlIntShCut(Filename: string): string;

var

IURL: IUniformResourceLocator;

PersistFile: IPersistfile;

FName: array[0..MAX_PATH] of WideChar;

p: Pchar;

begin

if Succeeded(CoCreateInstance(CLSID_InternetShortcut, nil, CLSCTX_INPROC_SERVER,

IID_IUniformResourceLocator, IURL))

then begin

Persistfile := IUrl as IPersistFile;

StringToWideChar(FileName, FName, MAX_PATH);

PersistFile.Load(Fname, STGM_READ);

IUrl.geturl(@P);

Result := P;

end;

function ResolveChannel(pFolder: IShellFolder; pidl: PItemIDList; var lpszURL: string): HRESULT;

var

pidlChannel: PItemIDList;

psfDesktop: IShellFolder;

pShellLink: IShellLink;

begin

Result := S_FALSE;

if Succeeded(pFolder.GetUIObjectOf(0, 1, pidl, IShellLink, nil, Pointer(pShellLink)))

then

if Succeeded(pShellLink.GetIDList(pidlChannel)) then

if Succeeded(SHGetDesktopFolder(psfDesktop))

then

begin

lpszURL := getDisplayName(psfDesktop, PidlChannel);

Result := S_OK;

end;

DisposePidl(PidlChannel);

end;

function ResolveLink(const path: string): string;

var

link: IShellLink;

storage: IPersistFile;

filedata: TWin32FindData;

buf: array[0..MAX_PATH] of Char;

widepath: WideString;

begin

OleCheck(CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER, IShellLink, link));

OleCheck(link.QueryInterface(IPersistFile, storage));

widepath := path;

Result := '';

if Succeeded(storage.Load(@widepath[1], STGM_READ)) then

if Succeeded(link.Resolve(GetActiveWindow, SLR_NOUPDATE)) then

if Succeeded(link.GetPath(buf, sizeof(buf), filedata, SLGP_UNCPRIORITY)) then

Result := buf;

storage := nil;

link := nil;

end;

function ExtractUrl(ShellFolder: IShellFolder; pidl: PItemIDList): string;

var

Handle: THandle;

Info: IQueryInfo;

W: PWideChar;

begin

Handle := 0;

Info := nil;

ShellFolder.GetUIObjectOf(Handle, 1, pidl, IID_IQUERYINFO, nil, Pointer(Info));

if assigned(Info) then

begin

Info.GetInfoTip(0, w);

Result := W;

end else result := '';

Result := Trim(Copy(Result, Pos(#10, Result) + 1, length(Result)));

end;

function IsFolder(ShellFolder: IShellFolder; ID: PItemIDList): Boolean;

var

Flags: UINT;

begin

Flags := SFGAO_FOLDER;

ShellFolder.GetAttributesOf(1, ID, Flags);

Result := SFGAO_FOLDER and Flags <> 0;

end;

function IsChannel(ChannelShortcut: String; ShellFolder: IShellFolder; ID: PItemIDList): Boolean;

var

FileInfo: TShFileInfo;

begin

SHGetFileInfo(Pchar(ID), 0, FileInfo, SizeOf(TSHFileInfo), SHGFI_PIDL or SHGFI_TYPENAME);

Result:=BOOL(fileinfo.szTypeName = ChannelShortcut);

end;

function IsFolderEx(ChannelShortcut: String; ShellFolder: IShellFolder; ID: PItemIDList): Boolean;

var

Flags: UINT;

begin

Flags := SFGAO_FOLDER;

ShellFolder.GetAttributesOf(1, ID, Flags);

If SFGAO_FOLDER and Flags <> 0 then

result:=not isChannel(ChannelShortcut, Shellfolder, id)

else Result:=False;

end;

function GetImageIndex(pidl: PItemIDList): integer;

var

Flags: UINT;

FileInfo: TSHFileInfo;

begin

Flags := SHGFI_PIDL or SHGFI_SYSICONINDEX or SHGFI_ICON or SHGFI_SMALLICON;

if SHGetFileInfo(PChar(pidl), 0, FileInfo, SizeOf(TSHFileInfo), Flags) = 0 then

Result := -1

else

Result := FileInfo.iIcon;

end;

function GetDisplayName(Folder: IShellFolder; pidl: PItemIDList): string;

var

StrRet: TStrRet;

begin

Folder.GetDisplayNameOf(pidl, SHGDN_NORMAL, StrRet);

case StrRet.uType of

STRRET_CSTR:

SetString(Result, StrRet.cStr, lStrLen(StrRet.cStr));

STRRET_OFFSET:

Result := Pchar(@pidl.mkid.abID[StrRet.uOffset - SizeOf(pidl.mkid.cb)]);

STRRET_WSTR:

Result := StrRet.pOleStr;

end;

function GetFileName(Folder: IShellFolder; pidl: PItemIDList): string;

var

StrRet: TStrRet;

begin

Folder.GetDisplayNameOf(pidl, SHGDN_FORPARSING, StrRet);

case StrRet.uType of

STRRET_CSTR:

SetString(Result, StrRet.cStr, lStrLen(StrRet.cStr));

STRRET_OFFSET:

Result:= Pchar(@pidl.mkid.abID[StrRet.uOffset - SizeOf(pidl.mkid.cb)]);

STRRET_WSTR:

Result := StrRet.pOleStr;

end;

procedure DisposePIDL(ID: PItemIDList);

var

Malloc: IMalloc;

begin

if ID = nil then Exit;

OLECheck(SHGetMalloc(Malloc));

Malloc.Free(ID);

end;

function CopyITEMID(Malloc: IMalloc; ID: PItemIDList): PItemIDList;

begin

Result := Malloc.Alloc(ID^.mkid.cb + SizeOf(ID^.mkid.cb));

CopyMemory(Result, ID, ID^.mkid.cb + SizeOf(ID^.mkid.cb));

end;

function NextPIDL(IDList: PItemIDList): PItemIDList;

begin

Result := IDList;

Inc(PChar(Result), IDList^.mkid.cb);

end;

function GetPIDLSize(IDList: PItemIDList): Integer;

begin

Result := 0;

if Assigned(IDList) then

begin

Result := SizeOf(IDList^.mkid.cb);

while IDList^.mkid.cb <> 0 do

begin

Result := Result + IDList^.mkid.cb;

IDList := NextPIDL(IDList);

end;

procedure StripLastID(IDList: PItemIDList);

var

MarkerID: PItemIDList;

begin

MarkerID := IDList;

if Assigned(IDList) then

begin

while IDList.mkid.cb <> 0 do

begin

MarkerID := IDList;

IDList := NextPIDL(IDList);

end;

MarkerID.mkid.cb := 0;

end;

function CreatePIDL(Size: Integer): PItemIDList;

var

Malloc: IMalloc;

HR: HResult;

begin

Result := nil;

HR := SHGetMalloc(Malloc);

if Failed(HR) then

Exit;

try

Result := Malloc.Alloc(Size);

if Assigned(Result) then

FillChar(Result^, Size, 0);

finally

end;

function CopyPIDL(IDList: PItemIDList): PItemIDList;

var

Size: Integer;

begin

Size := GetPIDLSize(IDList);

Result := CreatePIDL(Size);

if Assigned(Result) then

CopyMemory(Result, IDList, Size);

end;

function ConcatPIDLs(IDList1, IDList2: PItemIDList): PItemIDList;

var

cb1, cb2: Integer;

begin

if Assigned(IDList1) then

cb1 := GetPIDLSize(IDList1) - SizeOf(IDList1^.mkid.cb)

else

cb1 := 0;

cb2 := GetPIDLSize(IDList2);

Result := CreatePIDL(cb1 + cb2);

if Assigned(Result) then

begin

if Assigned(IDList1) then

CopyMemory(Result, IDList1, cb1);

CopyMemory(PChar(Result) + cb1, IDList2, cb2);

end;

end.