Pin and unpin programs on startmenu windows 7

Microsoft Office professional 2010 softw...
July 16, 2011 at 02:19:38
Specs: Windows 7 pro, 2G
Hi

Found this vbs script on the internet but can only do half of what I wanted since I am not a programmer maybe some-one could help me and create a script to remove all pin programs from the existing start menu and pin programs back on with Windows 7

The script below when run it will delete all pin programs and the next script I modified it which will pin programs back on, but when I run the first script again it doesn't remove them.

I just need a vbscript so when my users login to the domain it will delete all pin programs and have another script to pin different programs on it.

Thanks

Vbs script to unpin all:

'==========================================================================
'
' VBScript Source File -- Created with SAPIEN Technologies PrimalScript 2009
'
' NAME: Pin & Unpin items to/from Start Menu & Taskabar
'
' AUTHOR: JuliusPIV
' DATE : 4/8/2010
'
' COMMENT:
'
'==========================================================================

Dim sPath, sPinSMArray, sPinTBArray, sUnpinTBArray, PinItem
Dim sMOW, sMOO, sFOX, sLN, sNuance, siMAN, sEXP, sWMP
Const CSIDL_COMMON_PROGRAMS = &H17
Const CSIDL_PROGRAMS = &H2

Set fso = CreateObject("Scripting.FileSystemObject")
Set oShell = CreateObject("Shell.Application")
Set wshshell = CreateObject("WScript.Shell")
Set oAllUsersProgramsFolder = oShell.NameSpace(CSIDL_COMMON_PROGRAMS)

sPath = oAllUsersProgramsFolder.Self.Path & "\"
sMOW = "Microsoft Office Word 2007.lnk"
sMOO = "Microsoft Office Outlook 2007.lnk"
sFOX = "Mozilla Firefox.lnk"
sLN = "Notes.lnk"
sNuance = "Nuance PDF Professional 6\PDF Converter Professional.lnk"
siMAN = "iManage.lnk"
sEXP = wshshell.ExpandEnvironmentStrings("%WinDir%") & "\Explorer.exe"
sWMP = wshshell.ExpandEnvironmentStrings("%ProgramFiles%") & "\Windows Media Player\wmplayer.exe"

sPinSMArray = Array(sLN,sFOX,sMOO,sMOW,sNuance)
sPinTBArray = Array(sMOO,sMOW,sFOX)
sUnpinTBArray = Array(sEXP,sWMP)

dim strScriptHost, output_echo
strScriptHost = LCase(Wscript.FullName)
If Right(strScriptHost, 11) = "wscript.exe" Then
output_echo = False
Else
output_echo = True
End If

'Clearing out useless Start Menu icons
EnumKeys "HKCU","Software\Microsoft\Windows\CurrentVersion\Explorer\UserAssist"

WScript.Sleep(5000)

Dim item
For Each item In sPinSMArray
If Not fso.FileExists(sPath & item) Then
PinItem = False
debugecho "File, " & item & ", to pin does not exist in " & sPath & "."
debugecho "Please check the input and try again."
'WScript.quit
Else
PinSM(sPath & item)
End If
Next

For Each item In sPinTBArray
If Not fso.FileExists(sPath & item) Then
PinItem = False
debugecho "File, " & item & ", to pin does not exist in " & sPath & "."
debugecho "Please check the input and try again."
'WScript.quit
Else
PinTB(sPath & item)
End If
Next

For Each item In sUnpinTBArray
If Not fso.FileExists(item) Then
PinItem = False
debugecho "File, " & item & ", to unpin does not exist in " & sPath & "."
debugecho "Please check the input and try again."
'WScript.quit
Else
UnpinTB(item)
End If
Next


WScript.quit

Function PinSM(shortcut)
On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
Set oShell = CreateObject("Shell.Application")

sFolder = fso.GetParentFolderName(shortcut)
sFile = fso.GetFileName(shortcut)

debugecho "Pinning " & sFolder & "\" & sFile & " to Start Menu."
Err.Clear

Set oFolder = oShell.NameSpace(sFolder)
Set oFolderItem = oFolder.ParseName(sFile)
Set colVerbs = oFolderItem.Verbs

For Each itemverb In oFolderItem.Verbs
If Replace(itemverb.name, "&", "") = "Pin to Start Menu" Then itemverb.DoIt
Next
On Error GoTo 0
End Function

Function PinTB(shortcut)
On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
Set oShell = CreateObject("Shell.Application")

sFolder = fso.GetParentFolderName(shortcut)
sFile = fso.GetFileName(shortcut)

debugecho "Pinning " & sFolder & "\" & sFile & " to Taskbar."
Err.Clear

Set oFolder = oShell.NameSpace(sFolder)
Set oFolderItem = oFolder.ParseName(sFile)
Set colVerbs = oFolderItem.Verbs

For Each itemverb In oFolderItem.Verbs
If Replace(itemverb.name, "&", "") = "Pin to Taskbar" Then itemverb.DoIt
Next
On Error GoTo 0
End Function

Function UnpinTB(shortcut)
On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
Set oShell = CreateObject("Shell.Application")

sFolder = fso.GetParentFolderName(shortcut)
sFile = fso.GetFileName(shortcut)

debugecho "Unpinning " & sFolder & "\" & sFile & " from Taskbar."
Err.Clear

Set oFolder = oShell.NameSpace(sFolder)
Set oFolderItem = oFolder.ParseName(sFile)
Set colVerbs = oFolderItem.Verbs

For Each itemverb In oFolderItem.Verbs
If Replace(itemverb.name, "&", "") = "Unpin from Taskbar" Then itemverb.DoIt
Next
On Error GoTo 0
End Function

Function debugecho(msg)
if output_echo Then
wscript.echo msg
end if
end Function

Function EnumKeys(HKEY,Path)
Dim EKHKPath, GUIDPath, arrSubKeys, i
Select Case HKEY
Case "HKCU", "HKEY_CURRENT_USER"
Const HKCU = &H80000001
EKHKPath = HKCU
Case "HKLM", "HKEY_LOCAL_MACHINE"
Const HKLM = &H80000002
EKHKPath = HKLM
Case "HKU", "HKEY_USERS"
Const HKU = &H80000003
EKHKPath = HKU
Case "HKCR", "HKEY_CLASSES_ROOT"
Const HKCR = &H80000000
EKHKPath = HKCR
Case "HKCC", "HKEY_CURRENT_CONFIG"
Const HKCC = &H80000005
EKHKPath = HKCC
Case "HKDD", "HKEY_DYN_DAT"
Const HKDD = &H80000006
EKHKPath = HKDD
Case Else
WScript.Echo "ERROR: Invalid HKEY Type Specified (" & EKHKPath & ")"
WScript.echo "Please use HKCU, HKLM etc, or the long name equivalent."
WScript.Sleep(15000)
WScript.Quit
End Select

Set objReg=GetObject("winmgmts:\\.\root\default:StdRegProv")
objReg.EnumKey EKHKPath, Path, arrSubKeys

if isarray(arrSubKeys) Then
For i=0 to UBound(arrSubKeys)
GUIDPath = Path & "\" & arrSubKeys(i) & "\Count"
'WScript.Echo "GuidPath: " & GUIDPath
EnumValues HKEY,GUIDPath

Next
end If

End Function

Function EnumValues(HKEY,Path)
Dim EVHKPath, arrValueNames, arrValueTypes, i

const REG_SZ = 1
const REG_EXPAND_SZ = 2
Const REG_BINARY = 3
Const REG_DWORD = 4
Const REG_MULTI_SZ = 7

Select Case HKEY
Case "HKCU", "HKEY_CURRENT_USER"
Const HKCU = &H80000001
EVHKPath = HKCU
Case "HKLM", "HKEY_LOCAL_MACHINE"
Const HKLM = &H80000002
EVHKPath = HKLM
Case "HKU", "HKEY_USERS"
Const HKU = &H80000003
EVHKPath = HKU
Case "HKCR", "HKEY_CLASSES_ROOT"
Const HKCR = &H80000000
EVHKPath = HKCR
Case "HKCC", "HKEY_CURRENT_CONFIG"
Const HKCC = &H80000005
EVHKPath = HKCC
Case "HKDD", "HKEY_DYN_DAT"
Const HKDD = &H80000006
EVHKPath = HKDD
Case Else
WScript.Echo "ERROR: Invalid HKEY Type Specified (" & EVHKPath & ")"
WScript.echo "Please use HKCU or the long name equivalent, HKEY_LOCAL_MACHINE."
WScript.Sleep(15000)
WScript.Quit
End Select

Set oReg=GetObject("winmgmts:\\.\root\default:StdRegProv")
oReg.EnumValues EVHKPath, Path, arrValueNames, arrValueTypes

if isarray(arrValueNames) Then
For i=0 to UBound(arrValueNames)
'WScript.Echo "Unencrypted Value Name: " & arrValueNames(i)
arrValueNames(i) = Rot13Fixer(arrValueNames(i))
'WScript.Echo "Value Name: " & arrValueNames(i)
' #region Disabled code
' Select Case arrValueTypes(i)
' Case REG_SZ
' WScript.Echo "Data Type: String"
' Case REG_EXPAND_SZ
' WScript.Echo "Data Type: Expanded String"
' Case REG_BINARY
' WScript.Echo "Data Type: Binary"
' Case REG_DWORD
' WScript.Echo "Data Type: DWORD"
' Case REG_MULTI_SZ
' WScript.Echo "Data Type: Multi String"
' End Select
' #endregion
'WScript.Echo "this: " & HKEY & " " & Path & " " & arrValueNames(i)
FixStartMenu HKEY, Path, arrValueNames(i)
Next
End If
End Function

Function Rot13Fixer(sString)
Dim n, i, StringROT
For i=1 To Len(sString)
If Not IsNumeric(Mid(sString,i,1)) Then
individual_asc = Asc(Mid(sString,i,1))
'WScript.Echo "IASC: " & Chr(individual_asc) & " (" & individual_asc & ")"
If individual_asc >= 97 And individual_asc <=109 Then
individual_asc = individual_asc +13
'WScript.Echo "IASC+13.1: " & Chr(individual_asc) & " (" & individual_asc & ")"
Else
If individual_asc >= 110 And individual_asc <= 122 Then
individual_asc = individual_asc -13
'WScript.Echo "IASC-13.1: " & Chr(individual_asc) & " (" & individual_asc & ")"
Else
If individual_asc >= 65 And individual_asc <= 77 Then
individual_asc = individual_asc +13
'WScript.Echo "IASC+13.2: " & Chr(individual_asc) & " (" & individual_asc & ")"
Else
If individual_asc >= 78 And individual_asc <= 90 Then
individual_asc = individual_asc -13
'WScript.Echo "IASC-13.2: " & Chr(individual_asc) & " (" & individual_asc & ")"
End If
End If
End If
End If
StringROT = StringROT + Chr(individual_asc)
Else StringROT = StringROT + Mid(sString,i,1)
End If
'WScript.Echo StringROT
Next
Rot13Fixer = StringROT
End Function

Function FixStartMenu(HKEY, Path, ValueName)
Dim FSMPath, encValueName, arrDeleteApps
Select Case HKEY
Case "HKCU", "HKEY_CURRENT_USER"
Const HKCU = &H80000001
FSMPath = HKCU
Case "HKLM", "HKEY_LOCAL_MACHINE"
Const HKLM = &H80000002
FSMPath = HKLM
Case "HKU", "HKEY_USERS"
Const HKU = &H80000003
FSMPath = HKU
Case "HKCR", "HKEY_CLASSES_ROOT"
Const HKCR = &H80000000
FSMPath = HKCR
Case "HKCC", "HKEY_CURRENT_CONFIG"
Const HKCC = &H80000005
FSMPath = HKCC
Case "HKDD", "HKEY_DYN_DAT"
Const HKDD = &H80000006
FSMPath = HKDD
Case Else
WScript.Echo "ERROR: Invalid HKEY Type Specified (" & EVHKPath & ")"
WScript.echo "Please use HKCU or the long name equivalent, HKEY_LOCAL_MACHINE."
WScript.Sleep(15000)
WScript.Quit
End Select

arrDeleteApps = Array("microsoft.windows.gettingstarted","displayswitch.exe","microsoft.windows.remotedesktop","microsoft.windows.stickynotes","snippingtool.exe" &_
"calc.exe","mspaint.exe","xpsrchvw.exe","wfs.exe","magnify.exe","welcome center.lnk","displayswitch.lnk","remote desktop connection.lnk","sticky notes.lnk" &_
"snipping tool.lnk","calculator.lnk","paint.lnk","xps viewer.lnk","windows fax and scan.lnk","magnify.lnk")

For i=0 To UBound(arrDeleteApps)
If (instr(1,lcase(ValueName), lcase(deleteapps),1) > 0) Then
'WScript.Echo "hit"
encValueName = Rot13Fixer(ValueName)
Set oReg=GetObject("winmgmts:\\.\root\default:StdRegProv")
oReg.DeleteValue HKCU,Path,encValueName
End If
Next

End Function


Vbs script to pin programs to start menu

Const CSIDL_COMMON_PROGRAMS = &H17
Const CSIDL_PROGRAMS = &H2

'Pin to Start Menu - google earth
Set objShell = CreateObject("Shell.Application")
Set objAllUsersProgramsFolder = objShell.NameSpace(CSIDL_COMMON_PROGRAMS)
strAllUsersProgramsPath = objAllUsersProgramsFolder.Self.Path
Set objFolder = objShell.Namespace(strAllUsersProgramsPath & "\MS office 2010")
Set objFolderItem = objFolder.ParseName("MS word 2010.lnk")
Set colVerbs = objFolderItem.Verbs
For Each objVerb in colVerbs
If Replace(objVerb.name, "&", "") = "Pin to Start Menu" Then objVerb.DoIt
Next

'Pin to Start Menu - Notepad
Set objFolder = objShell.Namespace("C:\windows\system32")
Set objFolderItem = objFolder.ParseName("notepad.exe")
Set colVerbs = objFolderItem.Verbs
For Each objVerb in colVerbs
If Replace(objVerb.name, "&", "") = "Pin to Start Menu" Then objVerb.DoIt
Next

'Pin to Start Menu - calculator
Set objFolder = objShell.Namespace(strAllUsersProgramsPath & "\Accessories")
Set objFolderItem = objFolder.ParseName("calculator.lnk")
Set colVerbs = objFolderItem.Verbs
For Each objVerb in colVerbs
If Replace(objVerb.name, "&", "") = "Pin to Start Menu" Then objVerb.DoIt
Next


(Not sure how to pin folders to the start menu)

Thanks again



See More: Pin and unpin programs on startmenu windows 7

Report •

#1
July 18, 2011 at 07:28:18
Make a default profile instead, but if some-one can remove all pin program and insert and delete them with a vbs script let me know thanks

Report •
Related Solutions


Ask Question