LazFileUtils: implement GetShellLinkTarget function.

git-svn-id: trunk@46434 -

components/lazutils/lazfileutils.pas

@@ -107,6 +107,9 @@ function GetFileDescription(const AFilename: string): string;
 function ReadAllLinks(const Filename: string;
                       ExceptionOnError: boolean): string; // if a link is broken returns ''
 function TryReadAllLinks(const Filename: string): string; // if a link is broken returns Filename
+function GetShellLinkTarget(const FileName: string): string;
+
+
 type
   TPhysicalFilenameOnError = (pfeException,pfeEmpty,pfeOriginal);
 function GetPhysicalFilename(const Filename: string;
@@ -147,7 +150,7 @@ implementation
 // to get more detailed error messages consider the os
 uses
 {$IFDEF Windows}
-  Windows {$IFnDEF WinCE}, WinDirs{$ENDIF};
+  Windows {$IFnDEF WinCE}, ShlObj, ActiveX, WinDirs{$ENDIF};
 {$ELSE}
   {$IFDEF darwin}
   MacOSAll,

components/lazutils/unixlazfileutils.inc

@@ -473,6 +473,10 @@ begin
     raise EInOutError.Create(Format(lrsUnableToCreateConfigDirectoryS,[Dir]));
 end;
 
+function GetShellLinkTarget(const FileName: string): string;
+begin
+  Result := Filename;
+end;
 
 procedure InitLazFileUtils;
 begin

components/lazutils/winlazfileutils.inc

@@ -23,6 +23,8 @@ var
   _RemoveDirUtf8       : function(const Dir: String): Boolean ;
   _GetAppConfigDirUTF8 : function(Global: Boolean; Create: boolean = false): string;
   _GetAppConfigFileUTF8: function(Global: Boolean; SubDir: boolean = false;CreateDir: boolean = false): string;
+  _GetShellLinkTarget  : function(const FileName: string): string;
+
 
 
 
@@ -153,6 +155,11 @@ begin
   Result:=Filename;
 end;
 
+function GetShellLinkTarget(const FileName: string): string;
+begin
+  Result := _GetShellLinkTarget(FileName);
+end;
+
 // ******** Start of AnsiString specific implementations ************
 
 {$ifndef WinCE}
@@ -278,6 +285,35 @@ begin
     raise EInOutError.Create(Format(lrsUnableToCreateConfigDirectoryS,[Dir]));
 end;
 
+function GetShellLinkTargetAnsi(const FileName: string): string;
+var
+  ShellLinkA: IShellLinkA;
+  PersistFile: IPersistFile;
+  WideFileName: WideString;
+  AnsiPath: array [0 .. MAX_PATH] of Char;
+  WinFindData: WIN32_FIND_DATAA;
+begin
+  Result := FileName;
+  if (LowerCase(ExtractFileExt(FileName)) = '.lnk') then
+  begin
+    if (CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER,
+                         IShellLinkA, ShellLinkA) = S_OK) then
+    if (ShellLinkA.QueryInterface(IPersistFile, PersistFile) = S_OK) then
+    begin
+      WideFileName := Utf8ToUtf16(FileName);
+      FillChar(WinFindData{%H-}, SizeOf(WinFindData), 0);
+      if (PersistFile.Load(POleStr(WideFileName), STGM_READ) = S_OK) then
+      begin
+        if (ShellLinkA.GetPath(AnsiPath, Length(AnsiPath),
+                               WinFindData, SLGP_UNCPRIORITY) = S_OK) then
+        begin
+          Result := SysToUtf8(AnsiPath); // implicit conversion
+        end;
+      end;
+    end;
+  end;
+end;
+
 
 {$endif WinCE}
 
@@ -745,6 +781,40 @@ begin
     raise EInOutError.Create(Format(lrsUnableToCreateConfigDirectoryS,[Dir]));
 end;
 
+
+function GetShellLinkTargetWide(const FileName: string): string;
+{$IFnDEF WINCE}
+var
+  ShellLinkW: IShellLinkW;
+  PersistFile: IPersistFile;
+  WideFileName: WideString;
+  WidePath: array [0 .. MAX_PATH] of WideChar;
+  WinFindData: WIN32_FIND_DATAW;
+  {$ENDIF WINCE}
+begin
+  Result := FileName;
+  {$IFnDEF WINCE}
+  if (LowerCase(ExtractFileExt(FileName)) = '.lnk') then
+  begin
+    if (CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER,
+                         IShellLinkW, ShellLinkW) = S_OK) then
+    if (ShellLinkW.QueryInterface(IPersistFile, PersistFile) = S_OK) then
+    begin
+      WideFileName := Utf8ToUtf16(FileName);
+      FillChar(WinFindData{%H-}, SizeOf(WinFindData), 0);
+      if (PersistFile.Load(POleStr(WideFileName), STGM_READ) = S_OK) then
+      begin
+        if (ShellLinkW.GetPath(WidePath, Length(WidePath),
+                               @WinFindData, SLGP_UNCPRIORITY) = S_OK) then
+        begin
+          Result := Utf16toUtf8(WidePath); // implicit conversion
+        end;
+      end;
+    end;
+  end;
+  {$ENDIF WINCE}
+end;
+
 // ******** End of WideString specific implementations ************
 
 
@@ -1064,6 +1134,7 @@ begin
     _FindNextUtf8 := @FindNextAnsi;
     _GetAppConfigDirUtf8 := @GetAppConfigDirAnsi;
     _GetAppConfigFileUtf8 := @GetAppConfigFileAnsi;
+    _GetShellLinkTarget := @GetShellLinkTargetAnsi;
   end
   else
   {$endif}
@@ -1086,6 +1157,7 @@ begin
     _FindNextUtf8 := @FindNextWide;
     _GetAppConfigDirUtf8 := @GetAppConfigDirWide;
     _GetAppConfigFileUtf8 := @GetAppConfigFileWide;
+    _GetShellLinkTarget := @GetShellLinkTargetWide;
   end;
 end;