CodeItBetter Programming Another VB Programming Blog

'Internet - How to add Bookmark to Favorites folder

Option Explicit
 
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, _
    ByVal nFolder As SpecialShellFolderIDs, pidl As Long) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
    (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
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
 
Public Sub AddFavorite(SiteName As String, URL As String)
    Dim pidl As Long
    Dim intFile As Integer
    Dim strFullPath As String
    On Error GoTo ErrorHandler
    intFile = FreeFile
    strFullPath = Space(255)
    'Check the API for the folder existence and location
    If SHGetSpecialFolderLocation(0, CSIDL_FAVORITES, pidl) = 0 Then
        If pidl Then
            If SHGetPathFromIDList(pidl, strFullPath) Then
                'Trim any null characters
                If InStr(1, strFullPath,  chr ( 0 ) ) Then
                    strFullPath = Mid(strFullPath, 1, InStr(1, strFullPath,  chr ( 0 ) ) - 1)
                End If
                ' Add back slash, if none exists
                If Right(strFullPath, 1) <> "\" Then
                    strFullPath = strFullPath & "\"
                End If
                ' Create the link
                strFullPath = strFullPath & SiteName & ".URL"
                Open strFullPath For Output As #intFile
                Print #intFile, "[InternetShortcut]"
                Print #intFile, "URL=" & URL
                Close #intFile
            End If
            CoTaskMemFree pidl
        End If
    End If
ErrorHandler:
End Sub
 
'How can I call this function:
Private Sub Form_Load()
    AddFavorite "CodeItBetter", "http://www.codeitbetter.com/"
End Sub