Add a Web Site to the Internet Explorer Favorites List

By | 2007-05-08

This code allows you to add a favorite to the IE 4 or 5 list of favorites.

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           '' // DBCS
   CSIDL_COMMON_ALTSTARTUP = &H1E    '' // DBCS
   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

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
''Ltrim
    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)

''Rtrim
    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

Author: dwirch

Derek Wirch is a seasoned IT professional with an impressive career dating back to 1986. He brings a wealth of knowledge and hands-on experience that is invaluable to those embarking on their journey in the tech industry.

Leave a Reply

Your email address will not be published. Required fields are marked *

This site uses Akismet to reduce spam. Learn how your comment data is processed.