BvSiT

Comment épingler une icône Flip 3D à la barre des taches Windows 7 par VBScript.

Dans le cas d'un réseau avec des client Windows 7 il peut être utile de contrôler l’apparence du bureau des ordinateurs clients quand l’utilisateur se connecte pour la première fois. Une des actions possibles est d’ajouter les éléments épinglés qui apparaissent sur la barre des taches Windows 7.

Le point essentiel de ce script réside dans la manière dont le raccourci vers Flip 3D est crée. Comme il est précisé dans le Technet forum on peut y arriver en créant un raccourci vers rundll32.exe DwmApi #105.

Dès lors que l’on est sur que ce raccourci existe on peut l’épingler sur la barre des taches. Ceci est effectué par une méthode assez particulière. Chaque objet FolderItem a une propriété collection appelée .Verbs. Elle représente en fait les raccourcis on peut cliquer dessus dans le menu contextuel  (ou RightClick menu). On peut exécuter une commande dans ce menu en utilisant la méthode .DoIt de l’objet Verb correspondant. Le script est assuré de n’être exécuter qu’une seule fois par la création d’un fichier de control. Une fois le script exécuté l’utilisateur devrait être capable de décider quels éléments il veut voir apparaître sur la barre des taches. C'est la raison pour laquelle on ne veut pas que le script soit exécuté à chaque fois que l’on se connecte.

Evidemment on peut ajouter plusieurs items sur la barre des taches par cette méthode. Si vous souhaitez contrôler l’ordre dans lequel les items sont presenté il faut commencer par supprimer d'abord tous les items et puis les remplacez dans l’ordre désiré. 

Option Explicit

Const CSIDL_COMMON_PROGRAMS = &H17
Const CSIDL_PROGRAMS = &H2
Const CSIDL_STARTMENU = &HB
'Const sUnpinFromTaskBar=""Unpin from Taskbar"
Const sUnpinFromTaskBar="Van de taakbalk losmaken"  
    'this should be the exact verb in the context menu in the language of your Windows 7 version, so
    'in this case Dutch
Const sPinToTaskBar="Aan de taakbalk vastmaken"
'If OK file is present in %USERPROFILE% do not execute to control one-time execution for a certain
'user on this machine
Const sOKFile="PinnedItems15-12-11.ok" 
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Const bDebug = False

Dim oShell, oFSO
Dim oCurrentUserStartFolder
Dim sCurrentUserStartFolderPath
Dim oAllUsersProgramsFolder
Dim sAllUsersProgramsPath
Dim oFolder
Dim oFolderItem
Dim colVerbs
Dim oVerb
Dim Msg,f
Dim sPathOKFile  
Dim oWshShell

If bDebug = True Then MsgBox OSVersion

If Not Instr(1,OSVersion,"Windows 7",1)>0 Then WScript.Quit

Set oShell = CreateObject("Shell.Application")
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oCurrentUserStartFolder = oShell.NameSpace (CSIDL_STARTMENU)
sCurrentUserStartFolderPath = oCurrentUserStartFolder.Self.Path
Set oAllUsersProgramsFolder = oShell.NameSpace(CSIDL_COMMON_PROGRAMS)
sAllUsersProgramsPath = oAllUsersProgramsFolder.Self.Path

Set oWshShell = WScript.CreateObject ("WSCript.shell")

sPathOKFile= oWshShell.ExpandEnvironmentStrings("%USERPROFILE%") & "\" & sOKFile

'If OK file exists end execution
If oFSO.FileExists(sPathOKFile) Then
    If bDebug Then
        MsgBox "Execution aborted because OK file is present as: " & sPathOKFile,,"28" 
    Else
        WScript.Quit
    End If
End If

' - Remove pinned items -

'Remove items IE en Media Player from taskbar if present and add again to control the order in which
'they appear on the taskbar.

'Internet Explorer
If oFSO.FileExists(sCurrentUserStartFolderPath & "\Programs\Internet Explorer.lnk") Then
    Set oFolder = oShell.Namespace(sCurrentUserStartFolderPath & "\Programs")
    Set oFolderItem = oFolder.ParseName("Internet Explorer.lnk")
    Set colVerbs = oFolderItem.Verbs
	For Each oVerb in colVerbs
		If bDebug Then
			Msg = Msg & vbCrLf & oVerb.name
		End If
        If Replace(oVerb.name, "&", "") =  sUnpinFromTaskBar Then
			oVerb.DoIt
			If bDebug = False Then Exit For
		End If
	Next
	If bDebug Then MsgBox Msg
End If

'Windows Media Player
If oFSO.FileExists(sAllUsersProgramsPath & "\Windows Media Player.lnk") Then
    Set oFolder = oShell.Namespace(sAllUsersProgramsPath)
    Set oFolderItem = oFolder.ParseName("Windows Media Player.lnk")
    Set colVerbs = oFolderItem.Verbs
	For Each oVerb in colVerbs
		If bDebug Then
			Msg = Msg & vbCrLf & oVerb.name
		End If
        If Replace(oVerb.name, "&", "") =  sUnpinFromTaskBar Then
			oVerb.DoIt
			If bDebug = False Then Exit For
		End If
	Next
	If bDebug Then MsgBox Msg
End If

' - Pin to Taskbar -

'Microsoft Outlook 2007

If oFSO.FileExists(sAllUsersProgramsPath & "\Microsoft Office\Microsoft Office Outlook 2007.lnk") _
                                                                                                Then
	Set oFolder = oShell.Namespace(sAllUsersProgramsPath & "\Microsoft Office")
 'Microsoft Office Outlook 2007
	Set oFolderItem = oFolder.ParseName("Microsoft Office Outlook 2007.lnk")  
	Set colVerbs = oFolderItem.Verbs
	For Each oVerb in colVerbs
		If bDebug Then
			Msg = Msg & vbCrLf & oVerb.name
		End If
        If Replace(oVerb.name, "&", "") =  sPinToTaskBar Then
			oVerb.DoIt
			If bDebug = False Then Exit For
		End If
	Next
	If bDebug Then MsgBox Msg
End If

'Microsoft Word 2007

If oFSO.FileExists(sAllUsersProgramsPath & "\Microsoft Office\Microsoft Office Word 2007.lnk") Then
	Set oFolder = oShell.Namespace(sAllUsersProgramsPath & "\Microsoft Office")
	Set oFolderItem = oFolder.ParseName("Microsoft Office Word 2007.lnk")
	Set colVerbs = oFolderItem.Verbs
	For Each oVerb in colVerbs
		If bDebug Then
			Msg = Msg & vbCrLf & oVerb.name
		End If
        If Replace(oVerb.name, "&", "") =  sPinToTaskBar Then
			oVerb.DoIt
			If bDebug = False Then Exit For
		End If
	Next
	If bDebug Then MsgBox Msg
End If

'Windows Explorer
If oFSO.FileExists(sCurrentUserStartFolderPath & "\Programs\Accessories\Windows Explorer.lnk") Then
    Set oFolder = oShell.Namespace(sCurrentUserStartFolderPath & "\Programs\Accessories")
    Set oFolderItem = oFolder.ParseName("Windows Explorer.lnk")
    Set colVerbs = oFolderItem.Verbs
	For Each oVerb in colVerbs
		If bDebug Then
			Msg = Msg & vbCrLf & oVerb.name
		End If
        If Replace(oVerb.name, "&", "") =  sPinToTaskBar Then
			oVerb.DoIt
			If bDebug = False Then Exit For
		End If
	Next
	If bDebug Then MsgBox Msg
End If

'Internet Explorer
If oFSO.FileExists(sCurrentUserStartFolderPath & "\Programs\Internet Explorer.lnk") Then
    Set oFolder = oShell.Namespace(sCurrentUserStartFolderPath & "\Programs")
    Set oFolderItem = oFolder.ParseName("Internet Explorer.lnk")
    Set colVerbs = oFolderItem.Verbs
	For Each oVerb in colVerbs
		If bDebug Then
			Msg = Msg & vbCrLf & oVerb.name
		End If
        If Replace(oVerb.name, "&", "") =  sPinToTaskBar Then
			oVerb.DoIt
			If bDebug = False Then Exit For
		End If
	Next
	If bDebug Then MsgBox Msg
End If

'Windows Media Player
If oFSO.FileExists(sAllUsersProgramsPath & "\Windows Media Player.lnk") Then
    Set oFolder = oShell.Namespace(sAllUsersProgramsPath)
    Set oFolderItem = oFolder.ParseName("Windows Media Player.lnk")
    Set colVerbs = oFolderItem.Verbs
	For Each oVerb in colVerbs
		If bDebug Then
			Msg = Msg & vbCrLf & oVerb.name
		End If
        If Replace(oVerb.name, "&", "") =  sPinToTaskBar Then
			oVerb.DoIt
			If bDebug = False Then Exit For
		End If
	Next
	If bDebug Then MsgBox Msg
End If

'Create shortcut Flip to 3D and pin to taskbar

Create_ShortCut "%SystemRoot%\System32\rundll32.exe" , "DwmApi #105" ,sCurrentUserStartFolderPath, _
                                               "Flip 3D","",0,"%SystemRoot%\System32\imageres.dll",0

If oFSO.FileExists(sCurrentUserStartFolderPath & "\Flip 3D.lnk") Then
	Set oFolder = oShell.Namespace(sCurrentUserStartFolderPath)
	Set oFolderItem = oFolder.ParseName("Flip 3D.lnk")	
	Set colVerbs = oFolderItem.Verbs
	For Each oVerb in colVerbs
		If bDebug Then
			Msg = Msg & vbCrLf & oVerb.name
		End If
        If Replace(oVerb.name, "&", "") =  sPinToTaskBar Then
			oVerb.DoIt
			If bDebug = False Then Exit For
		End If
	Next
	If bDebug Then MsgBox Msg
End If	

'Create OK file for one-time execution

WriteToLog "",oWshShell.ExpandEnvironmentStrings("%USERPROFILE%") & "\" & sOKFile

WScript.Quit

'Microsoft Outlook 2010
If oFSO.FileExists(sAllUsersProgramsPath & "\Microsoft Office\Microsoft Outlook 2010.lnk") Then
	Set oFolder = oShell.Namespace(sAllUsersProgramsPath & "\Microsoft Office")
	Set oFolderItem = oFolder.ParseName("Microsoft Outlook 2010.lnk")
	Set colVerbs = oFolderItem.Verbs
	For Each oVerb in colVerbs
		If Replace(oVerb.name, "&", "") = "Pin to Taskbar" Then oVerb.DoIt
	Next
End If


'Windows Explorer
If oFSO.FileExists(sCurrentUserStartFolderPath & "\Programs\Accessories\Windows Explorer.lnk") Then
	Set oFolder = oShell.Namespace(sCurrentUserStartFolderPath & "\Programs\Accessories")
	Set oFolderItem = oFolder.ParseName("Windows Explorer.lnk")
	Set colVerbs = oFolderItem.Verbs
	For Each oVerb in colVerbs
		If Replace(oVerb.name, "&", "") = "Pin to Taskbar" Then oVerb.DoIt
	Next
End If

'Internet Explorer
If oFSO.FileExists(sCurrentUserStartFolderPath & "\Programs\Internet Explorer.lnk") Then
    Set oFolder = oShell.Namespace(sCurrentUserStartFolderPath & "\Programs")
    Set oFolderItem = oFolder.ParseName("Internet Explorer.lnk")
    Set colVerbs = oFolderItem.Verbs
    For Each oVerb in colVerbs
        If Replace(oVerb.name, "&", "") = "Pin to Taskbar" Then oVerb.DoIt
    Next
End If

'Mozilla Firefox
If oFSO.FileExists(sAllUsersProgramsPath & "\Mozilla Firefox\Mozilla Firefox.lnk") Then
	Set oFolder = oShell.Namespace(sAllUsersProgramsPath & "\Mozilla Firefox")
	Set oFolderItem = oFolder.ParseName("Mozilla Firefox.lnk")
	Set colVerbs = oFolderItem.Verbs
	For Each oVerb in colVerbs
		If Replace(oVerb.name, "&", "") = "Pin to Taskbar" Then oVerb.DoIt
	Next
End If

'Microsoft Word 2010
If oFSO.FileExists(sAllUsersProgramsPath & "\Microsoft Office\Microsoft Word 2010.lnk") Then
	Set oFolder = oShell.Namespace(sAllUsersProgramsPath & "\Microsoft Office")
	Set oFolderItem = oFolder.ParseName("Microsoft Word 2010.lnk")
	Set colVerbs = oFolderItem.Verbs
	For Each oVerb in colVerbs
		If Replace(oVerb.name, "&", "") = "Pin to Taskbar" Then oVerb.DoIt
	Next
End If

'Microsoft Excel 2010
If oFSO.FileExists(sAllUsersProgramsPath & "\Microsoft Office\Microsoft Excel 2010.lnk") Then
	Set oFolder = oShell.Namespace(sAllUsersProgramsPath & "\Microsoft Office")
	Set oFolderItem = oFolder.ParseName("Microsoft Excel 2010.lnk")
	Set colVerbs = oFolderItem.Verbs
	For Each oVerb in colVerbs
		If Replace(oVerb.name, "&", "") = "Pin to Taskbar" Then oVerb.DoIt
	Next
End If

'Microsoft Outlook 2010
If oFSO.FileExists(sAllUsersProgramsPath & "\Microsoft Office\Microsoft Outlook 2010.lnk") Then
	Set oFolder = oShell.Namespace(sAllUsersProgramsPath & "\Microsoft Office")
	Set oFolderItem = oFolder.ParseName("Microsoft Outlook 2010.lnk")
	Set colVerbs = oFolderItem.Verbs
	For Each oVerb in colVerbs
		If Replace(oVerb.name, "&", "") = "Pin to Taskbar" Then oVerb.DoIt
	Next
End If

'Windows Media Player
If oFSO.FileExists(sAllUsersProgramsPath & "\Windows Media Player.lnk") Then
	Set oFolder = oShell.Namespace(sAllUsersProgramsPath)
	Set oFolderItem = oFolder.ParseName("Windows Media Player.lnk")
	Set colVerbs = oFolderItem.Verbs
	For Each oVerb in colVerbs
		If Replace(oVerb.name, "&", "") = "Pin to Taskbar" Then oVerb.DoIt
	Next
End If

'Delete the script
DeleteSelf

Sub DeleteSelf()
        Dim oFSO
        Set oFSO = CreateObject("Scripting.FileSystemObject")
        'Delete the currently executing script
        oFSO.DeleteFile WScript.ScriptFullName
        Set oFSO = Nothing
End Sub

Function OSVersion
	Dim sComputer,oWMIService,colOperatingSystems,oOperatingSystem
	sComputer = "."
	Set oWMIService = GetObject("winmgmts:" _
		& "{impersonationLevel=impersonate}!\\" & sComputer & "\root\cimv2")

	Set colOperatingSystems = oWMIService.ExecQuery _
		("Select * from Win32_OperatingSystem")

	For Each oOperatingSystem in colOperatingSystems
		'Wscript.Echo oOperatingSystem.Caption & " " & oOperatingSystem.Version
		OSVersion = oOperatingSystem.Caption & " " & oOperatingSystem.Version
	Next
End Function

Function WriteToLog(s,sPathLogFile)
	'log file
	Dim fso,tLog
	Dim sFolderPath
	Set fso = CreateObject("Scripting.FileSystemObject")
	sFolderPath = Left(sPathLogFile,InstrRev(sPathLogFile,"\",-1,1)-1)
	If Not fso.FolderExists(sFolderPath) Then fso.CreateFolder(sFolderPath)
	Set tLog = fso.OpenTextFile(sPathLogFile, 8, True) 'open for append = 8 ,True = file is created
	tLog.WriteLine(s)
	tLog.Close
End Function

Function Create_ShortCut(ByVal TargetPath, Arguments, _
		ByVal ShortCutPath,  ByVal sShortCutName, WorkPath, Window_Style, sIconFilePath, _
        																			IconNum)

	'http://www.vbforums.com/showthread.php?t=234891

	'The Window_Style is a integer,
	'Window_Style=3 means MaximizedWindows when run.
	'Window_Style=7 means MinimizedWindows when run.
	'Well, others means NormalWindows when run.
	'Default is 0.

	'The IconNum set our Shortcut's icon.
	'0 means the first icon in the target file.
	'1 the second ...
	'2 the third ...
	'and so on.
	'Default is 0.
	
	'Example: create shortcut in Start Menu to flip 3D:
	'Create_ShortCut "C:\Windows\System32\rundll32.exe" , "DwmApi #105" ,_
	'       sCurrentUserStartFolderPath,"Flip 3D","",0,"%SystemRoot%\System32\imageres.dll",0
		
	Dim oWshShell
	Dim MyShortcut
	
	Set oWshShell = CreateObject("WScript.Shell")

	If Right(sShortCutName,4) <> ".lnk" Then sShortCutName = sShortCutName & ".lnk"
	
	Set MyShortcut = oWshShell.CreateShortcut(ShortCutPath & "\" & sShortCutName)
	
	MyShortcut.TargetPath = TargetPath	
	MyShortcut.WorkingDirectory = WorkPath
	MyShortcut.WindowStyle = Window_Style
	MyShortcut.IconLocation = sIconFilePath & "," & IconNum
 ' e.g. 'DwmApi #105' as in: "C:\Windows\System32\rundll32.exe DwmApi #105" for Flip 3D
	MyShortcut.Arguments = Arguments    
	MyShortcut.Save
	
End Function