VBA后续调用Dir（）返回相同的文件

我正在尝试search快捷方式的目录，获取快捷方式的path，并将这些path添加到集合中，以备后用。 然而，随后对Dir（）的调用一次又一次地返回相同的文件。 我已经隔离了通过调用下面定义的函数Getlnkpath导致的问题。 这个函数我没有自己写，所以我不确定是什么导致这种行为，或者如何解决它。

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

这可能会更安全

• 第一：收集所有的链接path

• 那么：收集所有的链接目标path

这样第一个集合可以保持稳定，无论后续的操作如何（除非删除了一些链接或文件夹…）

此外，我build议初始化一个Wscript.Shell对象，并处理所有对它的CreateShortcut()调用，而不是为每个链接实例化一个对象

最后我自己正朝着使用FileSystemObject代替Dir()函数的方向发展，这是因为我有时遇到了后者遇到的问题。 这只需要增加对Microsoft Scripting Runtime库的引用即可

对于上面我提出的以下代码：

 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 

相反，如果你想继续使用Dir()函数，那么只需更改GetLinksPaths()函数，如下所示：

 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 

顺便说一句： CreateObject("Wscript.Shell").CreateShortcut(Lnk)方法返回和对象（ WshShortcut或WshURLShortcut之一）不支持任何Close()方法，因为您在Getlnkpath()函数中。 因此，删除它以删除On Error Resume Next语句的必要性

Answer 2

看起来你正在用你的函数创build一个新的.lnk文件，然后你的dir命令find新创build的链接（它覆盖了旧链接）。 尝试在你的函数中使用GetShortcut而不是CreateShortcut 。