[VB6, Vista+] Finding and deleting invalid shortcuts with IShellLink and IShellItem

[fafalone]

Dead Link Cleaner
So I went looking for a utility to do this for me, and couldn't find one that either itself or its installer didn't look shady/spammy. Since shell interfaces are my favorite thing anyway, I went ahead and wrote program to make it.

I'm posting here instead of utilities because this example marks the first VB6 a technique for enumerating/searching files recursively using the standard IShellItem interface, where most previous examples either aren't recursive, aren't for general file system locations, or use a different method- sticking with IShellItem increases your coding efficiency since you don't need to convert between different ways of interacting with the file system.

Unicode is fully supported. The textbox and listbox are the standard VB controls so won't display Unicode, but the names are stored internally so everything will work; just if you need to use a path with Unicode extended characters in the name, select it with the Browse... button.

Requirements
-Windows Vista or newer (the link check/delete works on XP but the file enumeration uses IEnumShellItems, which is only available as of Vista)
-oleexp.tlb v4.0 or newer
-oleexp addon mIID.bas (included in oleexp download)

Code
The code here is to show core concepts, see the full project in the attachment for additional declares and support functions that the below requires to run.

We use IShellLinkW and IPersistFile to load links and grab their target:

Public Function GetLinkTarget(sLNK As String, Optional bResolve As Boolean = False) As String
Dim pSL As ShellLinkW
Dim ipf As IPersistFile
Dim sTar As String
Dim wfd As WIN32_FIND_DATAW

On Error GoTo e0

Set pSL = New ShellLinkW
Set ipf = pSL

ipf.Load sLNK, STGM_READ
If bResolve Then
    pSL.Resolve 0, SLR_UPDATE Or SLR_NO_UI
End If
sTar = String$(MAX_PATH, 0)
pSL.GetPath sTar, MAX_PATH, wfd, SLGP_UNCPRIORITY

pSL.Release

If InStr(sTar, vbNullChar) > 2 Then
    sTar = Left$(sTar, InStr(sTar, vbNullChar) - 1)
End If
If Left$(sTar, 1) = vbNullChar Then
    GetLinkTarget = ""
Else
    GetLinkTarget = sTar
End If
Exit Function
e0:
    Debug.Print "GetLinkTarget.Error->" & Err.Description & "(" & Err.Number & ")"
End Function

And the new recursive scanning with only IShellItem and IEnumShellItems is done like this:

Private Sub Command2_Click()
Dim psi As IShellItem
Dim piesi As IEnumShellItems
Dim isia As IShellItemArray
Dim pidl As Long
Dim pFile As IShellItem
Dim lpName As Long, lpFolder As Long
Dim sName As String, sFolder As String
Dim sDisp As String
Dim pcl As Long
Dim sTarget As String
Dim sStart As String
Dim lAtr As SFGAO_Flags
List1.Clear
ReDim arToDel(0)
nToDel = 0
nLinks = 0
bRslv = (Check3.Value = vbChecked)

pidl = ILCreateFromPathW(StrPtr(sRoot))
SHCreateItemFromIDList pidl, IID_IShellItem, psi
psi.BindToHandler 0&, BHID_EnumItems, IID_IEnumShellItems, piesi

Do While piesi.Next(1&, pFile, pcl) = S_OK
    pFile.GetDisplayName SIGDN_DESKTOPABSOLUTEPARSING, lpFolder
    Debug.Print "Obj " & LPWSTRtoStr(lpFolder)
    pFile.GetAttributes SFGAO_FOLDER Or SFGAO_DROPTARGET Or SFGAO_STREAM, lAtr
    If (lAtr And SFGAO_STREAM) = 0 Then
        If (lAtr And SFGAO_FOLDER) = SFGAO_FOLDER Then
            If (lAtr And SFGAO_DROPTARGET) = SFGAO_DROPTARGET Then
            If Check1.Value = vbChecked Then
                Debug.Print "FOLDER MATCH"
                ScanDeep pFile
            End If
            End If
        Else
            pFile.GetDisplayName SIGDN_DESKTOPABSOLUTEPARSING, lpName
            sName = LPWSTRtoStr(lpName)
            sDisp = Right(sName, Len(sName) - InStrRev(sName, "\"))
            If Right$(sName, 4) = ".lnk" Then
                Debug.Print "Found link: " & sName
                nLinks = nLinks + 1
                sTarget = GetLinkTarget(sName, bRslv)
                Debug.Print "Link Targt: " & sTarget
                If PathFileExistsW(StrPtr(sTarget)) Then
    '                Debug.Print "Link is valid, skipping."
                Else
                    Debug.Print "Link is invalid, deleting..."
                    ReDim Preserve arToDel(nToDel)
                    arToDel(nToDel) = sName
                    nToDel = nToDel + 1
                    List1.AddItem sDisp
                End If
            End If
        End If
    End If
Loop
Label2.Caption = "Checked " & nLinks & " links total, " & nToDel & " no longer valid and pending deletion."
Call CoTaskMemFree(pidl)

End Sub
Private Sub ScanDeep(psiLoc As IShellItem)
'for recursive scan
Dim psi As IShellItem
Dim piesi As IEnumShellItems
Dim pFile As IShellItem
Dim lpName As Long
Dim sName As String
Dim sDisp As String
Dim pcl As Long
Dim sTarget As String
Dim lAtr As SFGAO_Flags


psiLoc.BindToHandler 0&, BHID_EnumItems, IID_IEnumShellItems, piesi
Do While piesi.Next(1&, pFile, pcl) = S_OK
    pFile.GetAttributes SFGAO_FOLDER Or SFGAO_DROPTARGET Or SFGAO_STREAM, lAtr
    If (lAtr And SFGAO_STREAM) = 0 Then
        If (lAtr And SFGAO_FOLDER) = SFGAO_FOLDER Then
            If (lAtr And SFGAO_DROPTARGET) = SFGAO_DROPTARGET Then
                ScanDeep pFile
            End If
        End If
    Else
        pFile.GetDisplayName SIGDN_DESKTOPABSOLUTEPARSING, lpName
        sName = LPWSTRtoStr(lpName)
        sDisp = Right(sName, Len(sName) - InStrRev(sName, "\"))
        If Right$(sName, 4) = ".lnk" Then
            Debug.Print "Found link: " & sName
            nLinks = nLinks + 1
            sTarget = GetLinkTarget(sName, bRslv)
            If PathFileExistsW(StrPtr(sTarget)) Then
'                Debug.Print "Link is valid, skipping."
            Else
                Debug.Print "Link is invalid, deleting..."
                ReDim Preserve arToDel(nToDel)
                arToDel(nToDel) = sName
                nToDel = nToDel + 1
                List1.AddItem sDisp
            End If
        End If
    End If
Loop
End Sub

UPDATE - 2017 Jun 15
Project updated to Version 2 with the following changes:
-Added checks to the recursive search function to avoid enumerating zip/cab files and certain types of other containers
-Added option to call Resolve method to attempt to fix broken links where the target still exists somewhere (this isn't like a full search it only checks certain ways, so it doesn't add any noticeable time to the check). If enabled and successful the link file is updated and is never listed as broken.
-Added error handler in GetLinkTarget in case loading or GetPath fails