Option Explicit
 
Private Declare Function CreateDirectory Lib "kernel32" Alias "CreateDirectoryA" (ByVal lpPathName As String, lpSecurityAttributes As Long) As Long
Private Declare Function PathFileExists Lib "shlwapi.dll" Alias "PathFileExistsA" (ByVal pszPath As String) As Long
 
Public Enum ShortcutPath
    Desktop
    Programs
    StartMenu
    StartUp
    Favorites
    Recent
    SendTo
' *** Для Windows 2000/XP ***
    NT_AllUsersDesktop
    NT_AllUsersStartMenu
    NT_AllUsersPrograms
    NT_AllUsersStartup
End Enum
 
Public Sub CreateLink(ByVal inDest As ShortcutPath, _
                      ByVal sName As String, _
                      ByVal sPath As String, _
             Optional ByVal HotKey As String = vbNullString, _
             Optional ByVal sIcon As String = vbNullString, _
             Optional ByVal sWorkingDirectory As String = vbNullString, _
             Optional ByVal sSubFolder As String = vbNullString, _
             Optional ByVal WinStyle As VBA.VbAppWinStyle = vbNormalFocus)
    On Error Resume Next
    
    Dim WshShell As Object
    Set WshShell = CreateObject("WScript.Shell")
    
    With WshShell                           ' Выбор каталога, поскольку sPath - был переда ByVal,
        Select Case inDest                  ' можем его со спокойной душой менять
            Case Is = Desktop:               sPath = .SpecialFolders("Desktop")
            Case Is = StartMenu:             sPath = .SpecialFolders("StartMenu")
            Case Is = StartUp:               sPath = .SpecialFolders("StartUp")
            Case Is = Programs:              sPath = .SpecialFolders("Programs")
            Case Is = Favorites:             sPath = .SpecialFolders("Favorites Windows")
            Case Is = Recent:                sPath = .SpecialFolders("Recent Windows")
            Case Is = SendTo:                sPath = .SpecialFolders("SendTo Windows")
            Case Is = NT_AllUsersDesktop:    sPath = .SpecialFolders("AllUsersDesktop")
            Case Is = NT_AllUsersStartMenu:  sPath = .SpecialFolders("AllUsersStartMenu")
            Case Is = NT_AllUsersPrograms:   sPath = .SpecialFolders("AllUsersPrograms")
            Case Is = NT_AllUsersStartup:    sPath = .SpecialFolders("AllUsersStartup")
        End Select
    End With
                                            ' Проверка правильности имен и каталогов...
    If Not Right(sPath, &H1) = "\" Then sPath = sPath & "\"
    If Len(sSubFolder) Then If Not Right(sSubFolder, &H1) = "\" Then sSubFolder = sSubFolder & "\"
    If Not Right(sName, &H4) = ".lnk" Then sName = sName & ".lnk"
    
    sPath = sPath & sSubFolder              ' Ставим путь, и проверяем существует-ли он...
    If PathFileExists(sPath) = &H0 Then Call MkDirEx(sPath)
                                            
    Set WshShell = WshShell.CreateShortCut(sPath & "\" & sName)
                                            ' Ух... какой я экономный 
    With WshShell                           ' Зачем еще один объект создавать ???
        .WindowStyle = WinStyle
        .HotKey = HotKey
        .TargetPath = sPath
        .IconLocation = sIcon
        .Description = sName
        .WorkingDirectory = sWorkingDirectory
        .Save
    End With
    
    Set WshShell = Nothing
End Sub
 
Private Sub MkDirEx(sPath As String)   'Создание каталога любой степени вложенности
    Dim ci As Long, sArray() As String, sBuffer As String
    If Len(sPath) = &H0 Then Exit Sub
    
    sArray = Split(sPath, "\")
    
    For ci = 0 To UBound(sArray) - 1
        sBuffer = sBuffer & sArray(ci) & "\"
        If PathFileExists(sBuffer) = &H0 Then Call CreateDirectory(sBuffer, ByVal &H0)
    Next
End Sub

Ответить

Ответить

Всем большое спасибо!!!!!!!!!!!!!!!

Ответить