' Author: Perikov Vadim
'«Microsoft Shell Controls And Automation» (????? Shell32.dll)
Option Explicit
Private Declare Function lcreat Lib "kernel32" Alias "_lcreat" (ByVal lpPathName As String, ByVal iAttribute As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Const Delim = "\"
Public Function CreateShortcut(ByVal fCreateFileLnk As String, ByVal fFileObject As String, Optional ByVal fArguments As String = "", Optional ByVal fWorkingDir As String = "", Optional ByVal fDescription As String = "", Optional ByVal fShowCommand As Long = 1, Optional ByVal fFileIcon As String = "", Optional ByVal fIconNumber As Long = 0, Optional ByVal fHotkey As Long = 0) As Long
Dim fsHwnd As Long
Dim fsDl As Long
Dim csShell As Shell
Dim csFolder As Folder
Dim csItem As FolderItem
Dim fsLink As ShellLinkObject
On Error GoTo Errors
fsHwnd = lcreat(fCreateFileLnk, 0)
fsDl = CloseHandle(fsHwnd)
Set csShell = New Shell
Set csFolder = csShell.NameSpace(Left$(fCreateFileLnk, InStrRev(fCreateFileLnk, Delim, , 1) - 1))
Set csItem = csFolder.ParseName(Mid$(fCreateFileLnk, InStrRev(fCreateFileLnk, Delim, , 1) + 1))
If csItem.IsLink = True Then
Set fsLink = csItem.GetLink
End If
fsLink.Path = fFileObject
fsLink.Arguments = fArguments
fsLink.WorkingDirectory = fWorkingDir
fsLink.Description = fDescription
fsLink.ShowCommand = fShowCommand
' Hotkey
'512 - <Ctrl>
'1024 - <Alt>
'512+1024 - <Ctrl+Alt>
If fHotkey > 0 And fHotkey < 256 Then fsLink.HotKey = 512 + 1024 + fHotkey
fsLink.SetIconLocation fFileIcon, fIconNumber
fsLink.Save
If Not (fsLink Is Nothing) Then Set fsLink = Nothing
If Not (csItem Is Nothing) Then Set csItem = Nothing
If Not (csFolder Is Nothing) Then Set csFolder = Nothing
If Not (csShell Is Nothing) Then Set csShell = Nothing
CreateShortcut = 1
Exit Function
Errors:
CreateShortcut = 0
End Function
Sub test()
CreateShortcut "c:\windows\escritorio\Acceso Directo a pp.lnk", "c:\windows\escritorio\pp\"
End Sub
Saludos desde Baires, JuanC
