uses ComObj,
ActiveX, ShlObj;
const
IID_IShellItem: TGUID = '
{43826d1e-e718-42ee-bc55-a1e261c37bfe}';
type
{$EXTERNALSYM IShellItem}
IShellItem =
interface(IUnknown)
['
{43826d1e-e718-42ee-bc55-a1e261c37bfe}']
function BindToHandler(pbc: IBindCtx;
const rbhid: TGUID;
const riid: TIID;
out ppvOut): HResult;
stdcall;
function GetParent(
out ppsi: IShellItem): HResult;
stdcall;
function GetDisplayName(sigdnName: DWord;
out ppszName: POleStr): HResult;
stdcall;
function GetAttributes(sfgaoMask: ULong;
out psfgaoAttribs: ULong): HResult;
stdcall;
function Compare(psi: IShellItem; hint: DWord;
out piOrder: Integer): HResult;
stdcall;
end;
function SHBindToParent(pidl : PItemIdList;
const riid : TIID;
out ppv;
var ppidlLast : PItemIdList) : Hresult;
stdcall;
external '
shell32.dll';
function SHCreateShellItem(pidlParent: PItemIDList; psfParent: IShellFolder; pidl: PItemIDList;
out ppsi: IShellItem): HResult
stdcall;
external '
shell32.dll';
type
TFolderNameType = (fnNormal, fnInFolder, fnForEditing, fnForAddressBar, fnForParsing);
function GetFolderName (folder : IShellFolder; pidl : PItemIDList;
tp : TFolderNameType) : WideString;
overload;
var
t : DWORD;
str : TStrRet;
begin
case tp of
fnInfolder : t := SHGDN_INFOLDER;
fnForEditing : t := SHGDN_FOREDITING;
fnForAddressBar : t := SHGDN_FORADDRESSBAR;
fnForPARSING : t := SHGDN_FORPARSING;
else
t := SHGDN_NORMAL;
end;
if Succeeded (folder.GetDisplayNameOf(pidl, t, str))
then
case str.uType
of
STRRET_CSTR : result := str.cStr;
STRRET_WSTR :
begin
result := str.pOleStr;
CoTaskMemFree (str.pOleStr)
end;
STRRET_OFFSET : result := PChar (pidl) + str.uOffset;
else result := '
'
end
else
result := '
'
end;
function ReadLnkFile(
const LnkFileName:
String;
out Path, Arguments, WorkingDirectory, Description:
String;
out HotKey: Word;
out ShowCmd: Integer;
out IconPath:
String;
out IconIndex: Integer;
out ItemIDList: PItemIDList): Boolean;
var
ShellLink: IShellLink;
PersistFile: IPersistFile;
FileInfo: TWin32FindData;
begin
Result:=False;
if SUCCEEDED(CoCreateInstance(CLSID_ShellLink,
nil, CLSCTX_INPROC_SERVER, IShellLink, ShellLink))
then
begin
PersistFile := ShellLink
as IPersistFile;
if SUCCEEDED(PersistFile.Load(StringToOleStr(LnkFileName), STGM_READ))
then
with ShellLink
do
begin
SetLength(Path, MAX_PATH + 1);
if SUCCEEDED(GetPath(PChar(Path), MAX_PATH, FileInfo, SLR_ANY_MATCH))
then
begin
Path := PChar(Path);
Result := True;
SetLength(Arguments, MAX_PATH + 1);
GetArguments(PChar(Arguments), MAX_PATH);
Arguments := PChar(Arguments);
SetLength(WorkingDirectory, MAX_PATH + 1);
GetWorkingDirectory(PChar(WorkingDirectory), MAX_PATH);
WorkingDirectory := PChar(WorkingDirectory);
SetLength(Description, MAX_PATH + 1);
GetDescription(PChar(Description), MAX_PATH);
Description := PChar(Description);
GetHotkey(HotKey);
GetShowCmd(ShowCmd);
SetLength(IconPath, MAX_PATH + 1);
GetIconLocation(PChar(IconPath), MAX_PATH, IconIndex);
IconPath := PChar(IconPath);
if IconPath = '
'
then
IconPath := Path;
if not Succeeded(GetIDList(ItemIDList))
then
ItemIDList:=nil;
end
else
Path := '
';
end;
end;
end;
function GetPathFromLnkFileEx(
const ALnkFileName:
string;
out APathEx, AParsingPath :
String ): Boolean;
var
Path, Arguments, WorkingDirectory, Description:
String;
HotKey: Word;
ShowCmd: Integer;
IconPath:
String;
IconIndex: Integer;
ItemIDList: PItemIDList;
ItemIDListLast : PItemIDList;
ShellFolder: IShellFolder;
ShellItem,
ShellItem2: IShellItem;
PName : PWideChar;
begin
Result:=False;
ReadLnkFile(ALnkFileName, Path, Arguments, WorkingDirectory, Description, HotKey, ShowCmd, IconPath, IconIndex, ItemIDList);
if assigned(ItemIDList)
then
if Succeeded(SHBindToParent(ItemIDList, IID_IShellFolder, ShellFolder, ItemIDListLast))
then
begin
Result:=True;
AParsingPath:=GetFolderName(ShellFolder, ItemIDListLast, fnForParsing);
if Succeeded(SHCreateShellItem(ItemIDList, ShellFolder, ItemIDListLast, ShellItem))
then
begin
APathEx:='
';
while Succeeded(ShellItem.GetParent(ShellItem2))
do
begin
if Assigned(ShellItem2)
then
begin
ShellItem2.GetDisplayName(0, PName);
APathEx:='
\'+WideString(PName)+APathEx;
CoTaskMemFree(PName);
ShellItem:=ShellItem2;
end
else
Break;
end;
end;
end;
end;