Option Explicit
Public Enum SpecialShellFolderIDs
CSIDL_DESKTOP = &H0
CSIDL_INTERNET = &H1
CSIDL_PROGRAMS = &H2
CSIDL_CONTROLS = &H3
CSIDL_PRINTERS = &H4
CSIDL_PERSONAL = &H5
CSIDL_FAVORITES = &H6
CSIDL_STARTUP = &H7
CSIDL_RECENT = &H8
CSIDL_SENDTO = &H9
CSIDL_BITBUCKET = &HA
CSIDL_STARTMENU = &HB
CSIDL_DESKTOPDIRECTORY = &H10
CSIDL_DRIVES = &H11
CSIDL_NETWORK = &H12
CSIDL_NETHOOD = &H13
CSIDL_FONTS = &H14
CSIDL_TEMPLATES = &H15
CSIDL_COMMON_STARTMENU = &H16
CSIDL_COMMON_PROGRAMS = &H17
CSIDL_COMMON_STARTUP = &H18
CSIDL_COMMON_DESKTOPDIRECTORY = &H19
CSIDL_APPDATA = &H1A
CSIDL_PRINTHOOD = &H1B
CSIDL_ALTSTARTUP = &H1D
CSIDL_COMMON_ALTSTARTUP = &H1E
CSIDL_COMMON_FAVORITES = &H1F
CSIDL_INTERNET_CACHE = &H20
CSIDL_COOKIES = &H21
CSIDL_HISTORY = &H22
End Enum
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As SpecialShellFolderIDs, pidl As Long) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Public Function AddFavorite(SiteName As String, URL As String) As Boolean
'SiteName - название сайта, URL - адрес сайта в Инете
Dim pidl As Long
Dim psFullPath As String
Dim iFile As Integer
On Error GoTo ErrorHandler
iFile = FreeFile
psFullPath = Space(255)
If SHGetSpecialFolderLocation(0, CSIDL_FAVORITES, pidl) = 0 Then
If pidl Then
If SHGetPathFromIDList(pidl, psFullPath) Then
psFullPath = TrimWithoutPrejudice(psFullPath)
If Right(psFullPath, 1) <> "\" Then psFullPath = psFullPath & "\"
psFullPath = psFullPath & SiteName & ".URL"
Open psFullPath For Output As #iFile
Print #iFile, "[InternetShortcut]"
Print #iFile, "URL=" & URL
Close #iFile
End If
CoTaskMemFree pidl
AddFavorite = True
End If
End If
ErrorHandler:
End Function
Public Function TrimWithoutPrejudice(ByVal InputString As String) As String
Dim sAns As String
Dim sWkg As String
Dim sChar As String
Dim lLen As Long
Dim lCtr As Long
sAns = InputString
lLen = Len(InputString)
If lLen > 0 Then
For lCtr = 1 To lLen
sChar = Mid(sAns, lCtr, 1)
If Asc(sChar) > 32 Then Exit For
Next
sAns = Mid(sAns, lCtr)
lLen = Len(sAns)
If lLen > 0 Then
For lCtr = lLen To 1 Step -1
sChar = Mid(sAns, lCtr, 1)
If Asc(sChar) > 32 Then Exit For
Next
End If
sAns = Left$(sAns, lCtr)
End If
TrimWithoutPrejudice = sAns
End Function

Private Sub Form_Load()
AddFavorite "Сайт Visual Progs", "http://visualprogs.medyal.ru/"
End Sub