Option Explicit

Const ATTRIBUTESYSTEM = 4
Const WINDOW_HANDLE = 0
Const FOLDERDIALOG_ONLYSELECT = 0
Const FOLDERDIALOG_WITHTEXT = &H10&
Const MY_COMPUTER = &H11&

dim shortdocu
shortdocu = "Tool for checking 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 'recursive' option." & vbcrlf
shortdocu = shortdocu & "In the default mode, all LNK-files in the selected folder 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 selected folder." & 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 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 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 count<maxoutput then
            if recursive then
              outputmsg = outputmsg & vbcrlf & shortcutpath & ": " & targetpath
            else
              outputmsg = outputmsg & vbcrlf & getfilename(shortcutpath) & ": " & targetpath
            end if
          else
            outputmsg = outputmsg & vbcrlf & "..."
          end if
          count=count+1
          if count=maxoutput+1 then
            Wscript.echo outputmsg
            Wscript.Quit
          end if
        elseif not existsdamagedworkdir then
          if StrComp(shortcut.WorkingDirectory,"")<>0 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 count<maxoutput then
                if recursive then
                  outputmsg = outputmsg & vbcrlf & shortcutpath & ": " & workingdirectorypath
                else
                  outputmsg = outputmsg & vbcrlf & getfilename(shortcutpath) & ": " & workingdirectorypath
                end if
              else
                outputmsg = outputmsg & vbcrlf & "..."
              end if
              count=count+1
              if count=maxoutput+1 then
                Wscript.echo outputmsg
                Wscript.Quit
              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, outputmsg, maxoutput, count, 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