1.

Enum ShortCutDest
    DeskTop
    Programs
    StartMenu
    StartUp
End Enum

Public Function CreateLink(dest As ShortCutDest, ByVal sName As String, ByVal sPath As String, Optional HotKey As String = "", Optional sIcon As String = "", Optional sWorkingDirectory As String = "", Optional sSubFolder As String = "", Optional WinStyle As Integer = vbNormalFocus)
   Dim WshShell As Object
   Dim oShellLink As Object
   Dim sLinkPath As String
   Set WshShell = CreateObject("WScript.Shell")
   Select Case dest
       Case DeskTop
            sLinkPath = WshShell.SpecialFolders("Desktop")
       Case StartMenu
            sLinkPath = WshShell.SpecialFolders("StartMenu")
       Case StartUp
            sLinkPath = WshShell.SpecialFolders("StartUp")
       Case Programs
            sLinkPath = WshShell.SpecialFolders("Programs")
   End Select
   On Error Resume Next
   If sSubFolder <> "" Then
      sLinkPath = sLinkPath & "\" & sSubFolder
      If Dir(sLinkPath) = "" Then MkDir sLinkPath
   End If
   On Error GoTo 0
   Set oShellLink = WshShell.CreateShortCut(sLinkPath & "\" & sName & ".lnk")
   oShellLink.WindowStyle = WinStyle
   oShellLink.HotKey = sHotKey
   oShellLink.TargetPath = sPath
   oShellLink.IconLocation = sIcon
   oShellLink.Description = sName
   oShellLink.WorkingDirectory = sWorkingDirectory
   oShellLink.Save
   Set oShellLink = Nothing
   Set WshShell = Nothing
End Function

Private Sub Command1_Click()
' Создание ярлыка на рабочем столе
   CreateLink DeskTop, "Calculator", "c:\windows\calc.exe", "CTRL+SHIFT+C", "calc.exe,0", "c:\windows"
' Создание ярлыка в Автозагрузке
   CreateLink StartUp, "Calculator", "c:\windows\calc.exe", "CTRL+SHIFT+C", "calc.exe,0", "c:\windows"
' Создание ярлыка
   CreateLink StartMenu, "Calculator", "c:\windows\calc.exe", "CTRL+SHIFT+C", "calc.exe,0", "c:\windows"
'Создание ярлыка в меню программы
   CreateLink Programs, "Calculator", "c:\windows\calc.exe", "CTRL+SHIFT+C", "calc.exe,0", "c:\windows", "WinCalc"
   CreateLink Programs, "Помощь", "c:\windows\help\calc.hlp", "", "winhlp32.exe,0", "c:\windows\help", "WinCalc"
   CreateLink Programs, "Visit our web site", http://www.vbnet.ru", , "shdocvw.dll,0", , "WinCalc", vbMinimizedFocus
End Sub

2.

Private Declare Function SHBrowseForFolder Lib "shell32.dll" (pData As DBRinfo) As Long
Private Declare Function SHGetPathFromIDList Lib "Shell32" Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, ByVal pszPath As String) As Long

Public Declare Function SHGetSpecialFolderPath Lib "shell32.dll" Alias "SHGetSpecialFolderPathA" _
(ByVal hwndOwner As Long, ByVal lpszPath As String, ByVal nFolder As Long, _
ByVal fCreate As Long) As Long

Private Type DBRinfo
     hwndOwner As Long
     pidlRoot As String
     pszDisplayName As String
     lpszTitle As String
     ulFlags As Long
     lpfn As Long
     lParam As Long
     iImage As Integer
End Type

Public Enum nFolders
    ssfALTSTARTUP = 29
    ssfAPPDATA = 26
    ssfBITBUCKET = 10
    ssfCOMMONALTSTARTUP = 30
    ssfCOMMONAPPDATA = 35
    ssfCOMMONDESKTOPDIR = 25
    ssfCOMMONFAVORITES = 31
    ssfCOMMONPROGRAMS = 23
    ssfCOMMONSTARTMENU = 22
    ssfCOMMONSTARTUP = 24
    ssfCONTROLS = 3
    ssfCOOKIES = 33
    ssfDESKTOP = 0
    ssfDESKTOPDIRECTORY = 16
    ssfDRIVES = 17
    ssfFAVORITES = 6
    ssfFONTS = 20
    ssfHISTORY = 34
    ssfINTERNETCACHE = 32
    ssfLOCALAPPDATA = 28
    ssfMYPICTURES = 39
    ssfNETHOOD = 19
    ssfNETWORK = 18
    ssfPERSONAL = 5
    ssfPRINTERS = 4
    ssfPRINTHOOD = 27
    ssfPROFILE = 40
    ssfPROGRAMFILES = 38
    ssfPROGRAMFILESx86 = 48
    ssfPROGRAMS = 2
    ssfRECENT = 8
    ssfSENDTO = 9
    ssfSTARTMENU = 11
    ssfSTARTUP = 7
    ssfSYSTEM = 37
    ssfSYSTEMx86 = 41
    ssfTEMPLATES = 21
    ssfWINDOWS = 36
End Enum

' Вот эта функция
Function BrowseForFolder(Title As String, ResPath As String) As String
Dim DB As DBRinfo
Dim Res As Long
Dim Paths As String
Paths = String(1024, vbNullChar)
DB.lpszTitle = Title
DB.ulFlags = 5
DB.pszDisplayName = String(255, vbNullChar)
Res = SHBrowseForFolder(DB)
SHGetPathFromIDList Res, Paths
BrowseForFolder = Paths
ResPath = Replace(Paths, vbNullChar, "")
End Function

Ответить

Спасибо, понял, попробую

Ответить