VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "CShellLink"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' *************************************************************************
'  Copyright ©2004-07 Karl E. Peterson
'  All Rights Reserved, http://vb.mvps.org/
' *************************************************************************
'  You are free to use this code within your own applications, but you
'  are expressly forbidden from selling or otherwise distributing this
'  source code, non-compiled, without prior written consent.
' -------------------------------------------------------------------------
'  This wrapper class is considered UNSUPPORTED by its author.  If you
'  find it useful, that's great!  Enjoy...
' *************************************************************************
'  This class requires a reference to the ShellLnk.tlb file that ships on
'  the VB5 CD (in the \Tools\Unsupprt\Shelllnk folder), or may be obtained
'  here: http://vb.mvps.org/tools/files/ShellLnk.zip
' *************************************************************************
Option Explicit

' Win32 API declarations
Private Declare Function ExpandEnvironmentStrings Lib "kernel32" Alias "ExpandEnvironmentStringsA" (ByVal lpSrc As String, ByVal lpDst As String, ByVal nSize As Long) As Long

' API Constants
Private Const MAX_PATH As Long = 260

Private Const SW_SHOWNORMAL = 1
Private Const SW_SHOWMAXIMIZED = 3
Private Const SW_SHOWMINNOACTIVE = 7

' Public enumerations
Public Enum lnkWindowStates
  lnkNormal = SW_SHOWNORMAL
  lnkMaximized = SW_SHOWMAXIMIZED
  lnkMinimized = SW_SHOWMINNOACTIVE
End Enum

' Member variables
Private m_ShellLink As ShellLinkA       ' An explorer IShellLinkA(Win 95/Win NT) instance
Private m_PersistFile As IPersistFile   ' An explorer IPersistFile instance
Private m_FileName As String            ' Filename
Private m_AutoQuote As Boolean          ' Automatically add quotes around targets that contain spaces?
Private m_Overwrite As Boolean          ' Determines whether create overwrites existing files
Private m_Dirty As Boolean              ' Flag indicating object needs to be saved

' Property defaults
Private Const defOverwrite As Boolean = False
Private Const defAutoQuote As Boolean = True

' *************************************************
'  Initialization / Termination
' *************************************************
Private Sub Class_Initialize()
   ' Set property defaults.
   m_Overwrite = defOverwrite
   m_AutoQuote = defAutoQuote
   ' Create new IShellLink interface
   Set m_ShellLink = New ShellLinkA
   ' Implement ShellLinkA's IPersistFile interface
   Set m_PersistFile = m_ShellLink
End Sub

Private Sub Class_Terminate()
   ' Clean up.
   Set m_PersistFile = Nothing
   Set m_ShellLink = Nothing
End Sub

' *************************************************
'  Public Properties (read-write)
' *************************************************
Public Property Get Arguments() As String
   Dim Buffer As String
   With m_ShellLink
      Buffer = Space$(MAX_PATH)
      Call .GetArguments(Buffer, Len(Buffer))
      Arguments = TrimNull(Buffer)
   End With
End Property

Public Property Let Arguments(ByVal Args As String)
   With m_ShellLink
      If Args <> Me.Arguments Then
         .SetArguments Args
         m_Dirty = True
      End If
   End With
End Property

Public Property Get AutoQuote() As Boolean
   AutoQuote = m_AutoQuote
End Property

Public Property Let AutoQuote(ByVal NewVal As Boolean)
   m_AutoQuote = NewVal
End Property

Public Property Get Description() As String
   Dim Buffer As String
   With m_ShellLink
      Buffer = Space$(MAX_PATH)
      Call .GetDescription(Buffer, Len(Buffer))
      Description = TrimNull(Buffer)
   End With
End Property

Public Property Let Description(ByVal Desc As String)
   With m_ShellLink
      If Desc <> Me.Description Then
         .SetDescription Desc
         m_Dirty = True
      End If
   End With
End Property

Public Property Get Hotkey() As Long
   ' *** pwHotkey ***
   ' Address of the hot key. The virtual key code is in the
   ' low-order byte, and the modifier flags are in the
   ' high-order byte. The modifier flags can be a combination
   ' of the following values:
   '    HOTKEYF_ALT      ALT key
   '    HOTKEYF_CONTROL  CTRL key
   '    HOTKEYF_EXT      Extended key
   '    HOTKEYF_SHIFT    SHIFT key
   With m_ShellLink
      Call .GetHotkey(Hotkey)
   End With
End Property

Public Property Let Hotkey(ByVal NewKey As Long)
   With m_ShellLink
      If NewKey <> Me.Hotkey Then
         .SetHotkey NewKey
         m_Dirty = True
      End If
   End With
End Property

Public Property Get IconLocation(Optional Index As Long = 0) As String
   Dim Buffer As String
   ' Index can't be ByVal, because it's modified by
   ' GetIconLocation call, and returned to caller.
   With m_ShellLink
      ' Request file information from ShellLink object
      Buffer = Space$(MAX_PATH)
      Call .GetIconLocation(Buffer, Len(Buffer), Index)
      ' Expand any evars and trim nulls from buffer.
      Call ExpandEnvironmentStrings(Buffer, Buffer, Len(Buffer))
      IconLocation = TrimNull(Buffer)
   End With
End Property

Public Property Let IconLocation(Optional Index As Long = 0, ByVal IconFile As String)
   ' This file must exist, or we'll error out down the line.
   With m_ShellLink
      If IsFile(IconFile) Then
         .SetIconLocation IconFile, Index
         m_Dirty = True
      End If
   End With
End Property

Public Property Get Overwrite() As Boolean
   Overwrite = m_Overwrite
End Property

Public Property Let Overwrite(ByVal NewVal As Boolean)
   m_Overwrite = NewVal
End Property

Public Property Get Target() As String
   Dim wfd As WIN32_FIND_DATA
   Dim Buffer As String
   Const SLGP_RAWPATH As Long = 4
   
   With m_ShellLink
      ' Request file information from ShellLink object
      Buffer = Space$(MAX_PATH)
      Call .GetPath(Buffer, Len(Buffer), wfd, SLGP_RAWPATH)
      ' Expand any evars and trim nulls from buffer.
      Call ExpandEnvironmentStrings(Buffer, Buffer, Len(Buffer))
      ' Remove quotes if wanted.
      If m_AutoQuote Then
         Target = QuotesRemove(TrimNull(Buffer))
      Else
         Target = TrimNull(Buffer)
      End If
   End With
End Property

Public Property Let Target(ByVal TargetFile As String)
   ' This file must exist, or we'll error out down the line.
   If IsFile(TargetFile) Then
      ' Add quotes if wanted.
      If m_AutoQuote Then
         TargetFile = QuotesAdd(TargetFile)
      End If
      If Me.Target <> TargetFile Then
         m_ShellLink.SetPath TargetFile
         m_Dirty = True
      End If
   End If
End Property

Public Property Get WindowState() As FormWindowStateConstants
   Dim nRet As Long
   ' Make request
   m_ShellLink.GetShowCmd nRet
   ' Translate API constants to
   ' values VB will understand.
   Select Case nRet
      Case SW_SHOWNORMAL:      WindowState = vbNormal
      Case SW_SHOWMAXIMIZED:   WindowState = vbMaximized
      Case SW_SHOWMINNOACTIVE: WindowState = vbMinimized
   End Select
End Property

Public Property Let WindowState(ByVal ShowCmd As FormWindowStateConstants)
   Dim NewShowCmd As Long
   ' Translate intrinsic VB constants to
   ' values the API will understand.
   Select Case ShowCmd
      Case vbNormal:    NewShowCmd = SW_SHOWNORMAL
      Case vbMaximized: NewShowCmd = SW_SHOWMAXIMIZED
      Case vbMinimized: NewShowCmd = SW_SHOWMINNOACTIVE
   End Select
   ' Make request
   With m_ShellLink
      If ShowCmd <> Me.WindowState Then
         .SetShowCmd NewShowCmd
         m_Dirty = True
      End If
   End With
End Property

Public Property Get WorkingDirectory() As String
   Dim Buffer As String
   With m_ShellLink
      Buffer = Space$(MAX_PATH)
      Call .GetWorkingDirectory(Buffer, Len(Buffer))
      WorkingDirectory = TrimNull(Buffer)
   End With
End Property

Public Property Let WorkingDirectory(ByVal WorkDir As String)
   With m_ShellLink
      If IsDirectory(WorkDir) Then
         If WorkDir <> Me.WorkingDirectory Then
            .SetWorkingDirectory WorkDir
            m_Dirty = True
         End If
      End If
   End With
End Property

' *************************************************
'  Public Properties (read-only)
' *************************************************
Public Property Get Dirty() As Boolean
   Dirty = m_Dirty
End Property

Public Property Get Exists(Optional FileSpec As String) As Boolean
   ' Default to LNK file, but accept any spec.
   If FileSpec = "" Then FileSpec = m_FileName
   Exists = IsFile(FileSpec)
End Property

Public Property Get FileName() As String
   FileName = m_FileName
End Property

' *************************************************
'  Public Methods
' *************************************************
Public Function Clone(ByVal NewLinkFile As String) As Boolean
   ' Create a new copy, and keep it current.
   Clone = PersistObject(NewLinkFile, True)
End Function

Public Function Create(ByVal TargetFile As String, ByVal LinkFile As String) As Boolean
   ' Start with a fresh object.
   Call RecreateObject
   
   ' Special cases if link file already exists.
   If IsFile(LinkFile) = True Then
      If m_Overwrite = True Then
         ' Attempt to blow away old file.
         On Error Resume Next
            Kill LinkFile
            If Err.Number Then Exit Function
         On Error GoTo 0
      Else
         ' Load it instead.
         Create = Me.Load(LinkFile)
         Exit Function
      End If
   End If
   
   ' Attempt to create file object
   m_ShellLink.SetPath TargetFile
   Create = PersistObject(LinkFile, True)
End Function

Public Function QuotesAdd(ByVal TargetFile As String)
   If Len(TargetFile) > 0 Then
      TargetFile = Trim$(TargetFile)
      ' Only proceed if we have embedded space(s)
      If InStr(TargetFile, " ") Then
         If Left$(TargetFile, 1) <> """" Then
            TargetFile = """" & TargetFile
         End If
         If Right$(TargetFile, 1) <> """" Then
            TargetFile = TargetFile & """"
         End If
      End If
   End If
   QuotesAdd = TargetFile
End Function

Public Function QuotesRemove(ByVal TargetFile As String)
   TargetFile = Trim$(TargetFile)
   If Len(TargetFile) > 2 Then
      If Left$(TargetFile, 1) = """" Then
         If Right$(TargetFile, 1) = """" Then
            TargetFile = Mid$(TargetFile, 2, Len(TargetFile) - 2)
         End If
      End If
   End If
   QuotesRemove = TargetFile
End Function

Public Function Load(ByVal LinkFile As String) As Boolean
   Const STGM_DIRECT As Long = 0&
   
   ' Start with a fresh object.
   Call RecreateObject
   
   ' Make sure we have an accessible file.
   If IsFile(LinkFile) Then
      
      ' Load Shortcut file...(must do this UNICODE hack!)
      m_PersistFile.Load StrConv(LinkFile, vbUnicode), STGM_DIRECT
      
      ' Return success code?
      If IsFile(LinkFile) Then
         m_FileName = LinkFile
         Load = True
      End If
   End If
End Function

Public Function Save() As Boolean
   ' Delegate!
   Save = PersistObject(m_FileName, True)
End Function

Public Function SaveAs(ByVal NewLinkFile As String) As Boolean
   ' Create a new copy on the file system, but
   ' keep working with current object/file.
   SaveAs = PersistObject(NewLinkFile, False)
End Function

' ***********************************************
'  Private Methods
' ***********************************************
Private Function IsFile(ByVal SpecIn As String) As Boolean
   Dim attr As Long
   ' Guard against bad SpecIn by ignoring errors.
   On Error Resume Next
   ' Get attribute of SpecIn.
   attr = GetAttr(SpecIn)
   If Err = 0 Then
      ' No error, so something was found.
      ' If Directory attribute set, then not a file.
      If (attr And vbDirectory) = vbDirectory Then
         IsFile = False
      Else
         IsFile = True
      End If
   End If
End Function

Private Function IsDirectory(ByVal SpecIn As String) As Boolean
   Dim attr As Long
   ' Guard against bad SpecIn by ignoring errors.
   On Error Resume Next
   ' Get attribute of SpecIn.
   attr = GetAttr(SpecIn)
   If Err = 0 Then
      ' No error, so something was found.
      ' If Directory attribute set, then not a file.
      If (attr And vbDirectory) = vbDirectory Then
         IsDirectory = True
      Else
         IsDirectory = False
      End If
   End If
End Function

Private Function PersistObject(ByVal LnkFile As String, ByVal Remember As Boolean) As Boolean
   ' TargetFile must exist, or we'll
   ' error out when Resolve is called.
   If Not IsFile(Me.Target) Then
      Exit Function
   End If
   
   ' Attempt to create as requested, making sure
   ' to do the stupid Unicode hack with filename.
   'On Error Resume Next
   m_ShellLink.Resolve 0&, SLR_UPDATE
   m_PersistFile.Save StrConv(LnkFile, vbUnicode), Remember
   
   ' Check if file exists.
   If IsFile(LnkFile) Then
      ' Only persist this filename if it's also
      ' remains as the current object, and not
      ' as a clone.
      If Remember Then
         m_FileName = LnkFile
         m_Dirty = False
      End If
      ' Return success code.
      PersistObject = True
   End If
End Function

Private Sub RecreateObject()
   ' Destory and recreate new instances of
   ' ShellLinkA and IPersistFile interfaces.
   Set m_PersistFile = Nothing
   Set m_ShellLink = New ShellLinkA
   Set m_PersistFile = m_ShellLink
   ' Reset persisted properties.
   m_Dirty = False
   m_FileName = ""
End Sub

Private Function TrimNull(ByVal StrIn As String) As String
   Dim nul As Long
   ' Truncate input string at first null.
   ' If no nulls, perform ordinary Trim.
   nul = InStr(StrIn, vbNullChar)
   Select Case nul
      Case Is > 1
         TrimNull = Left(StrIn, nul - 1)
      Case 1
         TrimNull = ""
      Case 0
         TrimNull = Trim(StrIn)
   End Select
End Function