Создание ярлыка и копирование в папку

' записать в реестр
Set Reg = CreateObject("WScript.Shell")
Reg.RegWrite "HKLM\Software\Microsoft\Windows\CurrentVersion\Run\Имя твоей проги", "Путь к твоей проге"
 
' утрать из реестра
Set Reg = CreateObject("WScript.Shell")
Reg.RegDelete "HKLM\Software\Microsoft\Windows\CurrentVersion\Run\Имя твоей проги"

Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Sub Form_Load()
Dim strSysDir As String
  Dim RetLen As Long
  strSysDir = String$(256, Chr$(0))
   RetLen = GetSystemDirectory(strSysDir, 255)
   strSysDir = Left$(strSysDir, RetLen)
   MsgBox "Системная папка: " & strSysDir
End Sub

Private Sub Form_Load()
Debug.Print Environ("WINDIR")
Debug.Print Environ("USERPROFILE")
Debug.Print Environ("ProgramFiles")
End Sub

 
' Пример для сервера сценариев Windows
'
' ------------------------------------------------------------------------
'                     (C) Корпорация Microsoft, 1996-1998
'
' Вы имеете право, не требующее дополнительных лицензионных платежей, 
' на использование, изменение, воспроизведение и распространение файлов
' примеров (и любой измененной версии) любым способом, учитывая, что
' Корпорация Microsoft не предоставляет гарантий и обязательств, 
' а также не несет ответственности за любой из файлов примеров
' ------------------------------------------------------------------------
 
' Этот пример демонстрирует возможности использования объекта WshShell
' для создания ярлыка на рабочем столе
 
L_Welcome_MsgBox_Message_Text   = "Этот пример создает ярлык для Блокнота на рабочем столе."
L_Welcome_MsgBox_Title_Text     = "Пример сервера сценариев Windows"
Call Welcome()
 
' *****************************************************************************
' *
' * Методы работы с ярлыком.
' *
 
Dim WSHShell
Set WSHShell = WScript.CreateObject("WScript.Shell")
 
 
Dim MyShortcut, MyDesktop, DesktopPath
 
' Получение доступа к рабочему столу используя объект WshSpecialFolders
DesktopPath = WSHShell.SpecialFolders("Desktop")
 
' Создание ярлыка на рабочем столе
Set MyShortcut = WSHShell.CreateShortcut(DesktopPath & "\На Блокнот.lnk")
 
' Установка и запись свойств ярлыка
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
 
WScript.Echo "Ярлык на Блокнот создан на рабочем столе."
 
' ****************************************************************************
' *
' * Приветствие
' *
Sub Welcome()
    Dim intDoIt
 
    intDoIt =  MsgBox(L_Welcome_MsgBox_Message_Text,    _
                      vbOKCancel + vbInformation,       _
                      L_Welcome_MsgBox_Title_Text )
    If intDoIt = vbCancel Then
        WScript.Quit
    End If
End Sub

'****************************************************************************
'* Script utility for managing shortcut files
'* ver 1.07 2011.07.27
'* Programmed by Polyakov A.N. mailto:xey@yandex.ru
'****************************************************************************
'
' Add Shortcut  - lnk.vbs /add   <shortcut> <target> [args] [work_dir] [icon] [win_style] [hot_key] [descr]
' Get Shortcut  - lnk.vbs /get   <shortcut>
' Get Script    - lnk.vbs /get!  <shortcut>
'   or          - lnk.vbs /getscript <shortcut>
' Find Shortcut - lnk.vbs /find  <folder>   <target_to_find> [args_to_find]
 
' <shortcut> : [sf:SpecialFolder\]Path\ShortcutFile[.lnk]
' <folder>   : [sf:SpecialFolder\]Path
'
' SpecialFolder :
'   Desktop           - Рабочий стол
'   Favorites         - Избранное
'   Fonts             - Шрифты
'   MyDocuments       - Мои документы
'   NetHood           - Сетевое окружение
'   PrintHood         - Принтеры
'   Programs          - подменю Программы из меню Пуск
'   Recent            - подменю Документы из меню Пуск
'   SendTo            - подменю Отправить из контекстного меню файлов
'   StartMenu         - Главное меню
'   Startup           - Автозагрузка из подменю Программы
'   Templates         - Шаблоны
' Only WinNT/2000/XP/2003 :
'   AllUsersDesktop   - Рабочий стол всех пользователей
'   AllUsersStartMenu - Главное меню всех пользователей
'   AllUsersPrograms  - подменю Программы из меню Пуск всех пользователей
'   AllUsersStartup   - Автозагрузка из подменю Программы всех пользователей
 
' [icon] : IconFileName,IconIndex
'   Index 0 is first icon in the file
 
' [win_style] : 3 - Maximize, 4 - Standard, 7 - Minimze
 
' [hot_key] : ALT+SHIFT+<Chr>,  CTRL+ALT+<Chr>,
'             CTRL+SHIFT+<Chr>, ALT+CTRL+SHIFT+<Chr>
 
' <target_to_find> : target|rx:RegExped_Target
' [args_to_find]   : args|rx:RegExped_Args
 
' [args]           special symbols : ^  -> "
'                                    ^^ -> ^
 
rem BEGIN
 
' ver 1.07 2011.07.27 - add alias "/getscript" for "/get!" key
' ver 1.06 2010.04.18 - add special symbols ^ for "
' ver 1.05 2009.09.01 - add return code (for %ERRORLEVEL% variable)
' ver 1.04 2008.10.30 - fix <shortcut> parsing; fix SpecialFolder order; create folders for /add
' ver 1.03 2008.08.27 - add /find key
' ver 1.02 2007.06.16 - support URL-links
' ver 1.01 2006.12.08 - check lnk-file existance; change output format
' ver 1.00 2006.01.21
 
on Error Resume Next
 
const forRead=1
const forWrite=2
 
dim lnk_file, url, target, arg, path, shortcut_name, work_dir, icon, win_style
dim shell, shortcut, parentFolder, fso, fo, rx, colFile, objFile, objFldr
dim Q, ext, rx1, rx2
 
set shell = WScript.CreateObject("WScript.Shell")
set fso = CreateObject("Scripting.FileSystemObject")
 
outCon=right(LCase(wScript.FullName),11)="cscript.exe"
 
nl = chr(13) & chr(10)
 
set pars = WScript.Arguments
cnt=pars.count
 
if cnt<2 then
   ShowHelp
end if
 
 
cmd=LCase(pars(0))
 
lnk_file=pars(1)
 
if LCase(left(lnk_file,3))="sf:" then
   arr1=split(pars(1),"\")
   arr2=split(arr1(LBound(arr1)),":")
   lnk_file=replace(pars(1),arr1(LBound(arr1)),shell.SpecialFolders(arr2(LBound(arr2)+1)))
end if
 
 
if cmd="/getscript" then cmd="/get!"
 
if cmd="/find" then
   if cnt<3 then ShowHelp
 
   folder=lnk_file
 
   target=LCase(trim(pars(2)))
   rx1=left(target,3)="rx:"
   if rx1 then target=right(target,len(target)-3)
 
   if cnt>3 then args=LCase(trim(pars(3))) else args=""
   rx2=left(args,3)="rx:"
   if rx2 then args=right(args,len(args)-3)
 
   if rx1 or rx2 then
      set rx=new RegExp
      rx.IgnoreCase=true
   end if
 
   set colFile=fso.getFolder(folder).Files
   for each objFile in colFile
     lnk_file=objFile.Name
     ext=LCase(right(lnk_file,3))
     if (ext="lnk") or (ext="url") then
        set shortcut = shell.CreateShortcut(folder & "\" & lnk_file)
        Q=false
        if rx1 then
           rx.pattern=target
           Q=rx.test(LCase(shortcut.TargetPath))
        else
           Q=LCase(shortcut.TargetPath)=target
        end if
        if len(args)>0 then
           if rx2 then
              rx.pattern=args
              Q=Q and rx.test(LCase(shortcut.Arguments))
           else
              Q=Q and LCase(shortcut.Arguments)=args
           end if
        end if
        if Q then WScript.echo folder & "\" & lnk_file
     end if
   next
   WScript.quit
end if
 
url=false
 
if cmd="/add" then
   if cnt<3 then ShowHelp
 
   target=trim(pars(2))
   url=Instr(target,"://")>0
 
   if not url then
      if cnt>3 then args=repl2(trim(pars(3)),"^^","^","^",chr(34)) else args=""
      if cnt>4 then work_dir=trim(pars(4)) else work_dir=""
 
      if len(work_dir)=0 then
         set fso = CreateObject("Scripting.FileSystemObject")
         set fo  = fso.getFile(target)
         if (Err.Number<>0) then
            Err.clear
         else
            if fo.type<>"" then
               work_dir=fo.parentFolder
            end if
         end if
      end if
 
      icon=""
      if cnt>5 then
         icon=trim(pars(5))
      end if
 
      win_style=4
      if cnt>6 then
         win_style=trim(pars(6))
      end if
 
      hot_key=""
      if cnt>7 then
         hot_key=UCase(trim(pars(7)))
      end if
 
      descr=""
      if cnt>8 then
         descr=trim(pars(8))
      end if
   end if
end if
 
 
S=LCase(right(lnk_file,4))
if (S<>".lnk") and (S<>".url") then
   S=".lnk"
   if url then
      S=".url"
   end if
   lnk_file=lnk_file & S
end if
 
 
QRet=0
 
Q=fso.FileExists(lnk_file)
set shortcut = shell.CreateShortcut(lnk_file)
 
select case cmd
  case "/add"
    set objFldr=fso.CreateFolder(fso.GetParentFolderName(lnk_file))
    shortcut.TargetPath=target
    shortcut.IconLocation=icon
    if not url then
       shortcut.Arguments=args
       shortcut.WorkingDirectory=work_dir
       shortcut.IconLocation=icon
       shortcut.WindowStyle=win_style
       shortcut.HotKey=hot_key
       shortcut.Description=descr
    end if
    Err.clear
    shortcut.save
    QRet=Err.Number
 
  case "/get"
    if Q then
       target=shortcut.TargetPath
       args=shortcut.Arguments
       work_dir=shortcut.WorkingDirectory
       icon=shortcut.IconLocation
       win_style=shortcut.WindowStyle
       hot_key=shortcut.Hotkey
       descr=shortcut.Description
       Error=""
    else
       Error=" ERROR: (FILE DON'T EXIST) "
       QRet=1
    end if
 
    wscript.echo "Shortcut File   =" & Error & lnk_file
    wscript.echo "TargetPath      =" & target
    wscript.echo "Arguments       =" & args
    wscript.echo "WorkingDirectory=" & work_dir
    wscript.echo "IconLocation    =" & icon
    wscript.echo "WindowStyle     =" & win_style
    wscript.echo "HotKey          =" & hot_key
    wscript.echo "Description     =" & descr
 
  case "/get!"
    if Q then
       lnk_file=replace(sf(lnk_file),"%","%%")
       target=replace(sf(shortcut.TargetPath),"%","%%")
       args=shortcut.Arguments
       work_dir=replace(sf(shortcut.WorkingDirectory),"%","%%")
       icon=replace(sf(shortcut.IconLocation),"%","%%")
       win_style=shortcut.WindowStyle
       hot_key=shortcut.Hotkey
       descr=shortcut.Description
 
       S="cscript.exe //NoLogo " & wScript.ScriptName & " /add "
       S=S & qw(lnk_file) & " "
       S=S & qw(target) & " "
       S=S & qw(args) & " "
       S=S & qw(work_dir) & " "
       S=S & qw(icon) & " "
       S=S & qw(win_style) & " "
       S=S & qw(hot_key) & " "
       S=S & qw(descr)
    else
       QRet=1
    end if
    wscript.echo S
end select
 
wScript.quit(QRet)
 
 
sub ShowHelp
   set fso = CreateObject("Scripting.FileSystemObject")
   set fo = fso.GetFile(wScript.ScriptFullName)
 
   set txt = fo.OpenAsTextStream(forRead)
   S=""
   Q=false
   while not Q
     T=trim(txt.ReadLine)
     Q=(len(T)>0) and (left(T,1)<>"'")
     if not Q then
        if len(T)>0 then S=S & right(T,len(T)-1)
        S=S & vbCrLf
     end if
   wend
   txt.close
   wScript.echo S
   wScript.quit
end sub
 
 
function qw(T)
  Ret=chr(34) & T & chr(34)
  qw=Ret
end function
 
 
function repl2(SS,old1,new1,old2,new2)
  Ret=""
  if len(old1)<len(old2) then
     C=old2
     old2=old1
     old1=C
     C=new2
     new2=new1
     new1=C
  end if
 
  arr=split(SS,old1)
 
  for J=0 to UBound(arr)
    if J>0 then
       Ret=Ret & new1
    end if
    Ret=Ret & replace(arr(J),old2,new2)
  next
 
  repl2=Ret
end function
 
 
function sf(path)
  dim f(16)
 
  Ret=path
 
  f(1)= "AllUsersStartup"
  f(2)= "AllUsersPrograms"
  f(3)= "AllUsersStartMenu"
  f(4)= "AllUsersDesktop"
  f(5)= "Startup"
  f(6)= "Programs"
  f(7)= "StartMenu"
  f(8)= "Desktop"
  f(9)= "Favorites"
  f(10)="Fonts"
  f(11)="MyDocuments"
  f(12)="NetHood"
  f(13)="PrintHood"
  f(14)="Recent"
  f(15)="SendTo"
  f(16)="Templates"
 
  S0=LCase(path)
  set sh=wScript.createObject("wScript.Shell")
 
  for I=1 to 16
    S1=LCase(sh.SpecialFolders(f(I)))
    if instr(S0,S1)=1 then
       Ret="sf:" & f(I) & right(path,len(S0)-len(S1))
       exit for
    end if
  next
  sf=Ret
end function

'Создание/изменение ярлыка
Private Sub CreateLink(ByVal LinkFullName As String, ByVal LinkTargetPath As String, _
    Optional ByVal LinkArguments As String = "", Optional ByVal LinkWorkingDirectory As String = "", _
    Optional ByVal LinkIconLocation As String = ",0", Optional ByVal LinkHotkey As String = "", _
    Optional ByVal LinkWindowStyle As Long = WshNormalFocus, Optional ByVal LinkDescription As String = "")
    Dim oShellLink As Object
    'Создание Объекта WshShortcut
    Set oShellLink = WshShell.CreateShortcut(LinkFullName)
    With oShellLink
        'Передаем аргументы командной строки
        .Arguments = LinkArguments
        'Устанавливаем описание ярлыка
        .Description = LinkDescription
        'Устанавливаем клавиши быстрого вызова
        .Hotkey = LinkHotkey
        'Устанавливаем значек
        .IconLocation = LinkIconLocation
        'Устанавливаем путь к файлу
        .TargetPath = LinkTargetPath
        'Устанавливаем стиль запуска
        .WindowStyle = LinkWindowStyle
        'Устанавливаем рабочий каталог
        .WorkingDirectory = LinkWorkingDirectory
    End With
    'Сохраняем ярлык
    oShellLink.Save
    'Освобождаем объект WshShortcut
    Set oShellLink = Nothing
End Sub

Private Sub Command1_Click()
Set WshShell = CreateObject("WScript.Shell")
strDesktop = WshShell.SpecialFolders("Desktop") 'переменная strDesktop будет равна пути до рабочего стола будь то путь в windows 7 (C:\Users\Имя пользователя\Desktop) или в windows xp (C:\Documents and settings\Имя пользователя\Рабочий стол)
Set oShellLink = WshShell.CreateShortcut(strDesktop & "\Мой ярлычёк).lnk")  'кто не знает то у ярлыков формат lnk
oShellLink.TargetPath = "Приложение"
oShellLink.WindowStyle = 1
oShellLink.IconLocation = "Значок"
oShellLink.Description = "ярлычок"
oShellLink.WorkingDirectory = "Рабочая папка"
oShellLink.Save
End Sub

' взял тот код, что ранее по поиску написал, но убрал пару строк, связанных с путем ярлыка
 
Private Sub Command1_Click()
Set WshShell = CreateObject("WScript.Shell")
Set oShellLink = WshShell.CreateShortcut(тут путь к ярылку)
oShellLink.TargetPath = "Приложение"
oShellLink.WindowStyle = 1
oShellLink.IconLocation = "Значок"
oShellLink.Description = "ярлычок"
oShellLink.WorkingDirectory = "Рабочая папка"
oShellLink.Save
End Sub

App.Path & "\Ярлык.lnk"

MyShortcut.WorkingDirectory = App.Path