Imports System.Runtime.InteropServices
Imports System.Text

Module m_IShellLink

#Region "Constants"

  'IShellLink::GetPath method
  <Flags()>
  Private Enum SLGP_FLAGS
    ''' <summary>Retrieves the standard short (8.3 format) file name</summary>
    SLGP_SHORTPATH = &H1
    ''' <summary>Retrieves the Universal Naming Convention (UNC) path name of the file</summary>
    SLGP_UNCPRIORITY = &H2
    ''' <summary>Retrieves the raw path name. A raw path is something that might not exist and may include environment variables that need to be expanded</summary>
    SLGP_RAWPATH = &H4
    ''' <summary>Windows Vista and later. Retrieves the path, if possible, of the shortcut's target relative to the path set by a previous call to IShellLink::SetRelativePath</summary>
    SLGP_RELATIVEPRIORITY = &H8
  End Enum

  'Time Structures
  <StructLayout(LayoutKind.Sequential)>
  Private Structure FILETIME
    Dim dwLowDateTime As Integer
    Dim dwHighDateTime As Integer
  End Structure

  'File Management Structures
  <StructLayout(LayoutKind.Sequential, CharSet:=CharSet.Unicode)>
  Private Structure WIN32_FIND_DATA
    Dim dwFileAttributes As Integer
    Dim ftCreationTime As FILETIME
    Dim ftLastAccessTime As FILETIME
    Dim ftLastWriteTime As FILETIME
    Dim nFileSizeHigh As Integer
    Dim nFileSizeLow As Integer
    Dim dwReserved0 As Integer
    Dim dwReserved1 As Integer
    <MarshalAs(UnmanagedType.ByValTStr, SizeConst:=MAX_PATH)> Dim cFileName As String
    <MarshalAs(UnmanagedType.ByValTStr, SizeConst:=14)> Dim cAlternateFileName As String
  End Structure

  'IShellLink::Resolve method
  <Flags()>
  Private Enum SLR_FLAGS
    ''' <summary>
    ''' Do not display a dialog box if the link cannot be resolved. When SLR_NO_UI is set,
    ''' the high-order word of fFlags can be set to a time-out value that specifies the
    ''' maximum amount of time to be spent resolving the link. The function returns if the
    ''' link cannot be resolved within the time-out duration. If the high-order word is set
    ''' to zero, the time-out duration will be set to the default value of 3,000 milliseconds
    ''' (3 seconds). To specify a value, set the high word of fFlags to the desired time-out
    ''' duration, in milliseconds.
    ''' </summary>
    SLR_NO_UI = &H1
    ''' <summary>Obsolete and no longer used</summary>
    SLR_ANY_MATCH = &H2
    ''' <summary>If the link object has changed, update its path and list of identifiers.
    ''' If SLR_UPDATE is set, you do not need to call IPersistFile::IsDirty to determine
    ''' whether or not the link object has changed.</summary>
    SLR_UPDATE = &H4
    ''' <summary>Do not update the link information</summary>
    SLR_NOUPDATE = &H8
    ''' <summary>Do not execute the search heuristics</summary>
    SLR_NOSEARCH = &H10
    ''' <summary>Do not use distributed link tracking</summary>
    SLR_NOTRACK = &H20
    ''' <summary>Disable distributed link tracking. By default, distributed link tracking tracks
    ''' removable media across multiple devices based on the volume name. It also uses the
    ''' Universal Naming Convention (UNC) path to track remote file systems whose drive letter
    ''' has changed. Setting SLR_NOLINKINFO disables both types of tracking.</summary>
    SLR_NOLINKINFO = &H40
    ''' <summary>Call the Microsoft Windows Installer</summary>
    SLR_INVOKE_MSI = &H80
  End Enum

  'IPersistFile::Load method
  Private Const STGM_READ As UInteger = 0

  Private Const MAX_PATH = 260

#End Region


#Region "COM"

  'Shell Interfaces -> IShellLink
  ''' <summary>The IShellLink interface allows Shell links to be created, modified, and resolved</summary>
  <ComImport(), InterfaceType(ComInterfaceType.InterfaceIsIUnknown), Guid("000214F9-0000-0000-C000-000000000046")>
  Private Interface IShellLinkW
    ''' <summary>Retrieves the path and file name of a Shell link object</summary>
    Sub GetPath(<Out(), MarshalAs(UnmanagedType.LPWStr)> pszFile As StringBuilder, cchMaxPath As Integer, ByRef pfd As WIN32_FIND_DATA, fFlags As SLGP_FLAGS)
    ''' <summary>Retrieves the list of item identifiers for a Shell link object</summary>
    Sub GetIDList(ByRef ppidl As IntPtr)
    ''' <summary>Sets the pointer to an item identifier list (PIDL) for a Shell link object.</summary>
    Sub SetIDList(pidl As IntPtr)
    ''' <summary>Retrieves the description string for a Shell link object</summary>
    Sub GetDescription(<Out(), MarshalAs(UnmanagedType.LPWStr)> pszName As StringBuilder, cchMaxName As Integer)
    ''' <summary>Sets the description for a Shell link object. The description can be any application-defined string</summary>
    Sub SetDescription(<MarshalAs(UnmanagedType.LPWStr)> pszName As String)
    ''' <summary>Retrieves the name of the working directory for a Shell link object</summary>
    Sub GetWorkingDirectory(<Out(), MarshalAs(UnmanagedType.LPWStr)> pszDir As StringBuilder, cchMaxPath As Integer)
    ''' <summary>Sets the name of the working directory for a Shell link object</summary>
    Sub SetWorkingDirectory(<MarshalAs(UnmanagedType.LPWStr)> pszDir As String)
    ''' <summary>Retrieves the command-line arguments associated with a Shell link object</summary>
    Sub GetArguments(<Out(), MarshalAs(UnmanagedType.LPWStr)> pszArgs As StringBuilder, cchMaxPath As Integer)
    ''' <summary>Sets the command-line arguments for a Shell link object</summary>
    Sub SetArguments(<MarshalAs(UnmanagedType.LPWStr)> pszArgs As String)
    ''' <summary>Retrieves the hot key for a Shell link object</summary>
    Sub GetHotkey(ByRef pwHotkey As Short)
    ''' <summary>Sets a hot key for a Shell link object</summary>
    Sub SetHotkey(wHotkey As Short)
    ''' <summary>Retrieves the show command for a Shell link object</summary>
    Sub GetShowCmd(ByRef piShowCmd As Integer)
    ''' <summary>Sets the show command for a Shell link object. The show command sets the initial show state of the window.</summary>
    Sub SetShowCmd(iShowCmd As Integer)
    ''' <summary>Retrieves the location (path and index) of the icon for a Shell link object</summary>
    Sub GetIconLocation(<Out(), MarshalAs(UnmanagedType.LPWStr)> pszIconPath As StringBuilder, cchIconPath As Integer, ByRef piIcon As Integer)
    ''' <summary>Sets the location (path and index) of the icon for a Shell link object</summary>
    Sub SetIconLocation(<MarshalAs(UnmanagedType.LPWStr)> pszIconPath As String, iIcon As Integer)
    ''' <summary>Sets the relative path to the Shell link object</summary>
    Sub SetRelativePath(<MarshalAs(UnmanagedType.LPWStr)> pszPathRel As String, dwReserved As Integer)
    ''' <summary>Attempts to find the target of a Shell link, even if it has been moved or renamed</summary>
    Sub Resolve(hwnd As IntPtr, fFlags As SLR_FLAGS)
    ''' <summary>Sets the path and file name of a Shell link object</summary>
    Sub SetPath(<MarshalAs(UnmanagedType.LPWStr)> pszFile As String)

  End Interface

  'COM Fundamentals -> Reference -> Interfaces -> IPersist
  <ComImport(), Guid("0000010c-0000-0000-c000-000000000046"), InterfaceType(ComInterfaceType.InterfaceIsIUnknown)>
  Private Interface IPersist
    <PreserveSig()>
    Sub GetClassID(ByRef pClassID As Guid)
  End Interface

  'COM Fundamentals -> Reference -> Interfaces -> IPersistFile
  <ComImport(), Guid("0000010b-0000-0000-C000-000000000046"), InterfaceType(ComInterfaceType.InterfaceIsIUnknown)>
  Private Interface IPersistFile
    Inherits IPersist
    Shadows Sub GetClassID(ByRef pClassID As Guid)
    <PreserveSig()>
    Function IsDirty() As Integer

    ''' <summary>Opens the specified file and initializes an object from the file contents</summary>
    <PreserveSig()>
    Sub Load(<[In](), MarshalAs(UnmanagedType.LPWStr)> pszFileName As String, dwMode As UInteger)

    ''' <summary>Saves a copy of the object to the specified file</summary>
    <PreserveSig()>
    Sub Save(<[In](), MarshalAs(UnmanagedType.LPWStr)> pszFileName As String, <[In](), MarshalAs(UnmanagedType.Bool)> fRemember As Boolean)

    <PreserveSig()>
    Sub SaveCompleted(<[In](), MarshalAs(UnmanagedType.LPWStr)> pszFileName As String)

    <PreserveSig()>
    Sub GetCurFile(<[In](), MarshalAs(UnmanagedType.LPWStr)> ppszFileName As String)
  End Interface

  ' CLSID_ShellLink from ShlGuid.h 
  <ComImport(), Guid("00021401-0000-0000-C000-000000000046")> Private Class ShellLink
  End Class

#End Region


  Public Function CreateShortcut(ByVal pszShortcutPath As String, ByVal pszFileName As String, _
   Optional ByVal pszArguments As String = vbNullString, _
   Optional ByVal pszWorkingDirectory As String = vbNullString, _
   Optional ByVal pszDescription As String = vbNullString, _
   Optional ByVal pszIconPath As String = vbNullString, _
   Optional ByVal iIcon As Integer = 0) As Boolean
    'pszShortcutPath - string that specifies a path and file name of a shortcut
    'pszFileName - the path and file name for the target of a Shell link object
    'pszArguments - the command-line arguments for a Shell link object
    'pszWorkingDirectory - the name of the working directory for a Shell link object
    'pszDescription - the description string for a Shell link object
    'pszIconPath - the path of the file containing the icon
    'iIcon - the index of the icon

    Try
      If (Strings.Len(pszShortcutPath) = 0) Or _
       IO.Directory.Exists(IO.Path.GetDirectoryName(pszShortcutPath)) = False Then
        Return False
      End If

      Dim link As New ShellLink()
      'FileName
      DirectCast(link, IShellLinkW).SetPath(pszFileName)
      'Arguments
      If Strings.Len(pszArguments) > 0 Then DirectCast(link, IShellLinkW).SetArguments(pszArguments)
      'WorkingDirectory
      If Strings.Len(pszWorkingDirectory) = 0 Then
        'пытаемся взять WorkingDirectory из пути к pszFileName
        Try
          If (Strings.Len(pszFileName) > 0) Then pszWorkingDirectory = IO.Path.GetDirectoryName(pszFileName)
        Catch
        End Try
      End If
      If Strings.Len(pszWorkingDirectory) > 0 Then
        pszWorkingDirectory = GoodPath(pszWorkingDirectory) 'Add a trailing slash if none (поведение виндов)
        DirectCast(link, IShellLinkW).SetWorkingDirectory(pszWorkingDirectory)
      End If
      'Description
      If Strings.Len(pszDescription) > 0 Then DirectCast(link, IShellLinkW).SetDescription(pszDescription)
      'Icon (при отсутствии pszIconPath присваивается нулевая иконка из pszFileName)
      If Strings.Len(pszIconPath) > 0 Then DirectCast(link, IShellLinkW).SetIconLocation(pszIconPath, iIcon)
      'сохранение
      DirectCast(link, IPersistFile).Save(pszShortcutPath, True)
      Return True
    Catch
      Return False 'вряд ли оно споткнется...или об этом скажет
    End Try
  End Function

  Public Function GetShortcutTarget(ByVal pszShortcutPath As String) As String
    'путь к файлу, на кот. указывает ярлык
    Try
      Dim link As New ShellLink()
      DirectCast(link, IPersistFile).Load(pszShortcutPath, STGM_READ)
      Dim sb As New StringBuilder(MAX_PATH)
      Dim data As New WIN32_FIND_DATA
      DirectCast(link, IShellLinkW).GetPath(sb, sb.Capacity, data, 0)
      Return sb.ToString()
    Catch
      Return ""
    End Try
  End Function

  Public Sub RemoveShortcutsByTagretName(ByVal pszFolder As String, ByVal pszTargetName As String)
    'удаляет все ярлыки указывающие на имя pszTargetName по заданному пути pszFolder
    Dim ff As String() = IO.Directory.GetFiles(pszFolder, "*.lnk", IO.SearchOption.TopDirectoryOnly)
    For Each f As String In ff
      Dim sTarget As String = GetShortcutTarget(f)
      If Strings.Len(sTarget) > 0 Then
        If UCase(IO.Path.GetFileName(sTarget)) = UCase(pszTargetName) Then
          Try : IO.File.Delete(f) : Catch : End Try
        End If
      End If
    Next
  End Sub

  Private Function GoodPath(ByVal NewPath) As String
    Dim sPath As String
    'Add a trailing slash if none
    sPath = NewPath & IIf(Strings.Right(NewPath, 1) = "\", "", "\")
    GoodPath = sPath
  End Function


End Module