VBA subsequent calls to Dir() returns same file

Question

I am trying to search through a directory for Shortcuts, get the path for the Shortcut, and add those paths to a collection, for later usage. However subsequent calls to Dir() returns the same file over and over again. I have isolated the problem to being caused by calling the Function Getlnkpath defined below. This function I haven't written myself, so I am unsure exactly what is causing this behaviour, or how to fix it.

tempPath = Dir(startPath & "*.lnk")
Do Until tempPath = vbNullString
    myCollection.Add Getlnkpath(startPath & tempPath) & "\"
    tempPath = Dir()
Loop

Function Getlnkpath(ByVal Lnk As String)
   On Error Resume Next
   With CreateObject("Wscript.Shell").CreateShortcut(Lnk)
       Getlnkpath = .TargetPath
       .Close
   End With
End Function

Answer 1

It might be safer to

• first: collect all links paths

• then: collect all link target paths

so that the first collection stays stable whatever the subsequent operations may do (unless they delete some link or some folder...)

moreover I'd suggest to initialize one Wscript.Shell object only and handle all calls to its CreateShortcut() with it, instead of instantiating one object for each link

finally I myself am drifting towards the use of FileSystemObject in lieu of Dir() function, due to problems I sometimes meet with the latter. this at the only expense of adding the reference to Microsoft Scripting Runtime library

for what above I propose the following code:

Option Explicit

Sub main()
    Dim startPath As String
    Dim myLinkTargetPaths As New Collection, myLinkFilePaths As Collection

    startPath = "C:\myPath\"

    Set myLinkFilePaths = GetLinksPaths(startPath) 'first get the collection of all links path
    Set myLinkTargetPaths = GetLinksTarget(myLinkFilePaths) ' then get the collection of all links TargetPaths

End Sub


Function GetLinksTarget(myLinkFilePaths As Collection) As Collection
    Dim myColl As New Collection
    Dim element As Variant

    With CreateObject("Wscript.Shell")
        For Each element In myLinkFilePaths
            myColl.Add .CreateShortcut(element).TargetPath & "\"
        Next element
    End With
    Set GetLinksTarget = myColl
End Function     


Function GetLinksPaths(startPath As String) As Collection

    Dim objFso As FileSystemObject '<~~ requires adding reference to `Microsoft Scripting Runtime` library
    Dim objFile As File
    Dim objFolder As Folder
    Dim myColl As New Collection

    Set objFso = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFso.GetFolder(startPath)

    For Each objFile In objFolder.Files
        If objFso.GetExtensionName(objFile.Path) = "lnk" Then myColl.Add objFile.Path
    Next
    Set GetLinksPaths = myColl

End Function

instead, should you want to go on with Dir() function then just change the GetLinksPaths() function as follows:

Function GetLinksPaths(startPath As String) As Collection
    Dim tempPath As String
    Dim myColl As New Collection

    tempPath = Dir(startPath & "*.lnk")
    Do Until tempPath = vbNullString
        myColl.Add startPath & tempPath
        tempPath = Dir()
    Loop
    Set GetLinksPaths = myColl

End Function

BTW: the CreateObject("Wscript.Shell").CreateShortcut(Lnk) method returns and object (either a WshShortcut or a WshURLShortcut one) that doesn't support any Close() method as you have in your Getlnkpath() function. So remove it to remove the necessity of On Error Resume Nextstatement

Answer 2

Looks like you are creating a new .lnk file with your function and your dir command finds that newly created link (that has overwritten the old one) next. Try to use GetShortcut instead of CreateShortcut in your function.