Option Explicit Const ATTRIBUTESYSTEM = 4 Const OFN_NODEREFERENCELINKS = &H100000 Const MYDOCUMENTS = "Eigene Dateien" dim shortdocu shortdocu = "Tool for checking shortcuts (links)." & vbcrlf shortdocu = shortdocu & "Usage:" & vbcrlf shortdocu = shortdocu & "1. Select an arbitrary file from the folder containing the LNK-files to be processed. (Do not select a system file or a file from a system folder.)" & vbcrlf shortdocu = shortdocu & "2. Unselect/select the 'recursive' option." & vbcrlf shortdocu = shortdocu & "In the default mode, all LNK-files in the folder containing the selected file are processed: for each LNK-file, the existence of the target and the existence of the working directory are checked." & vbcrlf shortdocu = shortdocu & "With the 'recursive' option, the program also processes recursively all subfolders of the folder containing the selected file." & vbcrlf shortdocu = shortdocu & "Version: 16.11.2010. (c) M. Dom, 2010. All rights reserved. http://www.mdom.de" Wscript.Echo shortdocu dim abortmsg abortmsg=" The program will abort without output." dim objDialog Set objDialog = CreateObject("UserAccounts.CommonDialog") objDialog.Filter = "Shortcuts|*.lnk|All Files|*.*" objDialog.FilterIndex = 1 objDialog.InitialDir = "%homepath%\" & MYDOCUMENTS objDialog.Flags = OFN_NODEREFERENCELINKS dim intResult, strResult intResult = objDialog.ShowOpen strResult = objDialog.FileName Set objDialog = nothing If intResult = 0 Then Wscript.Echo "No file selected." & abortmsg Wscript.Quit end if dim folderpath, folderpathbsl folderpath = getfolderpath(strResult) folderpathbsl = withbsl(folderpath) 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) dim maxoutput, count maxoutput=15 count=0 dim outputmsg outputmsg = "LNK-files whose targets do not exist:" & vbcrlf dim existsdamagedworkdir existsdamagedworkdir=false processdirectory1 objFolder, outputmsg, maxoutput, count, existsdamagedworkdir, recursive, objFSO, objShell if existsdamagedworkdir then if count=0 then outputmsg = "LNK-files whose targets exist but whose working directories do not exist and are not the empty string:" & vbcrlf else outputmsg = outputmsg & vbcrlf & vbcrlf & "LNK-files whose targets exist but whose working directories do not exist and are not the empty string:" & vbcrlf end if processdirectory2 objFolder, outputmsg, maxoutput, count, recursive, objFSO, objShell end if If count=0 then outputmsg="Done." end if Set objFolder=nothing Set objFSO = nothing Set objShell =nothing Wscript.Echo outputmsg sub processdirectory1 (objFolder, byRef outputmsg, maxoutput, byRef count, byRef existsdamagedworkdir, 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 count0 then If not objFSO.FolderExists(shortcut.WorkingDirectory) Then existsdamagedworkdir=true 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 processdirectory1 subfolder, outputmsg, maxoutput, count, existsdamagedworkdir, true, objFSO, objShell end if Next Set objAllsubfolders = nothing end if end sub sub processdirectory2(objFolder, byRef outputmsg, maxoutput, byRef count, recursive, objFSO, objShell) dim objAllfiles Set objAllfiles = objFolder.Files dim file dim extension dim shortcutpath dim shortcut dim targetpath dim workingdirectorypath 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 workingdirectorypath = shortcut.WorkingDirectory If StrComp(workingdirectorypath,"")<>0 Then If not objFSO.FolderExists(workingdirectorypath) Then If count0 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