Option Explicit

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

dim shortdocu
shortdocu = "Tool for repairing shortcuts (links) whose targets have been moved or copied to a new location. For all shortcuts to be repaired, this new location must be one and the same folder." & 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. Select the folder containing the targets of the LNK-files. (Do not select a system folder.)" & vbcrlf
shortdocu = shortdocu & "3. Unselect/select the 'all LNK-files' option." & vbcrlf
shortdocu = shortdocu & "4. Unselect/select the 'recursive' option." & vbcrlf
shortdocu = shortdocu & "In the default mode, all LNK-files in the first selected folder are processed: if the target of an LNK-file does not exist, then the second selected folder is considered, and if there exists a file or folder with the same name as the target of the LNK-file, then this file or folder becomes the new target of the LNK-file (and the folder of the new target becomes the new working directory of the LNK-file if this makes sense)." & vbcrlf
shortdocu = shortdocu & "With the 'all LNK-files' option, the program tries to change the targets of all LNK-files (that is, even of those LNK-files whose current targets exist)." & 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. No LNK-file has been changed."

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)
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

Set objSelectFolder = objShellApplication.Namespace(MY_COMPUTER)
Set objSelectFolder = objSelectFolder.Self
Set objSelectFolder = objShellApplication.BrowseForFolder(WINDOW_HANDLE, "Select the folder containing the targets of the LNK-files: (Do not select a system folder.)", FOLDERDIALOG_ONLYSELECT, objSelectFolder.Path)
If objSelectFolder Is Nothing Then
    Wscript.Echo "No folder selected." & abortmsg
    Wscript.Quit
End If
Set objSelectFolder = objSelectFolder.Self
dim repairfolderpath, repairfolderpathbsl
repairfolderpath = withoutbsl(objSelectFolder.Path)
repairfolderpathbsl = withbsl(repairfolderpath)
Set objSelectFolder = nothing
Set objShellApplication = nothing

dim changeall
if msgbox("Try to change only the targets of those LNK-files whose current targets do not exist? (Selecting 'No' means: try to change all targets.)",vbYesNo)=vbNo then
  if msgbox("Try to change all targets: Are you sure?",vbYesNo)<>vbYes then
    Wscript.Echo "Selection not confirmed." & abortmsg
    Wscript.Quit
  else
    changeall=true
  end if
else
  changeall=false
end if

dim recursive
if msgbox("Process only the LNK-files in '" & folderpath & "'? (Selecting 'No' means: also process recursively all subfolders.)",vbYesNo)=vbNo then
  if msgbox("Also process recursively all subfolders: Are you sure?",vbYesNo)<>vbYes then
    Wscript.Echo "Selection not confirmed." & abortmsg
    Wscript.Quit
  else
    recursive=true
  end if
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)

preprocessdirectory objFolder, repairfolderpath, changeall, recursive, objFSO, objShell, abortmsg
processdirectory objFolder, repairfolderpath, changeall, recursive, objFSO, objShell

Set objFolder=nothing
Set objFSO = nothing
Set objShell =nothing

Wscript.Echo "Done."

sub preprocessdirectory(objFolder, repairfolderpath, changeall, recursive, objFSO, objShell, abortmsg)

  dim objAllfiles
  Set objAllfiles = objFolder.Files

  dim repairfolderpathbsl
  repairfolderpathbsl = withbsl(repairfolderpath)

  dim file
  dim extension
  dim shortcutpath
  dim shortcut
  dim targetpath
  dim repairtargetpath
  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 changeall or (not objFSO.FolderExists(targetpath) and not objFSO.FileExists(targetpath)) Then 
          repairtargetpath = repairfolderpathbsl & getfilename(targetpath)
          If objFSO.FolderExists(repairtargetpath) or objFSO.FileExists(repairtargetpath) Then
            if (file.attributes and ATTRIBUTEREADONLY)<>0 then
              if recursive then 
                Wscript.Echo "The LNK-file '" & shortcutpath & "' is read-only." & abortmsg
              else
                Wscript.Echo "The LNK-file '" & getfilename(shortcutpath) & "' is read-only." & abortmsg
              end if
              Wscript.Quit
            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
        preprocessdirectory subfolder, repairfolderpath, changeall, true, objFSO, objShell, abortmsg
      End If
    Next
    Set objAllsubfolders = nothing
  end if

end sub

sub processdirectory(objFolder, repairfolderpath, changeall, recursive, objFSO, objShell)

  dim objAllfiles
  Set objAllfiles = objFolder.Files

  dim repairfolderpathbsl
  repairfolderpathbsl = withbsl(repairfolderpath)

  dim file
  dim extension
  dim shortcutpath
  dim shortcut
  dim targetpath
  dim repairtargetpath
  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 changeall or (not objFSO.FolderExists(targetpath) and not objFSO.FileExists(targetpath)) Then 
          repairtargetpath = repairfolderpathbsl & getfilename(targetpath)
          If objFSO.FolderExists(repairtargetpath) or objFSO.FileExists(repairtargetpath) Then
            shortcut.TargetPath = repairtargetpath
            if StrComp(withoutbsl(shortcut.WorkingDirectory), getfolderpath(targetpath), VBTEXTCOMPARE)=0 then
              shortcut.WorkingDirectory = repairfolderpath
            end if
            shortcut.save
          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
        processdirectory subfolder, repairfolderpath, changeall, 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