Add a Web Site to the Internet Explorer Favorites List

Posted On 2007-05-08 by FortyPoundHead
Keywords:
Tags: VB6 Miscellaneous 
Views: 1921


PURPOSE: ADDS a Favorite to IE 4 or 5 List of Favorites
INPUT: SiteName = Name of Web Site
URL = URL FOR THE WEB SITE
RETURNS: TRUE IF SUCCESSFUL, FALSE OTHERWISE

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


About the Author

FortyPoundHead has posted a total of 1974 articles.


Comments On This Post

No comments on this post yet!


Do you have a thought relating to this post? You can post your comment here. If you have an unrelated question, you can use the Q&A section to ask it.

Or you can drop a note to the administrators if you're not sure where you should post.


Your IP address is:54.91.16.95

Before you can post, you need to prove you are human. If you log in, this test goes away.




Code Links