Dim sput As String, ot As String, sLinkName As String

ot = "c:\Program Files\Microsoft Office\OFFICE11\"
sput = Environ$("USERPROFILE") & "\Desktop\"
ChDir sput
sLinkName = Dir("c:\Program Files\Microsoft Office\OFFICE11\*.lnk")
Do While Len(sLinkName) >  0 
    FileCopy ot & sLinkName, sput & sLinkName
    sLinkName = Dir
Loop

Sub CreateShortCut()
Dim WSHShell As Object
Set WSHShell = CreateObject("WScript.Shell")


Dim MyShortcut As Object, MyDesktop As String, DesktopPath As String

' Read desktop path using WshSpecialFolders object
DesktopPath = WSHShell.SpecialFolders("Desktop")

' Create a shortcut object on the desktop
Set MyShortcut = WSHShell.CreateShortCut(DesktopPath & _
"\Shortcut to notepad.lnk")

' Set shortcut object properties and save it
MyShortcut.TargetPath = 
WSHShell.ExpandEnvironmentStrings("%windir%\notepad.exe")
MyShortcut.WorkingDirectory = WSHShell.ExpandEnvironmentStrings("%windir%")
MyShortcut.WindowStyle =  4 
MyShortcut.IconLocation = _
WSHShell.ExpandEnvironmentStrings("%windir%\notepad.exe, 0")
MyShortcut.Save

MsgBox "A shortcut to Notepad now exists on your Desktop."
Set MyShortcut = Nothing
Set WSHShell = Nothing
End Sub