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 (1.) repairing shortcuts (links) whose working directories are not valid any more or (2.) changing the working directories of shortcuts." & 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 that shall become the new working directory. (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 working directory of an LNK-file does not exist and is not the empty string, then the second selected folder becomes the new working directory of the LNK-file." & vbcrlf
shortdocu = shortdocu & "With the 'all LNK-files' option, the program tries to change the targets of all LNK-files whose working directories are not the empty string (that is, even of those LNK-files whose current working directories exist)." & vbcrlf
shortdocu = shortdocu & "With the 'recursive' option, the program also processes recursively all subfolders of the first 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 that shall become the new working directory: (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 working directories of those LNK-files whose current working directories do not exist? (Selecting 'No' means: try to change all working directories.)",vbYesNo)=vbNo then
  if msgbox("Ttry to change all working directories: 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, 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, changeall, recursive, objFSO, objShell, abortmsg)

  dim objAllfiles
  Set objAllfiles = objFolder.Files

  dim file
  dim extension
  dim shortcutpath
  dim shortcut
  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)
        If StrComp(shortcut.WorkingDirectory,"")<>0 and (changeall or not objFSO.FolderExists(shortcut.WorkingDirectory)) 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  
        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, 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 file
  dim extension
  dim shortcutpath
  dim shortcut
  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)
        If StrComp(shortcut.WorkingDirectory,"")<>0 and (changeall or not objFSO.FolderExists(shortcut.WorkingDirectory)) Then
          shortcut.WorkingDirectory = repairfolderpath
          shortcut.save
        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