Visual Basic Browse/ PIDL / CSIDL Routines

DoAddToFavDlg: Create and Manipulate IE Favourites in Specified Folders
Posted:   Saturday May 17, 1997
Updated:   Monday December 26, 2011
Applies to:   VB4-32, VB5, VB6
Developed with:   VB4-32, Windows 95
OS restrictions:   None
Author:   VBnet - Randy Birch


DoAddToFavDlg: Add and Manipulate IE Favourite Links
IE4 or greater.

This demo builds on the DoAddToFavDlg and DoOrganizeFavDlg APIs adding the ability to create the internet shortcut in other system folders.

As with the related project, the SHGetSpecialFolderLocation is again used, but this time the combo box is loaded with the values that refer to other system components, such as the desktop or start menu.  And just like the other demo, this passes the pidl relating to the specified CSIDL and creates the Favourite in the selected folder.

 BAS Module Code

 Form Code
To a project form add three command buttons (Command1-Command3), four text boxes (Text1-Text4), a combo box (Combo1) and labels as desired. Add the following to the form:

Option Explicit
' Copyright 1996-2011 VBnet/Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
' Distribution: You can freely use this code in your own
'               applications, but you may not reproduce 
'               or publish this code on any web site,
'               online service, or distribute as source 
'               on any media without express permission.
Private Const MAX_PATH As Long = 260
Private Const ERROR_SUCCESS As Long = 0
Private Const S_OK As Long = 0
Private Const S_FALSE As Long = 1
Private Const SHGFP_TYPE_CURRENT As Long = &H0            'current value for user, verify it exists
Private Const SHGFP_TYPE_DEFAULT As Long = &H1
Private Const CSIDL_PROGRAMS As Long = &H2                'Start Menu\Programs
Private Const CSIDL_PERSONAL As Long = &H5                'My Documents
Private Const CSIDL_FAVORITES As Long = &H6               '{user name}\Favourites
Private Const CSIDL_STARTUP As Long = &H7                 'Start Menu\Programs\Startup
Private Const CSIDL_STARTMENU As Long = &HB               '{user name}\Start Menu
Private Const CSIDL_DESKTOPDIRECTORY As Long = &H10       '{user name}\Desktop
Private Const CSIDL_TEMPLATES As Long = &H15
Private Const CSIDL_COMMON_STARTMENU As Long = &H16       'All Users\Start Menu
Private Const CSIDL_COMMON_PROGRAMS As Long = &H17        'All Users\Programs
Private Const CSIDL_COMMON_STARTUP As Long = &H18         'All Users\Startup
Private Const CSIDL_COMMON_DESKTOPDIRECTORY As Long = &H19'All Users\Desktop

Private Declare Function DoAddToFavDlg Lib "shdocvw" _
  (ByVal hWnd As Long, _
   ByVal szPath As String, _
   ByVal nSizeOfPath As Long, _
   ByVal szTitle As String, _
   ByVal nSizeOfTitle As Long, _
   ByVal pidl As Long) As Long
Private Declare Function DoOrganizeFavDlg Lib "shdocvw" _
  (ByVal hWnd As Long, _
   ByVal lpszRootFolder As String) As Long

Private Declare Function SHGetFolderPath Lib "shfolder" _
   Alias "SHGetFolderPathA" _
  (ByVal hwndOwner As Long, _
   ByVal nFolder As Long, _
   ByVal hToken As Long, _
   ByVal dwReserved As Long, _
   ByVal lpszPath As String) As Long

Private Declare Function SHGetSpecialFolderLocation Lib "shell32" _
  (ByVal hwndOwner As Long, _
   ByVal nFolder As Long, _
   pidl As Long) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32" _
   Alias "WritePrivateProfileStringA" _
  (ByVal lpSectionName As String, _
   ByVal lpKeyName As Any, _
   ByVal lpString As Any, _
   ByVal lpFileName As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32" _
   (ByVal pv As Long)

Private Sub Form_Load()

   Text1.Text = "VBnet Developers Resource Centre"
   Text2.Text = ""
   Text3.Text = ""
   Text4.Text = ""
  With Combo1
      .AddItem "CSIDL_PROGRAMS"
      .ItemData(.NewIndex) = &H2
      .AddItem "CSIDL_PERSONAL"
      .ItemData(.NewIndex) = &H5
      .AddItem "CSIDL_FAVORITES"
      .ItemData(.NewIndex) = &H6
      .AddItem "CSIDL_STARTUP"
      .ItemData(.NewIndex) = &H7
      .AddItem "CSIDL_STARTMENU"
      .ItemData(.NewIndex) = &HB
      .ItemData(.NewIndex) = &H10
      .AddItem "CSIDL_TEMPLATES"
      .ItemData(.NewIndex) = &H15
      .ItemData(.NewIndex) = &H16
      .ItemData(.NewIndex) = &H17
      .ItemData(.NewIndex) = &H18
      .ItemData(.NewIndex) = &H19
      .AddItem "CSIDL_APPDATA"
      .ItemData(.NewIndex) = &H1A
      .ItemData(.NewIndex) = &H1F
      .ItemData(.NewIndex) = &H23
      .ListIndex = 2  'default to Favourites
   End With
End Sub

Private Sub Command1_Click()

   Dim szTitle As String
   Dim sURL As String
   Dim sResult As String
   Dim CSIDL As Long

  'assign a title to the url. This is the
  'name that appears under Favourites
   szTitle = Text1.Text
  'assign the url. This is the
  'value saved to the Favourite file.
   sURL = Text2.Text
  'get the CSIDL value representing the
  'root folder selected in the combo
   CSIDL = Combo1.ItemData(Combo1.ListIndex)
  'call the Make routine, returning the
  'file created as a success
   sResult = MakeFavouriteEntrySpecial(szTitle, sURL, CSIDL)
   Text1.Text = szTitle
   Text2.Text = sURL
   Text3.Text = sResult
   Text4.Text = CSIDL

End Sub

Private Sub Command2_Click()

   Dim lpszRootFolder As String
   Dim success As Long
   Dim CSIDL As Long

  'open the organize folder at the path specified by the CSIDL
   CSIDL = Combo1.ItemData(Combo1.ListIndex)
   lpszRootFolder = GetFolderPath(CSIDL)
   success = DoOrganizeFavDlg(hWnd, lpszRootFolder)
End Sub

Private Sub Command3_Click()

   Unload Me
End Sub

Private Sub Combo1_Click()

   Text4.Text = Combo1.ItemData(Combo1.ListIndex)
   Text3.Text = ""

End Sub

Private Function MakeFavouriteEntrySpecial(szTitle As String, _
                                           sURL As String, _
                                           CSIDL As Long) As String

   Dim success As Long
   Dim pos As Long
   Dim nSizeOfPath As Long
   Dim nSizeOfTitle As Long
   Dim pidl As Long
   Dim szPath As String
  'set up the szTitle size, appending a chr$(0)
   szTitle = szTitle & Chr$(0)
   nSizeOfTitle = Len(szTitle)
  'pad a string for the return path
   szPath = Space$(MAX_PATH) & Chr$(0)
   nSizeOfPath = Len(szPath)
  'get the PIDL (pointer to item identifier list)
  'of the user's Favourites path
   success = SHGetSpecialFolderLocation(hWnd, CSIDL, pidl)
  'if the call is successful, the return value is 0
   If success = ERROR_SUCCESS Then
     'call the Add to Favourites dialog.
     'hwnd   =  the owner of the dialog, in this case our form.
     'szPath =  the absolute path returned to the selected folder,
     '          including the full file name appended, and the
     '          requisite .url extension. For example, on my system,
     '          using the Title specified above, and saving the file
     '          to the root Favourites folder, the szPath returned is:
     '          C:\WINNT\Profiles\birchr\Favorites\VBnet Res Centre.url
     'szTitle = the title (Favourite name) for the URL
     'pidl    = the PIDL representing the user's Favourites folder
      success = DoAddToFavDlg(hWnd, _
                              szPath, nSizeOfPath, _
                              szTitle, nSizeOfTitle, _

     'if a valid file path and title was specified,
     'and the user pressed OK, success will = 1
      If success = 1 Then
        'remove trailing nulls
         pos = InStr(szPath, Chr$(0))
         szPath = Left(szPath, pos - 1)
         pos = InStr(szTitle, Chr$(0))
         szTitle = Left(szTitle, pos - 1)
        'show the results in the text boxes
         Text1.Text = szPath
         Text2.Text = szTitle
        'a little tom-foolery. Since a favourite link
        'is nothing more than an ini file entry, we can
        'use the WritePrivateProfileString API to create
        'the Favourite entry! The 'ini file name' will
        'be the szPath returned value from the
        'DoAddToFavDlg call, and the value saved to
        'the file will be the URL passed to this procedure
         Call ProfileSaveItem("InternetShortcut", "URL", sURL, szPath)
        'return the path/file created as a measure of success
         MakeFavouriteEntrySpecial = szPath
      End If
     'clean up by freeing the PIDL
      Call CoTaskMemFree(pidl)

   End If

End Function

Private Sub ProfileSaveItem(lpSectionName As String, _
                            lpKeyName As String, _
                            lpValue As String, _
                            iniFile As String)

  'This function saves the passed value to the file,
  'under the section and key name specified.
  'If the ini file does not exist, it is created.
  'If the section does not exist, it is created.
  'If the key name does not exist, it is created.
  'If the key name exists, its value is replaced.
   Call WritePrivateProfileString(lpSectionName, _
                                  lpKeyName, _
                                  lpValue, _

End Sub

Private Function GetFolderPath(CSIDL As Long) As String

   Dim sPath As String
   Dim sTmp As String
  'fill pidl with the specified folder item
   sPath = Space$(MAX_PATH)
   If SHGetFolderPath(Me.hWnd, _
                      CSIDL, 0&, _
                      SHGFP_TYPE_CURRENT, _
                      sPath) = S_OK Then
       GetFolderPath = Left$(sPath, InStr(sPath, Chr$(0)) - 1)
   End If
End Function
Set the values of Text1 and Text2 as desired, select a target path from the combo box, then click the Add To Favourites button. The dialog will appear with the selected path rooted (navigation outside the folder is not possible). Navigate and edit as desired, and on closing, the URL will be saved into the folder / filename selected. By changing the CSIDL value, the Organize button will open at the folder specified in the combo box, allowing all the usual dialog options such as creating new folders, deleting, renaming or moving files.


PayPal Link
Make payments with PayPal - it's fast, free and secure!


Copyright 1996-2011 VBnet and Randy Birch. All Rights Reserved.
Terms of Use  |  Your Privacy


Hit Counter