'Création d'une cible sur un dossier
'Script très fortement inspiré de ceux disponibles ici
'http://www.bellamyjc.net/fr/vbsdownload.html
'
' (c) Gilles RONSIN - 2004

Dim ShellApp, Shell, fso, args
Dim Msg, lnk, folderpath, foldername
Dim Key, temp

Set Shell = WScript.CreateObject("WScript.Shell")
Set Args = Wscript.Arguments

'Arrêt si pas Windows 2000 ni Windows XP
On Error Resume Next
Temp=Shell.RegRead ("HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\ProductName")
If Instr(temp,"XP")=0 And Instr(temp,"2000")=0 Then
        Msgbox "Désolé. Ce script ne fonctionne que sous Windows 2000 ou Windows XP"
        Set Shell=Nothing
        WScript.Quit
End If
On Error Goto 0
        
'Analyse des arguments fournis
If Args.Count=0 Then 
        msg = "Syntaxe : " & vbCrLf & _
              "TargetLnk.vbs <chemin_dossier>" & vbcrlf & vbcrlf & _
              "Si vous êtes administrateur vous pouvez modifier le" & Vbcrlf & _
              "menu contextuel des dossiers." & vbcrlf & vbcrlf & _
              "Voulez-vous "

        Key = "HKCR\Folder\Shell\Cible\"

        On Error Resume Next
        temp = Shell.RegRead( Key )
        
		  If Err.Number=0 then
          Msg = Msg & "désinscrire " & WScript.ScriptName & _
                " du menu contextuel des dossiers ?"
          If MsgBox(msg, VBYesNo, "Désinscription")=VBYes Then
                Shell.RegDelete Key & "command\"
                Shell.RegDelete Key
          End If
        else
          Msg = Msg & "inscrire " & WSCript.ScriptName & _
                " dans le menu contextuel des dossiers ?"
          If MsgBox(msg,VBYesNo,"Inscription")=VBYes Then
                Shell.RegWrite Key , "Créer cible vers...", "REG_SZ"
                Shell.RegWrite Key & "command\", "WScript """ & _
                        WScript.ScriptFullName & """ ""%1""", "REG_SZ"
          End If
        End If

        set Shell=Nothing
        WScript.Quit
else
	folderpath=args(0)
end if

Set fso = WScript.CreateObject("Scripting.FileSystemObject")
If not fso.FolderExists(folderpath) then
	msgbox """" & Folderpath & """ n'est pas un dossier existant",,"Erreur "
	set fso=Nothing
	wscript.quit
end if


Set ShellApp = WScript.CreateObject("Shell.Application")
'Sélection du dossier
On error resume next
Set Item=shellApp.BrowseForFolder(0,"Dossier où placer la cible du dossier """ & folderpath & """", &h0001 ,"")
Lnk=Item.ParentFolder.ParseName(Item.Title).Path

If Err.Number<>0 Then
        Lnk=Null
        If Item.Title="Bureau" Then  Lnk=shell.SpecialFolders("Desktop")
        I=Instr(Item.Title, ":")
        If I>0 Then Lnk=Mid(Item.Title,i-1,2) & "\"
End If
On error goto 0

'Extraction nom du dossier
For i=Len(folderpath) to 1 step -1
	If Mid(folderpath,i,1)="\" Then Exit For
Next
foldername=Mid(folderpath,i)

'Création nouveau dossier
Set oFolder=fso.CreateFolder (lnk & foldername)
oFolder.Attributes=4
Set oFolder=Nothing

'Création du raccourci target pointant sur la cible
Set oLink=Shell.CreateShortcut(lnk & foldername & "\target.lnk")
oLink.TargetPath=folderpath
oLink.Save
Set oLink=Nothing

'Création du desktop.ini
Set oTs=fso.CreateTextFile(lnk & foldername & "\desktop.ini")
oTs.WriteLine "[.ShellClassInfo]"
oTs.WriteLine "CLSID2={0AFACED1-E828-11D1-9187-B532F1E9575D}"
oTs.WriteLine "Flags=2"
oTs.WriteLine "ConfirmFileOp=0"
OTs.Close
Set OTS=Nothing

Set Fso=Nothing
Set Shell=Nothing
Set ShellApp=Nothing
Wscript.Quit