一个IE工具单元

(*******************************
* 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;
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;
result := result + chr(j);
end;
end;
function Encode(const S: string): string;
var
I: Integer;
Hex: string;
begin
for I := 1 to Length(S) do
case S of
' ': result := Result + '+';
'A'..'Z', 'a'..'z', '*', '@', '.', '_', '-',
'0'..'9', '$', '!', '''', '(', ')':
result := Result + s;
else
begin
Hex := IntToHex(ord(S), 2);
if Length(Hex) = 2 then Result := Result + '%' + Hex else
Result := Result + '%0' + hex;
end;
end;
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;
end;
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;
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;
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;
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;
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;
end;
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;
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;
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;
end.