fortypoundhead.com

Add a Web Site to the Internet Explorer Favorites List

Posted On 2007-05-08 by FortyPoundHead
Keywords:
Tags: Visual Basic 6 
Views: 1798


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.80.58.75

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



Recent Forum Posts

List of Shady Characters
dwirch posted on April 25, 2017 at about 16:39 in Webmaster Stuff

Job Spammer: Bilal Uddin
dwirch posted on April 25, 2017 at about 11:00 in Spammers

Bug Fix: Contact Form Error
dwirch posted on April 21, 2017 at about 11:38 in Site News

Bug Fix: Ophion Time Tracker
dwirch posted on April 9, 2017 at about 11:30 in Site News

Job Spammer: Yogesh Kapadne
dwirch posted on March 31, 2017 at about 8:04 in Spammers

Job Spammer: Sathya Narayana
dwirch posted on March 15, 2017 at about 7:18 in Spammers