1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46
| Option Explicit
Const Key = "HKCU\Software\Microsoft\Windows\CurrentVersion\"
Const ForReading = 1
Dim fso, objFolder, ts, WS, strDesktop, oShellLink, oUrlLink, Ret
Dim lnk, target, icone, WorkDir, Desc, ApName, Apath
Set fso = CreateObject("Scripting.FileSystemObject")
Set WS = WScript.CreateObject("WScript.Shell")
Set ts = fso.OpenTextFile("Raccourcis.txt",ForReading,False)
strDesktop = WS.SpecialFolders("Desktop") & "\"
ApName = "WScript.exe"
Apath = WS.ExpandenvironmentStrings("%windir%") & "\System32\"
WriteRegKey
Do While Not ts.AtEndOfStream
Ret = ts.ReadLine
lnk = Right(Ret, Len(Ret) - InStrRev(Ret,"\")) + ".lnk"
target = Ret
icone = Ret & ",0"
WorkDir = Left(Ret, InStrRev(Ret,"\"))
Desc = Right(Ret, Len(Ret) - InStrRev(Ret,"\"))
If Not fso.FileExists(strDesktop & lnk) Then
CreateLink lnk, target, icone, WorkDir, Desc
End If
Loop
Private Sub CreateLink(lnk, target, icone, WorkDir, Desc)
Set oShellLink = WS.CreateShortcut(strDesktop & lnk)
oShellLink.TargetPath = target
oShellLink.WindowStyle = 1
oShellLink.IconLocation = icone
oShellLink.Description = "Raccourci vers " & Desc
oShellLink.WorkingDirectory = WorkDir
oShellLink.Save
End Sub
' =================
Private Sub WriteRegKey
With WS
On Error Resume Next
If .RegRead(Key & "Run\" & ApName) = "" Or _
.RegRead(Key & "Run\" & ApName) <> Apath & ApName & " " & Wscript.ScriptFullName Then
.RegWrite Key & "Run\" & ApName, Apath & ApName & " " & Wscript.ScriptFullName
Else
Exit Sub
End If
End With
End Sub |