ADD: Feature [0000990] Creation of shortcuts *.lnk in addition to symbolic links

src/platform/uosforms.pas

@@ -130,7 +130,7 @@ uses
   , uTotalCommander, FileUtil, Windows, ShlObj, uShlObjAdditional
   , uWinNetFileSource, uVfsModule, uLng, uMyWindows, DCStrUtils
   , uListGetPreviewBitmap, uThumbnailProvider, uDCReadSVG, uFileSourceUtil
-  , Dialogs, Clipbrd
+  , Dialogs, Clipbrd, uShowMsg
   {$ENDIF}
   {$IFDEF UNIX}
   , BaseUnix, fFileProperties, uJpegThumb
@@ -448,6 +448,35 @@ begin
     FreeAndNil(SelectedFiles);
   end;
 end;
+
+procedure CreateShortcut(Self, Sender: TObject);
+var
+  ShortcutName: String;
+  SelectedFiles: TFiles;
+begin
+  SelectedFiles := frmMain.ActiveFrame.CloneSelectedOrActiveFiles;
+  try
+    if SelectedFiles.Count > 0 then
+    begin
+      ShortcutName:= frmMain.NotActiveFrame.CurrentPath + SelectedFiles[0].NameNoExt + '.lnk';
+      if ShowInputQuery(rsMnuCreateShortcut, EmptyStr, ShortcutName) then
+      begin
+        if mbFileExists(ShortcutName) then
+        begin
+          if not msgYesNo(Format(rsMsgFileExistsRwrt, [WrapTextSimple(ShortcutName, 100)])) then
+            Exit;
+        end;
+        try
+          uMyWindows.CreateShortcut(SelectedFiles[0].FullPath, ShortcutName);
+        except
+          on E: Exception do msgError(E.Message);
+        end;
+      end;
+    end;
+  finally
+    FreeAndNil(SelectedFiles);
+  end;
+end;
 {$ENDIF}
 
 {$IF DEFINED(LCLGTK2) or (DEFINED(LCLQT) and not DEFINED(DARWIN))}
@@ -536,6 +565,12 @@ begin
     Handler.Code:= @CopyNetNamesToClip;
     MenuItem.OnClick:= TNotifyEvent(Handler);
     mnuNetwork.Add(MenuItem);
+
+    MenuItem:= TMenuItem.Create(mnuMain);
+    MenuItem.Caption:= rsMnuCreateShortcut;
+    Handler.Code:= @CreateShortcut;
+    MenuItem.OnClick:= TNotifyEvent(Handler);
+    mnuFiles.Insert(mnuFiles.IndexOf(miMakeDir) + 1, MenuItem);
   end;
 end;
 {$ELSE}

src/platform/win/umywindows.pas

@@ -132,6 +132,10 @@ function IsUserAdmin: LongBool;
    This routine returns @true if the caller's process is running in the remote desktop session
 }
 function RemoteSession: Boolean;
+{en
+   Creates windows shortcut file (.lnk)
+}
+procedure CreateShortcut(const Target, Shortcut: String);
 {en
    Extract file attributes from find data record.
    Removes reparse point attribute if a reparse point tag is not a name surrogate.
@@ -147,7 +151,7 @@ implementation
 
 uses
   ShellAPI, MMSystem, JwaWinNetWk, JwaWinUser, JwaNative, JwaVista, LazUTF8,
-  ActiveX, DCWindows, uShlObjAdditional;
+  ActiveX, ShlObj, ComObj, DCWindows, uShlObjAdditional;
 
 var
   Wow64DisableWow64FsRedirection: function(OldValue: PPointer): BOOL; stdcall;
@@ -828,6 +832,34 @@ begin
   end;
 end;
 
+procedure CreateShortcut(const Target, Shortcut: String);
+var
+  IObject: IUnknown;
+  ISLink: IShellLinkW;
+  IPFile: IPersistFile;
+  LinkName: WideString;
+  TargetArguments: WideString;
+begin
+  TargetArguments:= EmptyWideStr;
+
+  { Creates an instance of IShellLink }
+  IObject := CreateComObject(CLSID_ShellLink);
+  IPFile := IObject as IPersistFile;
+  ISLink := IObject as IShellLinkW;
+
+  OleCheckUTF8(ISLink.SetPath(PWideChar(UTF8Decode(Target))));
+  OleCheckUTF8(ISLink.SetArguments(PWideChar(TargetArguments)));
+  OleCheckUTF8(ISLink.SetWorkingDirectory(PWideChar(UTF8Decode(ExtractFilePath(Target)))));
+
+  { Get the desktop location }
+  LinkName := UTF8Decode(Shortcut);
+  if LowerCase(ExtractFileExt(LinkName)) <> '.lnk' then
+    LinkName := LinkName + '.lnk';
+
+  { Create the link }
+  OleCheckUTF8(IPFile.Save(PWideChar(LinkName), False));
+end;
+
 function ExtractFileAttributes(const FindData: TWin32FindDataW): DWORD; inline;
 begin
   // If a reparse point tag is not a name surrogate then remove reparse point attribute

src/ulng.pas

@@ -348,6 +348,7 @@ resourcestring
   rsMnuPackHere = 'Pack here...';
   rsMnuExtractHere = 'Extract here...';
   // for main menu
+  rsMnuCreateShortcut = 'Create Shortcut...';
   rsMnuMapNetworkDrive = 'Map Network Drive...';
   rsMnuDisconnectNetworkDrive = 'Disconnect Network Drive...';
   rsMnuCopyNetNamesToClip = 'Copy names with UNC path';