Option Explicit Const ATTRIBUTEREADONLY = 1 Const ATTRIBUTESYSTEM = 4 Const WINDOW_HANDLE = 0 Const FOLDERDIALOG_ONLYSELECT = 0 Const FOLDERDIALOG_WITHTEXT = &H10& Const MY_COMPUTER = &H11& Const OUTPUTFILENAME = "shortcutList.txt" dim shortdocu shortdocu = "Tool for creating a list (in ASCII format) of the targets of shortcuts (links)." & vbcrlf shortdocu = shortdocu & "Usage:" & vbcrlf shortdocu = shortdocu & "1. Select the folder containing the LNK-files to be processed. (Do not select a system folder.)" & vbcrlf shortdocu = shortdocu & "2. Unselect/select the 'names only' option." & vbcrlf shortdocu = shortdocu & "3. Unselect/select the 'with arguments' option." & vbcrlf shortdocu = shortdocu & "4. Unselect/select the 'recursive' option." & vbcrlf shortdocu = shortdocu & "In the default mode, all LNK-files in the selected folder are processed: for each LNK-file, the target path is written into the file '" & OUTPUTFILENAME & "' (in the selected folder)." & vbcrlf shortdocu = shortdocu & "With the 'names only' option, the program writes only the names of the targets instead of the paths." & vbcrlf shortdocu = shortdocu & "With the 'with arguments' option, the program also writes the arguments." & vbcrlf shortdocu = shortdocu & "With the 'recursive' option, the program also processes recursively all subfolders of the selected folder." & vbcrlf shortdocu = shortdocu & "Version: 17.9.2015. (c) M. Dom, 2010-2015. All rights reserved. http://www.mdom.de" Wscript.Echo shortdocu dim abortmsg abortmsg=" The program will abort. The list has not been created." dim objShellApplication Set objShellApplication = CreateObject("Shell.Application") dim objSelectFolder Set objSelectFolder = objShellApplication.Namespace(MY_COMPUTER) Set objSelectFolder = objSelectFolder.Self Set objSelectFolder = objShellApplication.BrowseForFolder(WINDOW_HANDLE, "Select the folder containing the LNK-files to be processed: (Do not select a system folder.)", FOLDERDIALOG_ONLYSELECT, objSelectFolder.Path) Set objShellApplication = nothing If objSelectFolder Is Nothing Then Wscript.Echo "No folder selected." & abortmsg Wscript.Quit End If Set objSelectFolder = objSelectFolder.Self dim folderpath, folderpathbsl folderpath = withoutbsl(objSelectFolder.Path) folderpathbsl = withbsl(folderpath) Set objSelectFolder = nothing dim onlynames if msgbox("Write the whole target paths? (Selecting 'No' means: write only the names of the targets instead of the paths.)",vbYesNo)=vbNo then onlynames=true else onlynames=false end if dim witharguments if msgbox("Write arguments?",vbYesNo)=vbNo then witharguments = false else witharguments = true end if dim recursive if msgbox("Process only the LNK-files in '" & folderpath & "'? (Selecting 'No' means: also process recursively all subfolders.)",vbYesNo)=vbNo then recursive=true else recursive=false end if dim objShell, objFSO Set objShell = CreateObject("WScript.Shell") Set objFSO = CreateObject("Scripting.FileSystemObject") dim objFolder Set objFolder = objFSO.GetFolder(folderpath) If (objFolder.attributes and ATTRIBUTEREADONLY)<>0 Then Wscript.echo "The folder '" & folderpath & "' is read-only." & abortmsg Wscript.Quit End If If objFSO.FileExists(folderpathbsl & OUTPUTFILENAME) Then Wscript.echo "There exists already a file '" & OUTPUTFILENAME & "' in the folder '" & folderpath & "'." & abortmsg Wscript.Quit end if If objFSO.FolderExists(folderpathbsl & OUTPUTFILENAME) Then Wscript.echo "There exists already a folder '" & OUTPUTFILENAME & "' in the folder '" & folderpath & "'." & abortmsg Wscript.Quit end if dim objOutputfile Set objOutputfile = objFSO.OpenTextFile(folderpathbsl & OUTPUTFILENAME,2,true) dim existsdamaged, existscorrect existsdamaged=false existscorrect=false processdirectory1 objFolder, existscorrect, existsdamaged, objOutputfile, onlynames, recursive, objFSO, objShell if existsdamaged then if existscorrect then objOutputfile.writeline() end if if recursive then objOutputfile.writeline("LNK-files in the folder " & folderpath & " (and its subfolders) whose targets do not exist:") else objOutputfile.writeline("LNK-files in the folder " & folderpath & " whose targets do not exist:") end if objOutputfile.writeline() processdirectory2 objFolder, objOutputfile, onlynames, recursive, objFSO, objShell end if objOutputfile.close Set objOutputfile = nothing Set objFolder=nothing Set objFSO = nothing Set objShell =nothing Wscript.Echo "Done." sub processdirectory1 (objFolder, byRef existscorrect, byRef existsdamaged, objOutputfile, onlynames, recursive, objFSO, objShell) dim objAllfiles Set objAllfiles = objFolder.Files dim file dim extension dim shortcutpath dim shortcut dim targetpath For Each file in objAllfiles If (file.attributes and ATTRIBUTESYSTEM)=0 then extension = objFSO.GetExtensionName(LCase(file.name)) If extension = "lnk" then shortcutpath = objFSO.GetAbsolutePathName(file) Set shortcut = objShell.CreateShortcut(shortcutpath) targetpath = shortcut.TargetPath If objFSO.FolderExists(targetpath) or objFSO.FileExists(targetpath) Then if onlynames then if witharguments then objOutputfile.writeline(getfilename(targetpath) & String(Len(Left(shortcut.arguments, 1)), " ") & shortcut.arguments) else objOutputfile.writeline(getfilename(targetpath)) end if else if witharguments then objOutputfile.writeline(targetpath & String(Len(Left(shortcut.arguments, 1)), " ") & shortcut.arguments) else objOutputfile.writeline(targetpath) end if end if existscorrect=true else existsdamaged=true end if Set shortcut = nothing End If End If Next Set objAllfiles = nothing if recursive then dim objAllsubfolders Set objAllsubfolders = objFolder.Subfolders dim subfolder For Each subfolder in objAllsubfolders If (subfolder.attributes and ATTRIBUTESYSTEM)=0 then processdirectory1 subfolder, existscorrect, existsdamaged, objOutputfile, onlynames, true, objFSO, objShell End If Next Set objAllsubfolders = nothing end if end sub sub processdirectory2 (objFolder, objOutputfile, onlynames, recursive, objFSO, objShell) dim objAllfiles Set objAllfiles = objFolder.Files dim file dim extension dim shortcutpath dim shortcut dim targetpath For Each file in objAllfiles If (file.attributes and ATTRIBUTESYSTEM)=0 then extension = objFSO.GetExtensionName(LCase(file.name)) If extension = "lnk" then shortcutpath = objFSO.GetAbsolutePathName(file) Set shortcut = objShell.CreateShortcut(shortcutpath) targetpath = shortcut.TargetPath If not objFSO.FolderExists(targetpath) and not objFSO.FileExists(targetpath) Then if onlynames then if recursive then if witharguments then objOutputfile.writeline(shortcutpath & ": " & getfilename(targetpath) & String(Len(Left(shortcut.arguments, 1)), " ") & shortcut.arguments) else objOutputfile.writeline(shortcutpath & ": " & getfilename(targetpath)) end if else if witharguments then objOutputfile.writeline(getfilename(shortcutpath) & ": " & getfilename(targetpath) & String(Len(Left(shortcut.arguments, 1)), " ") & shortcut.arguments) else objOutputfile.writeline(getfilename(shortcutpath) & ": " & getfilename(targetpath)) end if end if else if recursive then if witharguments then objOutputfile.writeline(shortcutpath & ": " & targetpath & String(Len(Left(shortcut.arguments, 1)), " ") & shortcut.arguments) else objOutputfile.writeline(shortcutpath & ": " & targetpath) end if else if witharguments then objOutputfile.writeline(getfilename(shortcutpath) & ": " & targetpath & String(Len(Left(shortcut.arguments, 1)), " ") & shortcut.arguments) else objOutputfile.writeline(getfilename(shortcutpath) & ": " & targetpath) end if end if end if end if Set shortcut = nothing End If End If Next Set objAllfiles = nothing if recursive then dim objAllsubfolders Set objAllsubfolders = objFolder.Subfolders dim subfolder For Each subfolder in objAllsubfolders If (subfolder.attributes and ATTRIBUTESYSTEM)=0 then processdirectory2 subfolder, objOutputfile, onlynames, true, objFSO, objShell End If Next Set objAllsubfolders = nothing end if end sub function withbsl (folderpathOrFoldername) if isnull(folderpathOrFoldername) then withbsl=null elseif StrComp(folderpathOrFoldername,"")=0 then withbsl="" elseif StrComp(Right(folderpathOrFoldername,1),"\")=0 then withbsl=folderpathOrFoldername else withbsl=folderpathOrFoldername & "\" end if end function function withoutbsl (folderpathOrFoldername) if isnull(folderpathOrFoldername) then withoutbsl=null elseif StrComp(folderpathOrFoldername,"")=0 then withoutbsl="" elseif StrComp(Right(folderpathOrFoldername,1),"\")=0 then withoutbsl=left(folderpathOrFoldername,len(folderpathOrFoldername)-1) else withoutbsl=folderpathOrFoldername end if end function function getfolderpath (filepath) if isnull(filepath) then getfolderpath=null exit function end if dim myfilepath myfilepath=withoutbsl(filepath) dim bslpos, nextbslpos bslpos=0 do nextbslpos=InStr(bslpos+1,myfilepath,"\") If nextbslpos>0 Then bslpos=nextbslPos loop until nextbslpos=0 if bslpos>0 then getfolderpath = left(myfilepath,bslPos-1) else ' cannot happen? getfolderpath="" end if end function function getfilename (filepathOrFilename) if isnull(filepathOrFilename) then getfilename=null exit function end if dim myfilepathOrFilename myfilepathOrFilename=withoutbsl(filepathOrFilename) dim bslpos, nextbslpos bslpos=0 do nextbslpos=InStr(bslpos+1,myfilepathOrFilename,"\") If nextbslpos>0 Then bslpos=nextbslPos loop until nextbslpos=0 if bslpos>0 then getfilename = mid(myfilepathOrFilename,bslPos+1) else getfilename = myfilepathOrFilename end if end function