Option Explicit

Const ATTRIBUTEREADONLY = 1
Const ATTRIBUTESYSTEM = 4
Const OFN_NODEREFERENCELINKS = &H100000
Const MYDOCUMENTS = "Eigene Dateien"
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 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 '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 folder containing the selected file are processed: for each LNK-file, the target path is written into the file '" & OUTPUTFILENAME & "' (in the folder containing the selected file)." & 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 folder containing the selected file." & 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 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 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