Windows 7: Shared Start Menus and Desktops

[danbee]

I wonder if anyone can help with this...

 

We are looking to have a kind of shortcut bank situation in Windows 7 where students and staff have redirected start menus and desktops. But how can you stop shortcuts appearing for programs which aren't installed on that particular device?

[peterp]

We have the following as a logon script.

It will populate their startmenu from a share on the server \\deploymentserver\deploy$\startmenu

In there place yoru shortcuts. You can set user security to only deploy them to the correct groups.

They will also only deploy if the shortcut can be resolved (i.e. it is installed on the computer)

 

It also pins the Internet Explorer and Outlook icons to the start menu, and hides the My Settings folder in their My Documents (re-directed as the N:\ drive on our system)

 

You may need to taylor this to your own.

 

 

'Copy Server start menu to local if available

Set oFSO = CreateObject("Scripting.FileSystemObject")

Set oShell = CreateObject("Wscript.Shell")

strServerStartMenu = "\\deplomentServer\deploy$\StartMenu\"

 

If oFSO.FileExists("\\svr-deploy1\deploy$\aup.txt") Then

strUserProfile = oShell.ExpandEnvironmentStrings("%USERPROFILE%")

strLocalStartMenu = strUserProfile + "\AppData\Roaming\Microsoft\Windows\Start Menu\Programs"

if oFSO.folderexists (strServerStartMenu) then

if oFSO.folderexists(strLocalStartMenu) Then

On Error Resume Next

oFSO.DeleteFolder strLocalStartMenu, true

end if

 

oFSO.createfolder(strLocalStartMenu)

Call CopyFolderRecursively(strServerStartMenu, strLocalStartMenu)

Call RemoveEmptyFolders(strLocalStartMenu)

Call Pin()

Call HideSettingsFolder()

End if

Else

'WScript.Echo "Not connected to domain"

End if

 

Sub HideSettingsFolder()

Set objFSO = CreateObject("Scripting.FileSystemObject")

if objFSO.Folderexists("N:\My Settings") then

Set objFolder = objFSO.GetFolder("N:\My Settings")

If objFolder.Attributes = objFolder.Attributes AND 2 Then

objFolder.Attributes = objFolder.Attributes XOR 2

End If

End If

end sub

 

Sub CopyFolderRecursively(strSrcPath, strDestPath)

On Error Resume Next

Set objCurrentFolder = oFSO.GetFolder(strSrcPath)

 

'moved from inside loop

If Not oFSO.FolderExists(strDestPath) Then

oFSO.CreateFolder(strDestPath)

end if

 

For Each objFile In objCurrentFolder.Files

' Create new folder if it's not there

on error resume next

strDestFile = strDestPath & "\" & objFile.Name

if CheckValidShortcut(objFile) Then

oFSO.CopyFile objFile, strDestFile

end if

err.clear

Next

 

For Each objFolder In objCurrentFolder.subFolders

Call CopyFolderRecursively(objFolder, strDestPath & "\" & objFolder.Name)

Next

End Sub

 

Sub RemoveEmptyFolders(strPath)

Set objCurrentFolder = oFSO.GetFolder(strPath)

For Each objFolder in ObjCurrentFolder.SubFolders

On Error Resume Next

if not FolderEmpty(objFolder) then

RemoveEmptyFolders(strPath & "\" & objFolder.Name)

else

oFSO.deleteFolder strpath & "\" & objFolder.name, true

end if

next

End Sub

 

Function CheckValidShortcut(objCheckFile)

If LCase(oFSO.GetExtensionName(objCheckFile.name)) = "lnk" Then

Set oLnk = oShell.CreateShortcut(objCheckFile.path)

If oFSO.FileExists(oLnk.TargetPath) Then

CheckValidShortcut = true

Else

CheckValidShortcut = False

End If

End If

End Function

 

Function FolderEmpty(strFolderPathName)

Dim oFiles, oFile, oFolder, oSubFolders, oSubFolder

Set oFolder = oFSO.GetFolder(strFolderPathName)

Set oFiles = oFolder.Files

Set oSubFolders = oFolder.SubFolders

if oSubFolders.Count > 0 then

FolderEmpty = False

exit Function

end if

 

If oFiles.Count > 0 Then

FolderEmpty = False

Exit Function

End If

FolderEmpty = True

End Function

 

Sub Pin()

on error resume next

'Process Start Menu Pinned Items

Const CSIDL_COMMON_PROGRAMS = &H17

Const CSIDL_PROGRAMS = &H2

Set objShell = CreateObject("Shell.Application")

'Set objWShell = CreateObject("WScript.Shell")

 

sRegKey = "HKCU\Software\Ashby"

favKey = "HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\StartPage2\Favorites"

 

On Error Resume Next

 

pinnedSM = oShell.RegRead(sRegKey & "\PinningRan")

 

'check for marker so we don't run this part if it has already been run

If pinnedSM <> "woot" Then

set filesys = CreateObject("Scripting.FileSystemObject")

strUProfile = oShell.ExpandEnvironmentStrings("%USERPROFILE%")

strStartMenuPinFiles = strUserProfile + "\AppData\Roaming\Microsoft\Internet Explorer\Quick Launch\User Pinned\StartMenu\"

strStartMenuPinFilesLocal = "N:\My Settings\Application Data\Microsoft\Internet Explorer\Quick Launch\User Pinned\StartMenu\"

filesys.DeleteFile strStartMenuPinFilesLocal + "*.lnk"

oshell.regwrite favKey, 255, "REG_BINARY"

 

if error <> 0 then

wscript.echo "Error " & error

end if

 

oShell.RegWrite sRegKey & "\PinnedInternet", "no"

oShell.RegWrite sRegKey & "\PinnedEmail", "no"

 

WScript.Sleep(2000)

 

Set objAllUsersProgramsFolder = objShell.NameSpace(CSIDL_COMMON_PROGRAMS)

strAllUsersProgramsPath = objAllUsersProgramsFolder.Self.Path

Set objFolder = objShell.Namespace(strAllUsersProgramsPath & "\Ashby School")

 

Set objFolderItem = objFolder.ParseName("Internet.lnk")

Set colVerbs = objFolderItem.Verbs

For Each objVerb in colVerbs

If Replace(objVerb.name, "&", "") = "Pin to Start Menu" Then

objVerb.DoIt

oShell.RegWrite sRegKey & "\PinnedInternet", "yes"

end if

Next

 

WScript.Sleep(2000)

 

Set objFolderItem = objFolder.ParseName("E-Mail.lnk")

Set colVerbs = objFolderItem.Verbs

For Each objVerb in colVerbs

If Replace(objVerb.name, "&", "") = "Pin to Start Menu" Then

objVerb.DoIt

oShell.RegWrite sRegKey & "\PinnedEmail", "yes"

end if

Next

 

 

'create the marker

oShell.RegWrite sRegKey & "\PinningRan", "yes"

End if

set objShell = Nothing

End Sub