'#################################################
' The purpose of this VBS is for creating the shortcut set for the public folders
' The reason why create this VBS is: some same style information was saved in different subfolder, it is not easy to find out all similar information from a lot off subfolder
'
' This VBS is planed to perform at 2:10 each day.
'
'Functions description:
'1: Generate Shortcuts set for target subfolders
'2: Check all old exist Shortcuts if they are invalid, if yes, delete it
'3: Generate shortcuts according to the distination subfolders
' Created by Tom Yu / 2012-07-15
'#################################################
Dim LogAddress, ShutCutAdd, DGFolder, SCFolder
LogAddress = "d:\Suppliers\00_AUTOSET\AUTOSET.log" ' ###Address of log, normally, it is not necessary to change
ShutCutAdd = "d:\Suppliers\00_AUTOSET\Audits\" ' ###Folder of the shortcut set, the actual address will be add Year with bellow codes, it have to be set for different subfolders
DGFolder = "d:\Suppliers" ' ###Target folder address, it has to be set for different subfolders
SCFolder = "\20-Audits\" ' ###Target subfolder, it has to be set for target subfolders
aa=0
'On error resume Next
'------------------ Define the Shortcut function, Log function, and Shortcut checking function
Function FilesTree(Path1,Depth) 'Path1 is the folder which need to be checked,Depth is folder level.
Dim wshShell, Shortcut, strDir, strName, SFolders
'Traverse all folders with Depth folder level
Set wshShell = WSH.CreateObject("WScript.Shell")
Set oFso = CreateObject("Scripting.FileSystemObject")
Set SFolderGet=CreateObject("Scripting.FileSystemObject")
Set Fs=CreateObject("Scripting.FileSystemObject")
Set oFolder = oFso.GetFolder(Path1)
Set SFoldersO = SFolderGet.GetFolder(ShutCutAdd)
For each SFoldersname In SFoldersO.SubFolders 'Check year folders circle to sure if need create the year folder
SFolders=SFoldersname.Name
if Depth > 0 then
For Each oSubFolder In oFolder.SubFolders
FilesTree oSubFolder.Path, Depth -1
If (Fs.folderexists(oSubFolder.Path&SCFolder&SFolders)) then 'Check if the year folder is exist alreay
If not (Fs.folderexists(ShutCutAdd&SFolders)) then set foldr=fs.createfolder(ShutCutAdd&SFolders) 'Check the target folder exist or not, Create it if not
'Generate the shortcut
strDir = ShutCutAdd&SFolders ' Define the folder for store the shortcuts set
strName = oSubFolder.Name ' Define the shortcuts name
'Check if the shortcut exist and has Read Only attribute, if yes, remove the attribute
If (Fs.fileexists(strDir & "\" & strName & ".lnk")) then
Set ShortCheck = Fs.getfile(strDir & "\" & strName & ".lnk")
If ShortCheck.Attributes <> 0 then ShortCheck.Attributes = 0
end if
Set Shortcut = wshShell.CreateShortcut(strDir & "\" & strName & ".lnk") 'Generate shortcut
Shortcut.TargetPath = oSubFolder.Path&SCFolder&SFolders 'setup the target folder address
Shortcut.WindowStyle = 1
'Shortcut.Hotkey = "CTRL+ALT+U"
'Shortcut.Description = "This shortcut was created automatically by VBS"
Shortcut.WorkingDirectory = oSubFolder.Path&SCFolder 'Set Start In folder
Shortcut.Save 'Save the shortcut now
End If
Next
End if
Next
'Clear all define
Set WriteLog = Nothing
Set Shortcut = Nothing
Set wshShell = Nothing
Set oFolder = Nothing
Set oFso = Nothing
Set strDir = Nothing
Set strName = Nothing
Set SFolders = Nothing
End Function
'Write content to a txt file
Function WriteLogFile(strFileName, strContent) ' strFileName mean the log address, et."D:\Suppliers\00AUTOSET\AUTOSET.log", strContent mean the content.
'WiteNewFile = Flase '''''''' default return value of function
Set ObjLog = CreateObject("scripting.FileSystemObject")
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Set objLogWrite =ObjLog.OpenTextFile(strFileName,ForAppending,True,TristateFalse)
objLogWrite.WriteLine strContent
objLogWrite.Close
Set ObjLog = Nothing
Set objLogWrite = Nothing
End Function
Function CheckLink(LinkFolder)
Set LinkWsh = WSH.CreateObject("WScript.Shell")
Set LinkFs = CreateObject("Scripting.FileSystemObject")
Set LinkFoldr = LinkFs.GetFolder(LinkFolder)
Set Linksubfoldrs = LinkFoldr.SubFolders
Set LinkFiles = LinkFoldr.Files
For Each oFile In LinkFiles
aa=aa+1
if Right(LCase(oFile.Path),4)=".lnk" then
'WScript.Echo oFile.Path
Set Chlnk = LinkWsh.CreateShortcut(oFile.Path)
Lnkaddss = ChLnk.TargetPath
'WScript.Echo ChLnk.TargetPath
If not (LinkFs.folderExists(ChLnk.TargetPath)) then oFile.Delete
End If
Next
For Each oSubFolder In Linksubfoldrs
'WScript.Echo oSubFolder.Path
CheckLink(oSubFolder.Path)
Next
Set LinkWsh = Nothing
Set LinkFs = Nothing
Set LinkFoldr = Nothing
Set Linksubfoldrs = Nothing
Set LinkFiles = Nothing
End Function
'----------------------Start run the functions
CheckLink (ShutCutAdd) 'Check the exist shortcut if it is available, or delete it.
FilesTree (DGFolder),1 'Create shortcut set.
WScript.Echo aa
' Due to the WriteLogFile function will be invalid if meet any error, So have to use full code to log the error here.
If ERR.Number <> 0 Then
Set ObjErr = CreateObject("scripting.FileSystemObject")
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Set objErrWrite =ObjErr.OpenTextFile(LogAddress,ForAppending,True,TristateFalse) ' Save error log
objErrWrite.WriteLine Date&" | "& Time &" | "& ERR.Number &" | "& ERR.Description
objErrWrite.Close
Set ObjErr = Nothing
Set objErrWrite= Nothing
Else
WriteLogFile LogAddress, Date&" | "&Time&" | Generate shortcuts set into "& ShutCutAdd &" for subfolders "&SCFolder&" from "&DGFolder&" | OK ;-)" ' Save normal log
End If
'Clear define
Set LogAddress = Nothing
Set ShutCutAdd = Nothing
Set DGFolder = Nothing
Set SCFolder = Nothing
On Error GoTo 0
转载于:https://blog.51cto.com/ybsking/931235