Option Explicit Const ATTRIBUTEREADONLY = 1 Const ATTRIBUTEHIDDEN = 2 Const ATTRIBUTESYSTEM = 4 Const ATTRIBUTEARCHIVE = 32 Const WINDOW_HANDLE = 0 Const FOLDERDIALOG_ONLYSELECT = 0 Const FOLDERDIALOG_WITHTEXT = &H10& Const MY_COMPUTER = &H11& dim shortdocu shortdocu = "Tool for (1.) replacing shortcuts (links) by their targets or (2.) copying the targets into the folder(s) containing the 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. Unselect/select the 'non deleting' option." & vbcrlf shortdocu = shortdocu & "3. Unselect/select the 'use shortcut names' option." & vbcrlf shortdocu = shortdocu & "4. 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 target is copied into the folder containing the LNK-file and the LNK-file is deleted." & vbcrlf shortdocu = shortdocu & "With the 'non deleting' option, the program does not delete the LNK-files after copying their targets." & vbcrlf shortdocu = shortdocu & "With the 'use shortcut names' option, each copied target gets the name and the attributes of its shortcut." & 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 transferableAttributes transferableAttributes = ATTRIBUTEREADONLY or ATTRIBUTEHIDDEN dim abortmsg abortmsg=" The program will abort. No file or folder has been copied or deleted." 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 deleteshortcuts if msgbox("Delete each LNK-file after copying its target?",vbYesNo)=vbNo then deleteshortcuts=false else if msgbox("Delete each LNK-file after copying its target: Are you sure?",vbYesNo)<>vbYes then Wscript.Echo "Selection not confirmed." & abortmsg Wscript.Quit else deleteshortcuts=true end if end if dim useshortcutnames if msgbox("Preserve the names and attributes of the copied targets? (Selecting 'No' means: each copied target gets the name and the attributes of its shortcut.)",vbYesNo)=vbNo then useshortcutnames=true else useshortcutnames=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, deleteshortcuts, useshortcutnames, recursive, objFSO, objShell, abortmsg processdirectory objFolder, deleteshortcuts, useshortcutnames, recursive, objFSO, objShell Set objFolder=nothing Set objFSO = nothing Set objShell =nothing Wscript.Echo "Done." sub preprocessdirectory(objFolder, deleteshortcuts, useshortcutnames, recursive, objFSO, objShell, abortmsg) dim folderpath, folderpathbsl folderpath = withoutbsl(objFSO.GetAbsolutePathName(objFolder)) folderpathbsl = withbsl(folderpath) dim checkFolderReadonly checkFolderReadonly=true dim arrayAllfiles() redim arrayAllfiles((objFolder.Files).Count-1) dim file dim i i=0 For Each file in objFolder.Files set arrayAllfiles(i) = file i=i+1 Next if recursive then dim arrayAllsubfolders() redim arrayAllsubfolders((objFolder.Subfolders).Count-1) dim subfolder i=0 For Each subfolder in objFolder.Subfolders set arrayAllsubfolders(i) = subfolder i=i+1 Next end if dim extension dim shortcutpath dim shortcut dim targetpath dim copyname dim copypath dim objCopynames set objCopynames = createObject("Scripting.Dictionary") objCopynames.CompareMode = VBTEXTCOMPARE For Each file in arrayAllfiles If (file.attributes and ATTRIBUTESYSTEM)=0 then extension = objFSO.GetExtensionName(LCase(file.name)) If extension = "lnk" then If checkFolderReadonly then If (objFolder.attributes and ATTRIBUTEREADONLY)<>0 Then Wscript.echo "The folder '" & folderpath & "' is read-only." & abortmsg Wscript.Quit Else checkFolderReadonly=false End If End If shortcutpath = objFSO.GetAbsolutePathName(file) Set shortcut = objShell.CreateShortcut(shortcutpath) targetpath = shortcut.TargetPath If not objFSO.FolderExists(targetpath) and not objFSO.FileExists(targetpath) Then if recursive then Wscript.echo "The target '" & targetpath & "' of the LNK-file '" & shortcutpath & "' does not exist." & abortmsg else Wscript.echo "The target '" & targetpath & "' of the LNK-file '" & getfilename(shortcutpath) & "' does not exist." & abortmsg end if Wscript.Quit end if if useshortcutnames then copyname = left(getfilename(shortcutpath),len(getfilename(shortcutpath))-4) else copyname = getfilename(targetpath) end if copypath = folderpathbsl + copyname If objFSO.FolderExists(copypath) Then if useshortcutnames then Wscript.Echo "There exists already a folder '" & copyname & "' in the folder '" & folderpath & "'." & abortmsg else if recursive then Wscript.Echo "The target of the LNK-file '" & shortcutpath & "' has the name '" & copyname & "'. However, there exists already a folder '" & copyname & "' in the folder '" & folderpath & "'." & abortmsg else Wscript.Echo "The target of the LNK-file '" & getfilename(shortcutpath) & "' has the name '" & copyname & "'. However, there exists already a folder '" & copyname & "' in the folder '" & folderpath & "'." & abortmsg end if end if Wscript.Quit elseif objFSO.FileExists(copypath) Then if useshortcutnames then Wscript.Echo "There exists already a file '" & copyname & "' in the folder '" & folderpath & "'." & abortmsg else if recursive then Wscript.Echo "The target of the LNK-file '" & shortcutpath & "' has the name '" & copyname & "'. However, there exists already a file '" & copyname & "' in the folder '" & folderpath & "'." & abortmsg else Wscript.Echo "The target of the LNK-file '" & getfilename(shortcutpath) & "' has the name '" & copyname & "'. However, there exists already a file '" & copyname & "' in the folder '" & folderpath & "'." & abortmsg end if end if Wscript.Quit end if if objCopynames.exists(copyname) then if useshortcutnames then if recursive then Wscript.Echo "The LNK-files '" & objCopynames.item(copyname) & "' and '" & shortcutpath & "' both have the name '" & copyname & "'. (This is possible because the NTFS file system can operate case-sensitively. However, this program, like most Windows programs, can not.)" & abortmsg else Wscript.Echo "The LNK-files '" & getfilename(objCopynames.item(copyname)) & "' and '" & getfilename(shortcutpath) & "' both have the name '" & copyname & "'. (This is possible because the NTFS file system can operate case-sensitively. However, this program, like most Windows programs, can not.)" & abortmsg end if else if recursive then Wscript.Echo "The targets of the LNK-files '" & objCopynames.item(copyname) & "' and '" & shortcutpath & "' both have the name '" & copyname & "'." & abortmsg else Wscript.Echo "The targets of the LNK-files '" & getfilename(objCopynames.item(copyname)) & "' and '" & getfilename(shortcutpath) & "' both have the name '" & copyname & "'." & abortmsg end if end if Wscript.Quit else objCopynames.add copyname, shortcutpath end if if deleteshortcuts 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 objCopynames = nothing For Each file in arrayAllfiles set file = nothing Next redim arrayAllfiles(-1) if recursive then For Each subfolder in arrayAllsubfolders If (subfolder.attributes and ATTRIBUTESYSTEM)=0 then preprocessdirectory subfolder, deleteshortcuts, useshortcutnames, true, objFSO, objShell, abortmsg End If Next For Each subfolder in arrayAllsubfolders set subfolder = nothing Next redim arrayAllsubfolders(-1) end if end sub sub processdirectory(objFolder, deleteshortcuts, useshortcutnames, recursive, objFSO, objShell) dim folderpath, folderpathbsl folderpath = withoutbsl(objFSO.GetAbsolutePathName(objFolder)) folderpathbsl = withbsl(folderpath) dim arrayAllfiles() redim arrayAllfiles((objFolder.Files).Count-1) dim file dim i i=0 For Each file in objFolder.Files set arrayAllfiles(i) = file i=i+1 Next if recursive then dim arrayAllsubfolders() redim arrayAllsubfolders((objFolder.Subfolders).Count-1) dim subfolder i=0 For Each subfolder in objFolder.Subfolders set arrayAllsubfolders(i) = subfolder i=i+1 Next end if dim extension dim shortcutpath dim shortcut dim targetpath dim newattributes dim copiedobject For Each file in arrayAllfiles 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) Then if useshortcutnames then objFSO.CopyFolder targetpath, folderpathbsl & left(getfilename(shortcutpath),len(getfilename(shortcutpath))-4), false set copiedobject = objFSO.GetFolder(folderpathbsl & left(getfilename(shortcutpath),len(getfilename(shortcutpath))-4)) newattributes = ((copiedobject.attributes or transferableAttributes) xor transferableAttributes) or (file.attributes and transferableAttributes) if copiedobject.attributes<>newattributes then copiedobject.attributes = newattributes set copiedobject = nothing else objFSO.CopyFolder targetpath, folderpathbsl, false set copiedobject = objFSO.GetFolder(folderpathbsl & getfilename(targetpath)) newattributes = ((copiedfile.attributes or transferableAttributes) xor transferableAttributes) or ((objFSO.GetFolder(targetpath)).attributes and transferableAttributes) if copiedobject.attributes<>newattributes then copiedobject.attributes = newattributes set copiedobject = nothing end if if deleteshortcuts then file.delete() end if elseif objFSO.FileExists(targetpath) Then if useshortcutnames then objFSO.CopyFile targetpath, folderpathbsl & left(getfilename(shortcutpath),len(getfilename(shortcutpath))-4), false set copiedobject = objFSO.GetFile(folderpathbsl & left(getfilename(shortcutpath),len(getfilename(shortcutpath))-4)) newattributes = ((copiedobject.attributes or transferableAttributes) xor transferableAttributes) or (file.attributes and transferableAttributes) if copiedobject.attributes<>newattributes then copiedobject.attributes = newattributes set copiedobject = nothing else objFSO.CopyFile targetpath, folderpathbsl, false set copiedobject = objFSO.GetFile(folderpathbsl & getfilename(targetpath)) newattributes = ((copiedobject.attributes or transferableAttributes) xor transferableAttributes) or ((objFSO.GetFile(targetpath)).attributes and transferableAttributes) if copiedobject.attributes<>newattributes then copiedobject.attributes = newattributes set copiedobject = nothing end if if deleteshortcuts then file.delete() end if end if Set shortcut = nothing End If End If Next For Each file in arrayAllfiles set file = nothing Next redim arrayAllfiles(-1) if recursive then For Each subfolder in arrayAllsubfolders If (subfolder.attributes and ATTRIBUTESYSTEM)=0 then processdirectory subfolder, deleteshortcuts, useshortcutnames, true, objFSO, objShell End If Next For Each subfolder in arrayAllsubfolders set subfolder = nothing Next redim arrayAllsubfolders(-1) 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