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 = "http://vbnet.mvps.org/"
   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
      
      .AddItem "CSIDL_DESKTOPDIRECTORY"
      .ItemData(.NewIndex) = &H10
      
      .AddItem "CSIDL_TEMPLATES"
      .ItemData(.NewIndex) = &H15
      
      .AddItem "CSIDL_COMMON_STARTMENU"
      .ItemData(.NewIndex) = &H16
      
      .AddItem "CSIDL_COMMON_PROGRAMS"
      .ItemData(.NewIndex) = &H17
      
      .AddItem "CSIDL_COMMON_STARTUP"
      .ItemData(.NewIndex) = &H18
      
      .AddItem "CSIDL_COMMON_DESKTOPDIRECTORY"
      .ItemData(.NewIndex) = &H19
      
      .AddItem "CSIDL_APPDATA"
      .ItemData(.NewIndex) = &H1A
      
      .AddItem "CSIDL_COMMON_FAVORITES"
      .ItemData(.NewIndex) = &H1F
      
      .AddItem "CSIDL_COMMON_APPDATA"
      .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, _
                              pidl)

     '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, _
                                  iniFile)

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